Código: trcfwaes.rkt
Descarga aquí
#lang plai
#|--------------------------------------------------------------------------------------------------
- -
- Gramáticas necesarias -
- -
--------------------------------------------------------------------------------------------------|#
;; Gramática para representar los árboles de sintaxis abstracta de TRCFWAE. Estos árboles representan:
;; · Identificadores.
;; · Números.
;; · Operaciones binarias.
;; · Condicional, if0.
;; · Asignaciones locales, with.
;; · Asignaciones locales recursivas, rec.
;; · Funciones anónimas de primera clase, fun.
;; · Aplicación de funciones.
(define-type TRCFWAE
[idS (i symbol?)]
[binopS (op procedure?) (lh TRCFWAE?) (rh TRCFWAE?)]
[numS (n number?)]
[if0S (test-expr TRCFWAE?) (then-expr TRCFWAE?) (else-expr TRCFWAE?)]
[withS (id symbol?) (type Type?) (value TRCFWAE?) (body TRCFWAE?)]
[recS (id symbol?) (value TRCFWAE?) (type Type?) (body TRCFWAE?)]
[funS (param symbol?) (type-param Type?) (type-return Type?) (body TRCFWAE?)]
[appS (fun-expr TRCFWAE?) (arg TRCFWAE?)])
;; Gramática para representar la versión sin azúcar sintáctica de TRCFWAE. Estos árboles representan:
;; · Identificadores.
;; · Números.
;; · Operaciones binarias.
;; · Condicional, if0.
;; · Asignaciones locales recursivas, rec.
;; · Funciones anónimas de primera clase, fun.
;; · Aplicación de funciones.
(define-type RCFAE
[id (i symbol?)]
[num (n number?)]
[binop (op procedure?) (lh RCFAE?) (rh RCFAE?)]
[if0 (test-expr RCFAE?) (then-expr RCFAE?) (else-expr RCFAE?)]
[rec (id symbol?) (value RCFAE?) (body RCFAE?)]
[fun (param symbol?) (body RCFAE?)]
[app (fun-expr RCFAE?) (arg RCFAE?)])
;; Gramática para representar los ambientes de avaluación. Los ambientes son representador por listas
;; en forma de pila, de esta forma un ambiente puede estar vacío o almacenar identificadores con su
;; valor y el siguiente ambiente. Esta versión incluye ambientes recursivos.
;;
;; Un ambiente recursivo, almacenar el cuerpo de la función recursiva en una caja. Aprovechamos los
;; ascpecto imperativos del lenguaje para preservar el estado de la función en la caja, cada que
;; abrimos la caja, obtenemos la misma función.
(define-type Enviroment
[mtSub]
[aSub (id symbol?) (value RCFAE-Value?) (env Enviroment?)]
[aRecSub (id symbol?) (value boxed-RCFAE-Value?) (env Enviroment?)])
;; Predicado que un valor se encuentra en una caja (box?) y que en efecto, el valor que almacena es
;; de tipo RCFAE-Value.
;; boxedd-RCFAE-Value?: any -> boolean
(define (boxed-RCFAE-Value? value)
(and (box? value) (RCFAE-Value? (unbox value))))
;; Gramática para representar los valores devueltos por el intérprete. El intérprete puede devolver:
;; · Números.
;; · Funciones, que más bien son cerraduras. Una cerradura almacena:
;; - Los parámetros de la función.
;; - El cuerpo de la función.
;; - El ambiente donde fue definida.
(define-type RCFAE-Value
[numV (n number?)]
[closureV (param symbol?) (body RCFAE?) (env Enviroment?)])
;; Gramática para representar los ambientes de tipos. Los ambientes son representados por listas en
;; forma de pila, de esta forma un ambiente puede estar vacío o almacenar identificadores con un tipo
;; asociado y el siguiente ambiente.
(define-type TEnviroment
[t-mtSub]
[t-aSub (id symbol?) (type Type?) (env TEnviroment?)])
;; Gramática para representar los tipos del lenguaje.
(define-type Type
[tnumber]
[tarrow (lhs Type?) (rhs Type?)])
#|--------------------------------------------------------------------------------------------------
- -
- Análisis sintácitco -
- -
--------------------------------------------------------------------------------------------------|#
;; Función que recibe una expresión en sintaxis concreta y regresa el árbol de sintaxis abstracta
;; correspondiente.
;; parse: sexp -> TRCFWAE
(define (parse sexp)
(match sexp
[(? symbol?) (idS sexp)]
[(? number?) (numS sexp)]
[(list 'if0 test-expr then-expr else-expr)
(if0S (parse test-expr) (parse then-expr) (parse else-expr))]
[(list 'with (list id ': type value) body)
(withS id (parse-type type) (parse value) (parse body))]
[(list 'rec (list id ': type value) body)
(recS id (parse-type type) (parse value) (parse body))]
[(list 'fun (list param ': param-type) ': return-type body)
(funS param (parse-type param-type) (parse-type return-type) (parse body))]
[(cons x xs)
(case x
[(+ - * /) (binopS (elige x) (parse (car xs)) (parse (cadr xs)))]
[else (appS (parse x) (parse (car xs)))])]))
(define (parse-type t)
(match t
['number (tnumber)]
[(list t1 '-> t2) (tarrow (parse-type t1) (parse-type t2))]))
(define (elige s)
(match s
['+ +]
['- -]
['* *]
['/ /]))
;; Función que recibe una expresión en sintaxis abstracta y regresa una versión desendulzada de
;; ésta. Simplemente convierte with en una aplicación de funciones.
;; desugar: TRCFWAE -> RCFAE
(define (desugar sexp)
(match sexp
[(idS i) (id i)]
[(numS n) (num n)]
[(binopS f lhs rhs) (binop f (desugar lhs) (desugar rhs))]
[(if0S test-expr then-expr else-expr)
(if0 (desugar test-expr) (desugar then-expr) (desugar else-expr))]
[(withS id type value body)
(app (fun id (desugar body)) (desugar value))]
[(recS id type value body)
(rec id (desugar value) (desugar body))]
[(funS param parse-type return-type body)
(fun param (desugar body))]
[(appS fun-expr arg) (app (desugar fun-expr) (desugar arg))]))
#|--------------------------------------------------------------------------------------------------
- -
- Análisis semántico -
- -
--------------------------------------------------------------------------------------------------|#
;; Función que recibe una expresión en sintaxis abstracta y regresa su evaluación. Para evaluar usa
;; un ambiente.
;; interp: RCFAE Enviroment -> RCFAE-Value
(define (interp sexp env)
(match sexp
[(id i) (lookup i env)]
[(num n) (numV n)]
[(binop op lh rh) (numV (op (numV-n (interp lh env)) (numV-n (interp rh env))))]
[(if0 test-expr then-expr else-expr)
(if (zero? (numV-n (interp test-expr env)))
(interp then-expr env)
(interp else-expr env))]
[(rec id value body) (interp body (cyclically-bind-and-interp id value env))]
[(fun param body) (closureV param body env)]
[(app fun-expr arg)
(let ([fun-val (interp fun-expr env)])
(interp
(closureV-body fun-val)
(aSub (closureV-param fun-val)
(interp arg env)
(closureV-env fun-val))))]))
;; Función que busca un valor en el ambiente indicado.
;; lookup: symbol Envirotment -> RCFAE-Value
(define (lookup id env)
(match env
[(mtSub) (error 'lookup "Identificador libre")]
[(aSub sub-id value rest-env)
(if (symbol=? id sub-id)
value
(lookup id rest-env))]
[(aRecSub sub-id value rest-env)
(if (symbol=? id sub-id)
(unbox value) ; Se obtiene un closure que hace referencia al mismo ambiente.
(lookup id rest-env))]))
;; Función que crea el ambiente recursivo.
;; cyclically-bind-and-interp: symbol RCFAE Enviroment -> Enviroment
(define (cyclically-bind-and-interp id value env)
; Creamos la caja que almacenará la función recursiva
(let* ([value-holder (box (numV 1729))]
; Creamos el ambiente y lo asociamos a la caja anterior.
[new-env (aRecSub id value-holder env)]
; Interpretamos el valor, esto nos devuelve un closure que tendrá como ambiente el new-env
[named-expr-val (interp value new-env)])
(begin
; Modificamos la caja. Ahora en lugar de almacenar 1729 almacena el closure con la función
; recursiva.
(set-box! value-holder named-expr-val)
; Regresamos el ambiente. La caja del ambiente tiene la nueva modificación.
new-env)))
#|--------------------------------------------------------------------------------------------------
- -
- Sistema Veriricador de Tipos -
- -
--------------------------------------------------------------------------------------------------|#
;; Función que recibe una expresión en sintaxis abstracta y regresa el tipo asociado.
;; typeof: RCFAE TEnviroment -> Type
(define (typeof expr env)
(match expr
[(idS i) (tlookup i env)]
[(numS n) (tnumber)]
[(binopS f lhs rhs)
(if (and (tnumber? (typeof lhs env)) (tnumber? (typeof rhs env)))
(tnumber)
(error 'typeof "Error de tipo"))]
[(if0S test-expr then-expr else-expr)
(if (and (tnumber? (typeof test-expr env))
(equal? (typeof then-expr env) (typeof else-expr env)))
(tnumber)
(error 'typeof "Error de tipo"))]
[(withS id type value body)
(if (equal? type (typeof value env))
(typeof body (t-aSub id type env))
(error 'typeof "Error de tipo"))]
[(recS id type value body)
(if (equal? type (typeof value env))
(typeof body (t-aSub id type env))
(error 'typeof "Error de tipo"))]
[(funS param param-type return-type body)
(if (equal? return-type (typeof body (t-aSub param param-type env)))
(tarrow param-type return-type)
(error 'typeof "Error de tipo"))]
[(appS fun-expr arg)
(let ([fun-type (typeof fun-expr env)])
(if (and (tarrow? fun-type)
(equal? (tarrow-lhs fun-type) (typeof arg env)))
(tarrow-rhs fun-type)
(error 'typeof "Error de tipo")))]))
(define (tlookup id env)
(match env
[(t-mtSub) (error 'tlookup "Error tlookup")]
[(t-aSub sub-id type rest-env)
(if (symbol=? id sub-id)
type
(tlookup id rest-env))]))