Interpretador paso por referencia

#lang eopl
;.

;;procedimientos
;.
;Asignación (lenguaje imperativo)
;.
(define especificacion-lexica
  '(
    (espacio-blanco (whitespace) skip)
    (comentario ("%" (arbno (not #\newline))) skip)
    (identificador (letter (arbno (or letter digit "?"))) symbol)
    (numero (digit (arbno digit)) number)
    (numero ("-" digit (arbno digit)) number)
    (numero (digit (arbno digit) "." digit (arbno digit)) number)
    (numero ("-" digit (arbno digit) "."  digit (arbno digit)) number)
    ))


(define especificacion-gramatical
  '(
    (programa (expresion) a-program)
    (expresion (numero) lit-exp)
    (expresion (identificador) var-exp)
    (expresion (primitiva "(" (separated-list expresion ",") ")") primapp-exp)
    (expresion ("if" expresion "then" expresion "else" expresion) if-exp)
    (expresion ("let" (arbno identificador "=" expresion) "in" expresion) let-exp)
    (expresion ("proc" "(" (separated-list identificador ",") ")" expresion) proc-exp)
    (expresion ("(" expresion (arbno expresion) ")") app-exp)
    ;;Letrec
    (expresion ("letrec" (arbno identificador "(" (separated-list identificador ",") ")" "=" expresion)
                 "in" expresion) letrec-exp)
    ;;asignación
    (expresion ("set" identificador "=" expresion) set-exp)
    (expresion ("begin" expresion (arbno ";" expresion) "end") begin-exp)
    (primitiva ("+") sum-prim)
    (primitiva ("-") menos-prim)
    (primitiva ("*") multiplicacion-prim)
    (primitiva ("add1") sucesor-prim)
    (primitiva ("sub1") antecesor-prim)
    ))

(define-datatype procval procval?
  (closure (larg (list-of symbol?))
           (body expresion?)
           (old-env ambiente?)))

(sllgen:make-define-datatypes especificacion-lexica especificacion-gramatical)

(define interpretador
  (sllgen:make-rep-loop
   "=>"
   (lambda (pgm) (evaluar-programa pgm))
   (sllgen:make-stream-parser especificacion-lexica especificacion-gramatical)
   ))

(define-datatype ambiente ambiente?
  (ambiente-vacio)
  (ambiente-extendido (lvar (list-of symbol?))
                      (lvalor vector?)
                      (amb ambiente?))

  )

(define ambiente-extendido-recursivo
  (lambda (proc-names idds bodies old-env)
    (let* (
           (len (length proc-names))
           (vec (make-vector len))
           (env (ambiente-extendido proc-names vec old-env))
           )
      (letrec
        (
         (actualizar-vector
          (lambda (pos lidds lbodies)
            (cond
              [(null? lidds) env]
              [else
               (begin
                 (vector-set! vec pos (direct-target (closure (car lidds) (car lbodies) env)))
                 (actualizar-vector (+ pos 1) (cdr lidds) (cdr lbodies))
                 )]
              )
            )
          )
         )
        (actualizar-vector 0 idds bodies)
        ))))


(define scheme-value?
  (lambda (l)
    #true))

(define apply-env
  (lambda (amb sym)
    (de-ref (apply-env-ref amb sym))))

;;Esta nueva función retorna es una referencia asociada a una variable
(define apply-env-ref
  (lambda (amb sym)
    (cases ambiente amb
      (ambiente-vacio () (eopl:error "No pude encontrar la variable ~s" sym))
      (ambiente-extendido (lids vec old-env)
                         (letrec
                             (
                              (buscar-ambiente
                               (lambda (pos lids)
                                 (cond
                                   [(null? lids) (apply-env-ref old-env sym)]
                                   [(equal? sym (car lids))
                                    (a-ref pos vec)]
                                   [else  (buscar-ambiente (+ pos 1) (cdr lids))])))
                              )
                           (buscar-ambiente 0 lids))
                         )
      )
    )
  )


(define ambiente-inicial
  (ambiente-extendido '(x y z) (list->vector '(1 2 3))
                      (ambiente-extendido '(a b c) (list->vector '(4 5 6)) (ambiente-vacio))))

(define evaluar-programa
  (lambda (pgm)
    (cases programa pgm
      (a-program (exp) (evaluar-expresion exp ambiente-inicial)))))

(define evaluar-expresion
  (lambda (exp amb)
    (cases expresion exp
      (lit-exp (num) num)
      (var-exp (id) (apply-env amb id))
      (if-exp (condicion true-exp false-exp)
              (if
               (true-value? (evaluar-expresion condicion amb))
               (evaluar-expresion true-exp amb)
               (evaluar-expresion false-exp amb)
              ))
      (let-exp (ids rands body)
              (let
                  (
                  (randsnum (map (lambda (x) (direct-target (evaluar-expresion x amb)) ) rands))
                  )

              (evaluar-expresion body (ambiente-extendido ids (list->vector randsnum) amb))))
      (letrec-exp (proc-names idss bodies body)
         (evaluar-expresion body (ambiente-extendido-recursivo proc-names idss bodies amb))
      )
      (proc-exp (lid body)
                (closure lid body amb))
      (app-exp (rator rands)
               (let
                   (
                    (proc (evaluar-expresion rator amb))
                    (lrands (map (lambda (x) (evaluar-rand-pref x amb)) rands))
                    )
                 (if
                  (procval? proc)
                  (aplicar-procedimiento proc lrands)
                  (eopl:error "Usted esta intentando aplicar un valor que no es un procedimiento")
                  )
                 ))
      ;;Asignación
      (set-exp (id rhs-exp)
               (begin
                 (setref! ;;Cambiamos el valor de la referencia
                  (apply-env-ref amb id) ;;Retorna una referencia
                  (evaluar-expresion rhs-exp amb)
                  )
                 1 ; Valor que significa que la expresión se hizo correctamente
                 )
               )
      (begin-exp (exp exps)
                 (if (null? exps)
                     (evaluar-expresion exp amb)
                     (letrec
                         (
                         ;;¿Que debo hacer aca?
                         ;;Evaluar exp, y luego evlauar la lista, retornando el ultimo de la lista
                         (evaluar-expresiones-begin
                          (lambda (lst)
                            (cond
                              [(null? (cdr lst)) (evaluar-expresion (car lst) amb)]
                              [else
                               (begin
                                 (evaluar-expresion (car lst) amb)
                                 (evaluar-expresiones-begin (cdr lst)))]
                              )
                            )
                          )
                         )
                       (begin
                         (evaluar-expresion exp amb)
                         (evaluar-expresiones-begin exps))
                       )
                     )
                 )
      (primapp-exp (prim lexp)
                   (let
                       (
                        (lnum (map (lambda (x) (evaluar-expresion x amb)) lexp))
                        )
                     (aplicar-primitiva prim lnum)
                   )
      )
    )
  )
)

(define true-value?
  (lambda (num)
    (not (zero? num))))

(define aplicar-primitiva
  (lambda (prim lnum)
    (cases primitiva prim
      (sum-prim () (operar + 0 lnum))
      (menos-prim () (operar - 0 lnum))
      (multiplicacion-prim () (operar * 1 lnum))
      (sucesor-prim  ()(+ 1 (car lnum)))
      (antecesor-prim  () (- (car lnum) 1))
      )))


(define operar
  (lambda (op acc lst)
    (cond
      [(null? lst) acc]
      [else (op (car lst) (operar op acc (cdr lst)))]
      )
    ))

(define aplicar-procedimiento
  (lambda (rator rands)
    (cases procval rator
      (closure (lid body old-env)
               (evaluar-expresion body (ambiente-extendido lid (list->vector rands) old-env))))))



;;REFERENCIAS
(define-datatype referencia referencia?
  (a-ref (pos number?)
         (vec vector?)))


(define de-ref
  (lambda (ref)
    (cases target (primitive-deref ref)
      (direct-target (val) val)
      (indirect-target (ref1)
                       (cases target  (primitive-deref ref1)
                         (direct-target (val) val)
                         (indirect-target (p)
                                          (eopl:error "Usted es un referencia ilegal: ~s" ref1)))))))


(define primitive-deref
  (lambda (ref)
    (cases referencia ref
      (a-ref (pos vec)
             (vector-ref vec pos)))))

(define setref!
  (lambda  (ref newexp)
    (let
        (
         (ref
          (cases target (primitive-deref ref)
            (direct-target (exp) ref)
            (indirect-target (ref1) ref1))
          ))
      (primitive-setref! ref (direct-target newexp))
      )))


(define primitive-setref!
  (lambda (ref val)
    (cases referencia ref
      (a-ref (pos vec)
        (vector-set! vec pos val)))))
;;PASO POR REFERENCIA

(define-datatype target target?
  (direct-target (expval expval?))
  (indirect-target (ref ref-to-direct-target?)))

(define expval?
  (lambda (exp)
    (or (procval? exp) (number? exp))))

(define ref-to-direct-target?
  (lambda (exp)
    (if (referencia? exp)
        (cases referencia exp
          (a-ref (vec pos)
                 ;;Error del video (vector-ref vec pos)
                 (cases target (vector-ref pos vec)
                   (direct-target (v) #T)
                   (indirect-target (v) (eopl:error "No se puede pasar una referencia entre procedimientos"))
                   )
                 )
          )
        #F)
    )
  )

(define evaluar-rand-pref
  (lambda (x amb)
    (cases expresion x
      (var-exp (id)
               (indirect-target
                (let(
                     (ref (apply-env-ref amb id))
                    )

                  (cases target (primitive-deref ref)
                    (direct-target (exp) ref)
                    ;;Cuando pasas de un procedimiento que recibe una variable a otro
                    ;;Se toma la referencia al target directo :D
                    (indirect-target (ref1) ref1)
                    )
                  )
                ))
      (else
       (direct-target (evaluar-expresion x amb)))
      )))

(interpretador)