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))]))