Interprete paso por referencia

#lang eopl
; Especificación léxica: define tokens y patrones regex
(define lexical
  '(
    (comment ("%" (arbno (not #\newline))) skip)  ; Comentarios: % hasta newline (se ignoran)
    (whitespace (whitespace) skip)                ; Espacios en blanco (se ignoran)
    (number (digit (arbno digit)) number)         ; Números positivos: dígitos
    (number ("-" digit (arbno digit)) number)     ; Números negativos: - seguido de dígitos
    (identifier (letter (arbno (or letter digit))) symbol) ; Identificadores: letra seguida de letras/dígitos
    ))

; Gramática para el parser (producciones y constructores del AST)
(define grammar
  '(
    (program (expression) a-program)              ; Programa: una expresión
    (expression (identifier) var-exp)             ; Expresión: variable
    (expression (number) lit-exp)                 ; Expresión: literal numérico
    (expression ("true") true-exp)                ; Expresión: booleano true
    (expression ("false") false-exp)              ; Expresión: booleano false
    (expression (primitive "(" (separated-list expression ",") ")") prim-exp) ; Expresión primitiva con argumentos

    (expression ("if" expression "then" expression "else" expression) if-exp)
    (expression ("let" (arbno identifier "=" expression)
                       "in" expression) let-exp)
    (expression ("proc" "(" (separated-list identifier ",") ")" expression) proc-exp)
    (expression ("letrec" (arbno
                           identifier "(" (separated-list identifier ",") ")"
                           "=" expression)
                          "in"
                          expression) letrec-exp)

    (expression ("set" identifier "=" expression) set-exp)
    (expression ("begin" expression (arbno ";" expression) "end") begin-exp)
    (expression ("(" expression (arbno expression) ")") app-exp)
    (primitive ("+") add-prim)                    ; Primitiva: suma
    (primitive ("-") sub-prim)                    ; Primitiva: resta
    (primitive ("*") prod-prim)                   ; Primitiva: multiplicación
    (primitive ("/") div-prim)                    ; Primitiva: división
    (primitive ("and") and-prim)                  ; Primitiva: and lógico
    (primitive ("or") or-prim)                    ; Primitiva: or lógico
    (primitive ("<") less-prim)                   ; Primitiva: menor que
    (primitive ("<=") lesseq-prim)                ; Primitiva: menor o igual
    (primitive (">") more-prim)                   ; Primitiva: mayor que
    (primitive (">=") moreeq-prim)                ; Primitiva: mayor o igual
    (primitive ("==") eq-prim)                    ; Primitiva: igualdad
    (primitive ("!=") neq-prim)                   ; Primitiva: desigualdad
    )
  )

;; Generar datatypes automáticamente a partir de lexical/grammar
(sllgen:make-define-datatypes lexical grammar)

; Scanner: convierte string en lista de tokens
; scanner -> string -> lista de tokens
(define scanner
  (lambda (program)
    ((sllgen:make-string-scanner lexical grammar) program)))

; Parser: convierte string en AST usando la gramática
; parser: string -> ast
(define parser
  (lambda (program)
    ((sllgen:make-string-parser lexical grammar) program)))

; Definición del entorno (environment) como estructura de datos
(define-datatype environment environment?
  (empty-env)  ; Entorno vacío
  (extend-env  ; Extender entorno con nuevos bindings
   (lid (list-of symbol?))     ; Lista de identificadores
   (lval vector?)     ; Lista de valores
   (old-env environment?)); Entorno anterior
  (extend-recursively-env
   (procname (list-of symbol?))
   (argss (list-of (list-of symbol?)))
   (bodies (list-of expression?))
   (old-env environment?))   
  )     
; Predicado value?: cualquier valor es válido (implementación simplificada)
(define value?
  (lambda (v)
    #T))

; Aplicar entorno: busca un símbolo en el entorno y retorna su valor
; apply-env: environment -> valor
(define apply-env
  (lambda (env var)
    (deref (apply-env-ref env var))))


; apply-env: environment -> referencia
(define apply-env-ref
  (lambda (env var)
    (cases environment env
      (empty-env () (eopl:error "Variable not found" var)) ; Error si no se encuentra
      (extend-env (lid vec old-env)
                  (letrec
                      ((search-var ; Búsqueda recursiva en la lista de bindings
                        (lambda (lid lval [pos 0])
                          (cond
                            [(null? lid) (apply-env-ref old-env var)] ; Buscar en entorno anterior
                            [(equal? (car lid) var) (a-ref pos vec)]   ; Voy a generar una referencia cuando encuentro la variable
                            [else (search-var (cdr lid) vec (+ pos 1))]) ; Continuar búsqueda
                        )))
                    (search-var lid vec)))
      (extend-recursively-env
       (procnames llargs bodies old-env)
       (letrec
           (
            (search-proc
             (lambda (procs args bodies)
               (cond
                 [(null? procs) (apply-env-ref old-env var)]
                 [(eqv? (car procs) var)
                  (a-ref
                   0
                   (list->vector (list
                                  (closure (car args)
                                           (car bodies)
                                           env)
                                  )
                    ))]
                 [else (search-proc (cdr procs) (cdr args) (cdr bodies))]
                 )
               )
             )
            )
         (search-proc procnames llargs bodies)
         )
       )
      )
    )
  )

; Evaluar programa: punto de entrada, evalúa la expresión del programa
; eval-program: program -> value
(define eval-program
  (lambda (pgm)
    (cases program pgm
      (a-program (exp) (eval-expression exp init-env)) ; Evalúa la expresión con entorno inicial
      )
    ))



; Evaluar expresión: recursivamente evalúa según el tipo de expresión
; eval-expression: expression -> value
(define eval-expression
  (lambda (exp env)
    (cases expression exp
      (var-exp (id) (apply-env env id))      ; Variable: busca en entorno
      (lit-exp (datum) datum)                ; Literal: retorna el número
      (true-exp () #t)                       ; True: retorna #t
      (false-exp () #f)                      ; False: retorna #f
      (prim-exp (prim lrands)                ; Primitiva: evalúa argumentos y aplica
                (let ((values (map (lambda (x) (eval-expression x env)) lrands)))
                  (apply-primitive prim values)))
      (if-exp (cond-exp true-exp false-exp)
               (let
                   (
                    (cond-value (eval-expression cond-exp env))
                    )
                 (if (boolean? cond-value)
                     (if
                      cond-value
                      (eval-expression true-exp env)
                      (eval-expression false-exp env)
                      )
                     (eopl:error "The condition must be a boolean " cond-exp)
                     )
                 )
               )
      (let-exp (lid lexpr expr)
               (let
                   (
                    (vexpr (map (lambda (x) (direct-target (eval-expression x env))) lexpr))
                    )
                 (eval-expression expr
                                     (extend-env lid (list->vector vexpr) env))
                 )
               )
      (proc-exp (lid exp)
                (closure lid exp env))
      (app-exp (rator rands)
               (let
                   (
                    (procv (eval-expression rator env))
                    (vrands (map (lambda (x) (eval-rand x env)) rands))
                    )
                 (if
                  (and
                   (procVal? procv)
                   (= (length (procVal->lid procv))
                      (length vrands))
                   )
                  (cases procVal procv
                    (closure
                     (lid exp old-env)
                     (eval-expression exp
                                      (extend-env lid (list->vector vrands) old-env))))
                  (eopl:error "Not a procedure or incorrect of number of args"))
                 )
               )

      ;; Manejo de expresiones letrec en eval-expression
      (letrec-exp
       (procnames llargs bodies expn)     ; Componentes de la expresión letrec
       (eval-expression
        expn                             ; Expresión del cuerpo principal (después de "in")
        (extend-recursively-env          ; Extender el ambiente con definiciones recursivas
         procnames                       ; Lista de nombres de procedimientos
         llargs                          ; Lista de listas de argumentos (parámetros formales)
         bodies                          ; Lista de cuerpos de los procedimientos
         env)))                          ; Ambiente actual (base para la extensión)
      (begin-exp (exp lexp)
                 (letrec
                     (
                      (evaluation (lambda (lexp)
                                    (cond
                                      [(null? (cdr lexp)) (eval-expression (car lexp) env)]
                                      [else (begin
                                              (eval-expression (car lexp) env)
                                              (evaluation (cdr lexp)))]
                                      )
                                    )
                                  )
                      )
                   (evaluation (cons exp lexp))
                   )
                 )
      (set-exp (id exp)
               (begin
                 (setref!
                  (apply-env-ref env id)
                  (eval-expression exp env))
                 (void)))

      (else "Not implemented yet")))) ; Default (no debería ocurrir)



; Operación genérica: aplica una función binaria acumulativa a una lista
; operation: (T,T)->T, lista de valores, T -> value
(define operation
  (lambda (f lst acc)
    (cond
      [(null? lst) acc] ; Caso base: retorna acumulador
      [else (operation f (cdr lst) (f (car lst) acc))] ; Aplica f y acumula
      )))

; Aplicar primitiva: ejecuta la operación correspondiente sobre los valores
; apply-primitive: primitive, lista valores -> value
(define apply-primitive
  (lambda (prim values)
    (cases primitive prim
      (add-prim () (operation + values 0))        ; Suma acumulativa
      (sub-prim () (- (car values) (operation + (cdr values) 0))) ; Resta (first - sum(rest))
      (prod-prim () (operation * values 1))       ; Producto acumulativo
      (div-prim () (/ (car values) (operation * (cdr values) 1))) ; División (first / product(rest))
      (and-prim () (operation (lambda (a b) (and a b)) values #t)) ; AND acumulativo
      (or-prim () (operation (lambda (a b) (or a b)) values #f))   ; OR acumulativo
      (less-prim () (< (car values) (cadr values)))     ; < (2 args)
      (lesseq-prim () (<= (car values) (cadr values)))  ; <= (2 args)
      (more-prim () (> (car values) (cadr values)))     ; > (2 args)
      (moreeq-prim () (>= (car values) (cadr values)))  ; >= (2 args)
      (eq-prim () (= (car values) (cadr values)))       ; == numérico (2 args)
      (neq-prim () (not (= (car values) (cadr values)))) ; != numérico (2 args)
      )))

; Intérprete interactivo: loop de lectura-evaluación-impresión
(define interpreter
  (sllgen:make-rep-loop
   "-->"          ; Prompt
   eval-program   ; Función de evaluación
   (sllgen:make-stream-parser lexical grammar) ; Parser para input stream
   ))

; Closure
; Representación de los procedimientos
(define-datatype procVal procVal?
  (closure
   (lid (list-of symbol?))
   (exp expression?)
   (old-env environment?)
   ))

;;Extractor para lid en un closure
(define procVal->lid
  (lambda (cls)
    (cases procVal cls
      (closure (lid exp old-env)
               lid))))


;;References
(define-datatype reference reference?
  (a-ref (position integer?)
         (vec vector?)))

;;dref: reference -> value
(define deref
  (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 "Illegal reference" ref1)))))))

;primitive-refef: reference -> valor
(define primitive-deref
  (lambda (ref)
    (cases reference ref
      (a-ref (pos vec)
             (vector-ref vec pos)))))

;setref
;Setref es un procedimiento para cambiar el valor de una referencia
(define setref!
  (lambda (ref val)
    (let
        (
         (ref1
          (cases target (primitive-deref ref)
            (direct-target (e) ref)
            (indirect-target (r) r))
          )
         )
      (primitive-setref! ref1 (direct-target val))
      )
    )
  )

(define primitive-setref!
  (lambda (ref val)
    (cases reference ref
      (a-ref (pos vec)
             (vector-set! vec pos val)))))


;;definición del valor nulo
(define-datatype nulltype nulltype?
  (void))

;;Paso por referencia
(define-datatype target target?
  (direct-target (val expval?))
  (indirect-target (ref ref-to-direct-target?)))


;Expval is a number, boolean or procval (expressed value)
(define expval?
  (lambda (x)
    (or (number? x) (boolean? x) (procVal? x))))

;Ref a target direct must be a reference and this reference have to content a direct target
(define ref-to-direct-target?
  (lambda (x)
    (and
     (reference? x)
     (cases reference x
       (a-ref (pos vec)
              (cases target (vector-ref vec pos)
                             (direct-target (v) #T) 
                             (indirect-target (v) #F))))))) ;boolean or procval 


; Entorno inicial predefinido (variables x,y,z y a,b,c con valores numéricos)
(define init-env
  (extend-env '(x y z) (list->vector (list (direct-target 1)
                                           (direct-target 2)
                                           (direct-target 3)
                                           )
                                     )
              (extend-env '(a b c) (list->vector (list

                                                  (direct-target 4)
                                                  (direct-target 5)
                                                  (direct-target 6)
                                                  )
                                                 ) (empty-env))))


;eval-rand
;1. if it is a value generates a direct-target
;2. if it is a var-exp generates an indirect-target
(define eval-rand
  (lambda (rand env)
    (cases expression rand
      (var-exp (id)
               (let
                   (
                    (ref (apply-env-ref env id))
                    )
                 (indirect-target
                  (cases target (primitive-deref ref)
                   (direct-target (e) ref)
                   (indirect-target (ref1) ref1))
                  )
                 )
               )
      (else
       (direct-target (eval-expression rand env)))
      )
     )
  )


; Iniciar el intérprete
(interpreter)