PasteRack.org
Paste # 6502
2017-12-13 09:03:57

Fork as a new paste.

Paste viewed 89 times.


Embed:

  1. #lang eopl
  2. ;******************************************************************************************
  3. ;;;;; Interpretador para lenguaje con condicionales, ligadura local, procedimientos y
  4. ;;;;; procedimientos recursivos
  5.  
  6. ;; La definición BNF para las expresiones del lenguaje:
  7. ;;
  8. ;;  <program>       ::= <expression>
  9. ;;                      <a-program (exp)>
  10. ;;  <expression>    ::= <number>
  11. ;;                      <lit-exp (datum)>
  12. ;;                  ::= <identifier>
  13. ;;                      <var-exp (id)>
  14. ;;                  ::= <primitive> ({<expression>}*(,))
  15. ;;                      <primapp-exp (prim rands)>
  16. ;;                  ::= if <expresion> then <expresion> else <expression>
  17. ;;                      <if-exp (exp1 exp2 exp23)>
  18. ;;                  ::= let {identifier = <expression>}* in <expression>
  19. ;;                      <let-exp (ids rands body)>
  20. ;;                  ::= proc({<identificador>}*(,)) <expression>
  21. ;;                      <proc-exp (ids body)>
  22. ;;                  ::= (<expression> {<expression>}*)
  23. ;;                      <app-exp proc rands>
  24. ;;                  ::= letrec  {identifier ({identifier}*(,)) = <expression>}* in <expression>
  25. ;;                     <letrec-exp proc-names idss bodies bodyletrec>
  26. ;;  <primitive>     ::= + | - | * | add1 | sub1
  27.  
  28. ;******************************************************************************************
  29.  
  30. ;******************************************************************************************
  31. ;Especificación Léxica
  32. ;******************************************************************************************
  33. (define the-lexical-spec
  34. '((white-sp
  35.    (whitespace) skip)
  36.   (comment
  37.    ("#" (arbno (not #\newline))) skip)
  38.   (identifier
  39.    (letter (arbno (or letter digit "?" "_"))) symbol)
  40.   (number
  41.    (digit (arbno digit)) number)
  42.   (number
  43.    ("-" digit (arbno digit)) number)
  44.   (string
  45.      ("|" (arbno (or letter digit)) "|") string)
  46.   ))
  47. ;******************************************************************************************
  48.  
  49.  
  50. ;******************************************************************************************
  51. ;Especificación Sintáctica (gramática)
  52. ;******************************************************************************************
  53. (define the-grammar
  54.   '(
  55.     (program  ((arbno decl-class) "main"  "(" expression ")") a-program)
  56.  
  57.     ; Clases:
  58.     (decl-class ("class" identifier "(" decl-fields decl-methods ")")
  59.             class)
  60.     (decl-fields  ((separated-list identifier ","))
  61.               atributes)
  62.     (decl-methods ((arbno decl-method))
  63.               methods)
  64.     (decl-method ("method" identifier "(" (separated-list identifier ",") ")" expression)
  65.              method)
  66.  
  67.     ; Expresiones basicas
  68.     (expression (string) string-exp) ;; (scan&parse "main (|5|)")
  69.     (expression (number) lit-exp)
  70.     (expression (boolean) boolean-exp) ;se crea una expression de tipo bool-exp, el cual es otro datatype.
  71.     (expression (lista) list-exp) ; se crea una expression de tipo list, el cual es otro datatype
  72.  
  73.     ; Expresiones Booleanas
  74.     (boolean (boolean-primitive "(" (arbno expression )")") boolean-prim-exp)
  75.     (boolean ("true") true-exp)
  76.     (boolean ("false") false-exp)
  77.     (boolean (boolean-operator "(" (arbno expression)")") boolean-operator-exp)
  78.  
  79.     ; Operadores Boolenanos
  80.     (boolean-operator ("and") and-prim) ; actua como un and de scheme y se aplica a expressiones.
  81.     (boolean-operator ("&&") and-prim)
  82.     (boolean-operator ("or") or-prim)   ; actua como un or de scheme y se aplica a expressiones.
  83.     (boolean-operator ("||") or-prim)
  84.     (boolean-operator ("not") not-prim) ; actua como un not de scheme y se aplica a expressiones.
  85.     (boolean-operator ("!") not-prim)
  86.  
  87.     ; Primitivas booleanas
  88.     (boolean-primitive ("==") equal-prim)      ; pregunta si dos expressiones son iguales.
  89.     (boolean-primitive (">=") greaterEqual-prim) ; pregunta si una expression es mayor igual que otra.
  90.     (boolean-primitive ("<=") minorEqual-prim) ; pregunta si una expression es menor igual que otra.
  91.     (boolean-primitive (">") greater-prim)       ; pregunta si una expression es mayor  que otra.
  92.     (boolean-primitive ("<") minor-prim)       ; pregunta si una expression es menor que otra.
  93.  
  94.     ; Listas
  95.     (lista ("(list" (arbno expression) ")") list-e)
  96.  
  97.     (expression (identifier) var-exp)
  98.     (expression
  99.      (primitive "(" (arbno expression)")")
  100.      primapp-exp)
  101.  
  102.     ;if-elseif-else
  103.     (expression ("if" expression "then" expression (arbno  "elseif" expression "then" expression  ) "else" expression "end"); cambio
  104.                 if-exp)
  105.     ;for
  106.     (expression ("for" identifier ":=" expression "to" expression "each"expression "do"expression "end") for-exp);
  107.  
  108.     ;Generales let,proc, (),...
  109.     (expression ("let" (separated-list identifier "=" expression "," ) "in" expression "end") ;cada declaracion se identifica con una "," y termina con end.
  110.                 let-exp)
  111.     (expression ("proc" "(" (separated-list identifier "," ) ")" expression "end")
  112.                 proc-exp)
  113.     (expression ( "apply" identifier "(" (arbno expression) ")")
  114.                 app-exp)
  115.  
  116.     ; características adicionales
  117.     (expression ("letrec" (arbno identifier "(" (separated-list identifier ",") ")" "=" expression)  "in" expression)
  118.                 letrec-exp)
  119.  
  120.     (expression ("begin" expression (arbno ";" expression) "end")
  121.                 begin-exp)
  122.  
  123.     (expression ("set" identifier ":=" expression)
  124.                 set-exp)
  125.  
  126.     (expression ("class." expression "." identifier "(" (arbno expression)")" )
  127.                 methodcall-exp)
  128.     (expression ("new" identifier"(" (arbno expression) ")")
  129.                 new-exp)
  130.  
  131.     (primitive ("+") add-prim)
  132.     (primitive ("-") substract-prim)
  133.     (primitive ("*") mult-prim)
  134.     (primitive ("/") divide-prim)
  135.     (primitive ("cons") cons-prim)
  136.     (primitive ("max") max-prim)
  137.     (primitive ("min") min-prim)
  138.     (primitive ("cons") cons-prim)
  139.     (primitive ("car") car-prim)
  140.     (primitive ("cdr") cdr-prim)
  141.     (primitive ("null?") null-prim)
  142.  
  143.  
  144.     ))
  145. ;**************************************************************************************
  146.  
  147. ;**************************************************************************************
  148. ;Interpretador
  149. ;**************************************************************************************
  150. ;Construidos automáticamente:
  151. (sllgen:make-define-datatypes the-lexical-spec the-grammar)
  152.  
  153. (define show-the-datatypes
  154.   (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))
  155.  
  156. ;Parser, Scanner, Interfaz
  157.  
  158. ;El FrontEnd (Análisis léxico (scanner) y sintáctico (parser) integrados)
  159. (define scan&parse
  160.   (sllgen:make-string-parser the-lexical-spec the-grammar))
  161.  
  162. ;El Analizador Léxico (Scanner)
  163. (define just-scan
  164.   (sllgen:make-string-scanner the-lexical-spec the-grammar))
  165.  
  166. ;El Interpretador (FrontEnd + Evaluación + señal para lectura )
  167. (define interpretador
  168.   (sllgen:make-rep-loop  "--> "
  169.     (lambda (pgm) (eval-program  pgm))
  170.     (sllgen:make-stream-parser
  171.       the-lexical-spec
  172.       the-grammar)))
  173.  
  174. ;eval-program: <programa> -> numero
  175. (define eval-program
  176.   (lambda (pgm)
  177.     (cases program pgm
  178.       (a-program (c-decls exp)
  179.         (make-class! c-decls)
  180.         (eval-expression exp (empty-env))))))
  181.  
  182. ; Ambiente inicial
  183. (define init-env
  184.   (lambda ()
  185.     (empty-env)))
  186. ;**************************************************************************************
  187.  
  188. ;**************************************************************************************
  189. ; Eval-expression
  190. ;**************************************************************************************
  191. ;eval-expression: <expression> <enviroment> -> numero
  192. ; evalua la expresión en el ambiente de entrada
  193. (define eval-expression
  194.   (lambda (exp env)
  195.     (cases expression exp
  196.       (string-exp (string) string)
  197.       (lit-exp (datum) datum)
  198.  
  199.       (boolean-exp (bool-expr) ;añadido.
  200.                    (cases boolean bool-expr
  201.                      (boolean-prim-exp (prim-bool rands)
  202.                                     (let ((args (eval-primapp-exp-rands rands env)))
  203.                                       (apply-boolean-primitives prim-bool args))) ; applica apply a los operadores de bool-exp (> <..)
  204.                      (true-exp () #t)
  205.                      (false-exp () #f)
  206.                      (boolean-operator-exp (prim rands)
  207.                                         (let ((args (eval-primapp-exp-rands rands env)))
  208.                                           (apply-boolean-operator prim args))) ;applica apply a los operadores de bool-operator(and or not)
  209.                      )
  210.                    )
  211.  
  212.       (list-exp (list) (eval-list list env))
  213.  
  214.       (var-exp (id) (apply-env env id))
  215.  
  216.       (primapp-exp (prim rands)
  217.                    (let ((args (eval-primapp-exp-rands rands env)))
  218.                      (apply-primitive prim args)))
  219.  
  220.       (if-exp (test-exp true-exp test-exp-1 true-exp-1 false-exp) ; modificacion del if.
  221.               ; si el test es falso verifica si hay ifelse si los hay mira si alguno de ellos se cumple, si no retorna
  222.               ;lo que tiene el else.
  223.               (if (eval-expression test-exp env)
  224.                   (eval-expression true-exp env)
  225.                   (if (equal? (funcion-if (funcion-aux test-exp-1 env) (eval-primapp-exp-rands  true-exp-1 env)) #f)
  226.                       (eval-expression false-exp env)
  227.                       (funcion-if (funcion-aux test-exp-1 env) (eval-primapp-exp-rands  true-exp-1 env)))))
  228.  
  229.       (for-exp (id number parametro aumento body) ; creacion de for. utiliza la funcion auxiliar for-rec
  230.                (let ((numero (eval-expression number env))
  231.                      (target-num (eval-rand number env))
  232.                      (parameter (eval-expression parametro env))
  233.                      (aumento (eval-expression aumento env)))
  234.                  (for-rec id numero parameter aumento body (extend-env (cons  id empty) (cons target-num empty) env))
  235.                  ))
  236.  
  237.       (let-exp (ids rands body)
  238.                (let ((args (eval-let-exp-rands rands env)))
  239.                  (eval-expression body (extend-env ids args env))))
  240.  
  241.       (proc-exp (ids body)
  242.                 (closure ids body env))
  243.  
  244.       (app-exp (rator rands)
  245.                ;(let ((proc (eval-expression rator env))
  246.                (let ((proc (apply-env env rator))
  247.                      (args (eval-rands rands env)))
  248.                  (if (procval? proc)
  249.                      (apply-procedure proc args)
  250.                      (eopl:error 'eval-expression
  251.                                  "Attempt to apply non-procedure ~s" proc))))
  252.  
  253.       (letrec-exp (proc-names idss bodies letrec-body)
  254.                   (eval-expression letrec-body
  255.                                    (extend-env-recursively proc-names idss bodies env)))
  256.  
  257.       (set-exp (id rhs-exp)
  258.                (begin
  259.                  (setref!
  260.                   (apply-env-ref env id)
  261.                   (eval-expression rhs-exp env))
  262.                  1))
  263.       (begin-exp (exp exps)
  264.                  (let loop ((acc (eval-expression exp env))
  265.                              (exps exps))
  266.                     (if (null? exps)
  267.                         acc
  268.                         (loop (eval-expression (car exps)
  269.                                                env)
  270.                               (cdr exps)))))
  271.  
  272.       (new-exp (nombre-clase rands)
  273.               (let ((args (eval-rands rands env))
  274.                     (obj (new-object nombre-clase)))
  275.                 (find-method-and-apply nombre-clase nombre-clase obj args)
  276.                 obj))
  277.       (methodcall-exp (nombre-obj nombre-metodo rands)
  278.                        (let ((args (eval-rands rands env))
  279.                              (obj (eval-expression nombre-obj env)))
  280.                          (find-method-and-apply
  281.                           nombre-metodo (object->class-name obj) obj args)))
  282.       )))
  283. ;**************************************************************************************
  284.  
  285.  
  286. ;**************************************************************************************
  287. ; Declaraciones de clases
  288. ;**************************************************************************************
  289. (define-datatype clase clase?
  290.   (a-class
  291.     (class-name symbol?)
  292.     (field-length integer?)
  293.     (field-ids (list-of symbol?))
  294.     (methods (list-of metodo?))))
  295.  
  296. (define-datatype metodo metodo?
  297.   (a-method
  298.     (decl-method decl-method?)
  299.     (field-ids (list-of symbol?))))
  300.  
  301. (define-datatype object object?
  302.   (an-object
  303.     (class-name symbol?)
  304.     (fields vector?)))
  305.  
  306. ; Ambiente de clases:
  307.  
  308. (define class-env '())
  309.  
  310. (define init-class-env!
  311.   (lambda ()
  312.     (set! class-env '())))
  313.  
  314. (define add-to-class-env!
  315.   (lambda (clase)
  316.     (set! class-env (cons clase class-env))))
  317.  
  318. ; new-object: <identifier> -> (object)
  319. ; Crea un objeto de una clase especifica.
  320.  
  321. (define new-object
  322.   (lambda (nombre-clase)
  323.     (an-object
  324.       nombre-clase
  325.         (list->vector (cambiar-a-target (vector->list (make-vector (class-name->field-length nombre-clase))))))))
  326.  
  327. (define find-method-and-apply
  328.   (lambda (m-name clase-metodo self args)
  329.     (let((metodo (buscar-metodo m-name
  330.                       (class-name->methods clase-metodo) (length args))))
  331.                 (evaluar-metodo metodo clase-metodo self args))))
  332.  
  333. ; find-method-and-apply: <identifier> <lista> <lista> -> (metodo)
  334. ; Busca un metodo en una lista de metodos.
  335.  
  336. (define buscar-metodo
  337.   (lambda (m-name methods args)
  338.     (cond
  339.       ((null? methods) (eopl:error 'buscar-metodo
  340.                        "El método ~s no existe." m-name))
  341.       ((and (eqv? args (length (method->ids (car methods)))) (eqv? m-name (method->method-name (car methods))))
  342.        (car methods))
  343.       (else (buscar-metodo m-name (cdr methods) args)))))
  344.  
  345. (define evaluar-metodo
  346.   (lambda (method clase-metodo self args)
  347.     (let ((ids (method->ids method))
  348.           (body (method->body method))
  349.           (field-ids (metodo->field-ids method))
  350.           (fields (object->fields self)))
  351.        (eval-expression body
  352.           (extend-env ids args (extend-env-refs field-ids fields (empty-env)))))))
  353.  
  354. (define cambiar-a-target
  355.   (lambda (list)
  356.     (cond
  357.       [(null? list) empty]
  358.       [else (cons (direct-target (car list)) (cambiar-a-target (cdr list)))])))
  359.  
  360. (define make-class!
  361.   (lambda (decl-clases)
  362.     (init-class-env!)
  363.     (for-each make-a-class! decl-clases)))
  364.  
  365. (define make-a-class!
  366.   (lambda (decl-clase)
  367.      (let ((field-ids (decl-fields->atributos
  368.                        (decl-class->field-ids decl-clase))))
  369.        (add-to-class-env!
  370.          (a-class
  371.            (decl-class->class-name decl-clase)
  372.            (length field-ids)
  373.            field-ids
  374.            (make-mtds
  375.             decl-clase field-ids))))))
  376.  
  377. (define make-mtds
  378.   (lambda (decl-clase field-ids)
  379.     (map
  380.       (lambda (decl-metd)
  381.         (a-method decl-metd field-ids))
  382.       (decl-methods->lista-metodos (decl-class->decl-methods decl-clase)))))
  383.  
  384. (define buscar-clase
  385.   (lambda (nombre-clase)
  386.     (let loop ((env class-env))
  387.       (cond
  388.         ((null? env) (eopl:error 'buscar-clase
  389.                        "La clase ~s no existe." nombre-clase))
  390.         ((eqv? (class->class-name (car env)) nombre-clase) (car env))
  391.         (else (loop (cdr env)))))))
  392.  
  393. (define decl-fields->atributos
  394.   (lambda (fields-decl)
  395.     (cases decl-fields fields-decl
  396.       (atributes (atributos)
  397.         atributos))))
  398.  
  399. (define decl-class->class-name
  400.   (lambda (c-decl)
  401.     (cases decl-class c-decl
  402.       (class (class-name field-ids m-decls)
  403.         class-name))))
  404.  
  405. (define decl-class->field-ids
  406.   (lambda (c-decl)
  407.     (cases decl-class c-decl
  408.       (class (class-name field-ids m-decls)
  409.         field-ids))))
  410.  
  411. (define decl-class->decl-methods
  412.   (lambda (c-decl)
  413.     (cases decl-class c-decl
  414.       (class (class-name  field-ids m-decls)
  415.         m-decls))))
  416.  
  417. (define decl-method->method-name
  418.   (lambda (md)
  419.     (cases decl-method md
  420.       (method (method-name ids body) method-name))))
  421.  
  422. (define decl-method->ids
  423.   (lambda (md)
  424.     (cases decl-method md
  425.       (method (method-name ids body) ids))))
  426.  
  427. (define decl-method->body
  428.   (lambda (md)
  429.     (cases decl-method md
  430.       (method (method-name ids body) body))))
  431.  
  432. (define decl-methods->method-names
  433.   (lambda (mds)
  434.     (map decl-method->method-name mds)))
  435.  
  436. (define decl-methods->lista-metodos
  437.   (lambda (metodos)
  438.     (cases decl-methods metodos
  439.       (methods (lista-metodos) lista-metodos))))
  440.  
  441. (define class->class-name
  442.   (lambda (c-struct)
  443.     (cases clase c-struct
  444.       (a-class (class-name  field-length field-ids methods)
  445.         class-name))))
  446.  
  447. (define class->field-length
  448.   (lambda (c-struct)
  449.     (cases clase c-struct
  450.       (a-class (class-name  field-length field-ids methods)
  451.         field-length))))
  452.  
  453. (define class->field-ids
  454.   (lambda (c-struct)
  455.     (cases clase c-struct
  456.       (a-class (class-name  field-length field-ids methods)
  457.         field-ids))))
  458.  
  459. (define class->methods
  460.   (lambda (c-struct)
  461.     (cases clase c-struct
  462.       (a-class (class-name  field-length field-ids methods)
  463.         methods))))
  464.  
  465. (define object->class-name
  466.   (lambda (obj)
  467.     (cases object obj
  468.       (an-object (class-name fields)
  469.         class-name))))
  470.  
  471. (define object->fields
  472.   (lambda (obj)
  473.     (cases object obj
  474.       (an-object (decl-class fields)
  475.         fields))))
  476.  
  477. (define object->decl-class
  478.   (lambda (obj)
  479.     (buscar-clase (object->class-name obj))))
  480.  
  481. (define object->field-ids
  482.   (lambda (object)
  483.     (class->field-ids
  484.       (object->decl-class object))))
  485.  
  486. (define class-name->field-ids
  487.   (lambda (class-name)
  488.  
  489.       (class->field-ids (buscar-clase class-name))))
  490.  
  491. (define class-name->methods
  492.   (lambda (class-name)
  493.  
  494.       (class->methods (buscar-clase class-name))))
  495.  
  496. (define class-name->field-length
  497.   (lambda (class-name)
  498.  
  499.         (class->field-length (buscar-clase class-name))))
  500.  
  501. (define method->decl-method
  502.   (lambda (meth)
  503.     (cases metodo meth
  504.       (a-method (meth-decl  field-ids) meth-decl))))
  505.  
  506. (define metodo->field-ids
  507.   (lambda (meth)
  508.     (cases metodo meth
  509.       (a-method (decl-method  field-ids) field-ids))))
  510.  
  511. (define method->method-name
  512.   (lambda (method)
  513.     (decl-method->method-name (method->decl-method method))))
  514.  
  515. (define method->body
  516.   (lambda (method)
  517.     (decl-method->body (method->decl-method method))))
  518.  
  519. (define method->ids
  520.   (lambda (method)
  521.     (decl-method->ids (method->decl-method method))))
  522.  
  523.  
  524.  
  525. ;**************************************************************************************
  526.  
  527.  
  528. ;**************************************************************************************
  529. ;Funciones auxiliares
  530. ;**************************************************************************************
  531.  
  532. ; Funciones auxiliares para eval-expression
  533. ;-------------------------------------------------------------------------------------
  534. (define eval-rands
  535.   (lambda (rands env)
  536.     (map (lambda (x) (eval-rand x env)) rands)))
  537.  
  538. (define eval-rand
  539.   (lambda (rand env)
  540.     (cases expression rand
  541.       (var-exp (id)
  542.                (indirect-target
  543.                 (let ((ref (apply-env-ref env id)))
  544.                   (cases target (primitive-deref ref)
  545.                     (direct-target (expval) ref)
  546.                     (indirect-target (ref1) ref1)))))
  547.       (else
  548.        (direct-target (eval-expression rand env))))))
  549.  
  550. (define eval-primapp-exp-rands
  551.   (lambda (rands env)
  552.     (map (lambda (x) (eval-expression x env)) rands)))
  553.  
  554. (define eval-let-exp-rands
  555.   (lambda (rands env)
  556.     (map (lambda (x) (eval-let-exp-rand x env))
  557.          rands)))
  558.  
  559. (define eval-let-exp-rand
  560.   (lambda (rand env)
  561.     (direct-target (eval-expression rand env))))
  562.  
  563. ;apply-primitive: <primitiva> <list-of-expression> -> numero
  564. (define apply-primitive
  565.   (lambda (prim args)
  566.     (cases primitive prim
  567.       (add-prim () (apply-operation-primitive + args 0))
  568.       (substract-prim () (- (car args) (cadr args)))
  569.       (mult-prim () (apply-operation-primitive * args 1))
  570.       (divide-prim () (/ (car args) (cadr args)))
  571.       (cons-prim () (cons (car args) (cadr args)))
  572.       (car-prim () (car (car args)))
  573.       (cdr-prim () (cdr (car args)))
  574.       (null-prim () (if (null? (car args)) #t #f))
  575.       (max-prim ()  (cast-limit args >))
  576.       (min-prim ()  (cast-limit args <))
  577.       )
  578.     )
  579.   )
  580.  
  581. ;true-value?: determina si un valor dado corresponde a un valor booleano falso o verdadero
  582. (define true-value?
  583.   (lambda (x)
  584.     (not (zero? x))))
  585.  
  586. (define apply-operation-primitive
  587.   (lambda (operator list modulo)
  588.     (cond
  589.       [(null? list) modulo]
  590.       [else (operator (car list)
  591.                       (apply-operation-primitive operator (cdr list) modulo))]
  592.       )
  593.     ))
  594.  
  595.  
  596.  
  597. ;Funciones auxiliares para If else if
  598. ;-------------------------------------------------------------------------------------
  599. ; funcion funcion-aux.
  600.  
  601. ; <lista> -> <lista>
  602. (define funcion-aux ;Aplica eval-bool-exp a una lista, esta función se usa en el ifelse.
  603.   (lambda (rands env)
  604.     (map (lambda (x) (eval-expression x env)) rands)))
  605.  
  606. ; funcion funcion-if
  607.  
  608. ;esta funcion pregunta si el car de l1 es true, si es así devuelve el car de l2 y así recursivamente
  609. ; y si ninguna es true o la lista es vacia retorna #f
  610. ; <l1> <l2> -> <car l2>
  611. (define funcion-if
  612.   (lambda (l1 l2)
  613.     (cond
  614.       [(null? l1) #f]
  615.       [else ( if (car l1) (car l2) (funcion-if (cdr l1) (cdr l2)))])))
  616.  
  617.  
  618. ;Funciones auxiliares para el for
  619. ;-------------------------------------------------------------------------------------
  620. ;funcion encargada de recibir los parametros del for y ejecutar cuantas veces sea nencesaro para cumplir con la condicion del for
  621. (define for-rec
  622.   (lambda (id number parametro aumento cuerpo env)
  623.     ;si el valor de la variable que aumenta es igual al valor del parametro de parada entonces evaluara la funcion por ultima vez
  624.     (if(equal? number parametro) (eval-expression cuerpo env)
  625.        (begin
  626.          ;en caso contrario entonces se dispondra a realizar un llamado recursivo de la funcion conla variable aumentada despues de realizar la ejecucuion del cuerpo
  627.          ;del for
  628.          (eval-expression cuerpo env)
  629.          (for-rec id (+ (apply-env env id ) aumento) parametro aumento cuerpo (extend-env (cons id empty) (cons (direct-target (+ (apply-env env id ) aumento)) empty) env) )
  630.          ))
  631.     ))
  632.  ;funcion encargada de recibir los parametros del for y ejecutar cuantas veces sea nencesaro para cumplir con la condicion del for
  633.  
  634. ; Funciones auxiliares para primitivas
  635. ;-------------------------------------------------------------------------------------
  636. (define cast-limit
  637.   (lambda (lista rator)
  638.     (cond
  639.       [(null? lista) (show-error "Expected a non-empty param")]
  640.       [else (limit-aux lista rator)]
  641.       )))
  642.  
  643. (define limit-aux
  644.   (lambda (lista rator)
  645.     (cond
  646.       [(equal? (length lista) 1) (car lista)]
  647.       [(rator (car lista)(cadr lista)) (limit-aux (append (list (car lista)) (cddr lista)) rator)]
  648.       [else (limit-aux (cdr lista) rator)]
  649.       )))
  650.  
  651. ; Manejo de errrores
  652. ;-------------------------------------------------------------------------------------
  653. (define show-error
  654.   (lambda (str)
  655.     (eopl:error str)
  656.     ))
  657.  
  658.  
  659. ;Funciones para expresiones Booleanas
  660. ;-------------------------------------------------------------------------------------
  661. (define apply-boolean-primitives
  662.   (lambda (prim args)
  663.     (if (check-num-params args 2)
  664.                     (cases boolean-primitive prim
  665.                       (equal-prim ()  (equal? (car args) (cadr args)))
  666.                       (greaterEqual-prim () (>= (car args) (cadr args)))
  667.                       (minorEqual-prim() (<= (car args) (cadr args)))
  668.                       (greater-prim ()(> (car args) (cadr args)) )
  669.                       (minor-prim() (<(car args) (cadr args)))
  670.                       )
  671.                     (eopl:error "Expect two argument")
  672.                     )
  673.     ))
  674.  
  675. (define apply-boolean-operator
  676.   (lambda ( prim args)
  677.     (cases boolean-operator prim
  678.       (and-prim () (aux-and args))
  679.       (or-prim ()(aux-or args))
  680.       (not-prim ()
  681.                 (if (check-num-params args 1)
  682.                     (not (car args))
  683.                     (eopl:error "Expect just one argument")
  684.                 )))))
  685.  
  686. ;Funciones Auxiliares para expresiones Booleanas
  687. (define aux-and
  688.   (lambda (una-lista)
  689.     (cond
  690.       [(null? una-lista) #t]
  691.       [(equal? (car una-lista) #t) (aux-and (cdr una-lista))]
  692.       [else #f])))
  693.  
  694. (define aux-or
  695.   (lambda (una-lista)
  696.     (cond
  697.       [(null? una-lista) #f]
  698.       [(equal? (car una-lista) #t) #t]
  699.       [else (aux-or (cdr una-lista))])))
  700.  
  701. (define check-num-params
  702.   (lambda (lista cant)
  703.     (cond
  704.       [(equal? (length lista) cant) #t]
  705.       [else #f]
  706.       )))
  707.  
  708. ; Funciones auxiliares para encontrar la posición de un símbolo
  709. ;-------------------------------------------------------------------------------------
  710. (define rib-find-position
  711.   (lambda (sym los)
  712.     (list-find-position sym los)))
  713.  
  714. (define list-find-position
  715.   (lambda (sym los)
  716.     (list-index (lambda (sym1) (eqv? sym1 sym)) los)))
  717.  
  718. (define list-index
  719.   (lambda (pred ls)
  720.     (cond
  721.       ((null? ls) #f)
  722.       ((pred (car ls)) 0)
  723.       (else (let ((list-index-r (list-index pred (cdr ls))))
  724.               (if (number? list-index-r)
  725.                 (+ list-index-r 1)
  726.                 #f))))))
  727.  
  728. ;****************************************************************************************
  729.  
  730. ;****************************************************************************************
  731. ;Funciones para expresiones Listas
  732. ;****************************************************************************************
  733.  
  734. (define eval-list
  735.   (lambda (lista-exp env)
  736.     (cases lista lista-exp
  737.       (list-e (lista) (let ((args (eval-primapp-exp-rands lista env)))
  738.                   args)))))
  739.  
  740. ;****************************************************************************************
  741.  
  742. ;*****************************************************************************************
  743. ;Procedimientos
  744. ;*****************************************************************************************
  745. (define-datatype procval procval?
  746.   (closure
  747.    (ids (list-of symbol?))
  748.    (body expression?)
  749.    (env environment?)))
  750.  
  751. ;apply-procedure: evalua el cuerpo de un procedimientos en el ambiente extendido correspondiente
  752. (define apply-procedure
  753.   (lambda (proc args)
  754.     (cases procval proc
  755.       (closure (ids body env)
  756.                (eval-expression body (extend-env ids args env))))))
  757.  
  758. ;*******************************************************************************************
  759.  
  760. ;**************************************************************************************
  761. ;Definición tipos de datos referencia y blanco
  762. ;**************************************************************************************
  763. (define-datatype target target?
  764.   (direct-target (expval expval?))
  765.   (indirect-target (ref ref-to-direct-target?)))
  766.  
  767. (define-datatype reference reference?
  768.   (a-ref (position integer?)
  769.          (vec vector?)))
  770. ;**************************************************************************************
  771.  
  772. ;**************************************************************************************
  773. ;Ambientes
  774. ;**************************************************************************************
  775. ;definición del tipo de dato ambiente
  776. (define-datatype environment environment?
  777.   (empty-env-record)
  778.   (extended-env-record
  779.    (syms (list-of symbol?))
  780.    (vec vector?)
  781.    (env environment?)))
  782.  
  783. (define scheme-value? (lambda (v) #t))
  784.  
  785. ;empty-env:      -> enviroment
  786. ;función que crea un ambiente vacío
  787. (define empty-env
  788.   (lambda ()
  789.     (empty-env-record)))       ;llamado al constructor de ambiente vacío
  790.  
  791.  
  792. ;extend-env: <list-of symbols> <list-of numbers> enviroment -> enviroment
  793. ;función que crea un ambiente extendido
  794. (define extend-env
  795.   (lambda (syms vals env)
  796.     (extended-env-record syms (list->vector vals) env)))
  797.  
  798. ;extend-env-recursively: <list-of symbols> <list-of <list-of symbols>> <list-of expressions> environment -> environment
  799. ;función que crea un ambiente extendido para procedimientos recursivos
  800. (define extend-env-recursively
  801.   (lambda (proc-names idss bodies old-env)
  802.     (let ((len (length proc-names)))
  803.       (let ((vec (make-vector len)))
  804.         (let ((env (extended-env-record proc-names vec old-env)))
  805.           (for-each
  806.             (lambda (pos ids body)
  807.               (vector-set! vec pos (direct-target (closure ids body env))))
  808.             (iota len) idss bodies)
  809.           env)))))
  810.  
  811. ;;;
  812. (define extend-env-refs
  813.   (lambda (syms vec env)
  814.     (extended-env-record syms vec env)))
  815.  
  816. ;iota: number -> list
  817. ;función que retorna una lista de los números desde 0 hasta end
  818. (define iota
  819.   (lambda (end)
  820.     (let loop ((next 0))
  821.       (if (>= next end) '()
  822.         (cons next (loop (+ 1 next)))))))
  823.  
  824. ;función que busca un símbolo en un ambiente
  825. (define apply-env
  826.   (lambda (env sym)
  827.     (deref (apply-env-ref env sym))))
  828.  
  829. (define apply-env-ref
  830.   (lambda (env sym)
  831.     (cases environment env
  832.       (empty-env-record ()
  833.                         (eopl:error 'apply-env-ref "No binding for ~s" sym))
  834.       (extended-env-record (syms vals env)
  835.                            (let ((pos (rib-find-position sym syms)))
  836.                              (if (number? pos)
  837.                                  (a-ref pos vals)
  838.                                  (apply-env-ref env sym)))))))
  839.  
  840.  
  841. ;**************************************************************************************
  842.  
  843.  
  844. ;**************************************************************************************
  845. ;Blancos y Referencias
  846. ;**************************************************************************************
  847. (define expval?
  848.   (lambda (x)
  849.     #t))
  850.  
  851. (define ref-to-direct-target?
  852.   (lambda (x)
  853.     (and (reference? x)
  854.          (cases reference x
  855.            (a-ref (pos vec)
  856.                   (cases target (vector-ref vec pos)
  857.                     (direct-target (v) #t)
  858.                     (indirect-target (v) #f)))))))
  859.  
  860. (define deref
  861.   (lambda (ref)
  862.     (cases target (primitive-deref ref)
  863.       (direct-target (expval) expval)
  864.       (indirect-target (ref1)
  865.                        (cases target (primitive-deref ref1)
  866.                          (direct-target (expval) expval)
  867.                          (indirect-target (p)
  868.                                           (eopl:error 'deref
  869.                                                       "Illegal reference: ~s" ref1)))))))
  870.  
  871. (define primitive-deref
  872.   (lambda (ref)
  873.     (cases reference ref
  874.       (a-ref (pos vec)
  875.              (vector-ref vec pos)))))
  876.  
  877. (define setref!
  878.   (lambda (ref expval)
  879.     (let
  880.         ((ref (cases target (primitive-deref ref)
  881.                 (direct-target (expval1) ref)
  882.                 (indirect-target (ref1) ref1))))
  883.       (primitive-setref! ref (direct-target expval)))))
  884.  
  885. (define primitive-setref!
  886.   (lambda (ref val)
  887.     (cases reference ref
  888.       (a-ref (pos vec)
  889.              (vector-set! vec pos val)))))
  890.  
  891. ;****************************************************************************************
  892.  
  893. ;****************************************************************************************
  894. (interpretador)

=>