Ejemplos de clase

#lang eopl

;; <programa> = <expresion>  (program)
;; <expresion> = <identificador>  (id-exp)
;; <expresion> = "(" <identificador> <operacion> <identificador> ")"  (op-exp)
;; <operacion> = "+" (sum-op)
;; <operacion> = "-" (res-op)
;;<operacion>  = "/" (div-op)
;; <operador> = "*"  (mul-op)


(define especificacionLexica
  '(
    (espacioBlanco (whitespace) skip)
    (comentario ("//" (arbno (not #\newline))) skip)
    (identificador (letter (arbno (or digit letter))) symbol)
    (palabra  ("\"" (or letter digit) (arbno (or digit letter)) "\"") string)
    (numero (digit (arbno digit)) number)
    )
  )

(define especificacionGramatical
  '(
    (programa (expresion) program)
    (expresion (identificador) id-exp)
    (expresion ( "(" identificador operador identificador ")") op-exp)
    (operador ("+") sum-op)
    (operador ("-") res-op)
    (operador ("/") div-op)
    (operador ("*") mul-op)
    )
  )

;Construidos automáticamente:

(sllgen:make-define-datatypes especificacionLexica especificacionGramatical)

(define show-the-datatypes
  (lambda () (sllgen:list-define-datatypes especificacionLexica especificacionGramatical)))
;Parser, Scanner, Interfaz

;El FrontEnd (Análisis léxico (scanner) y sintáctico (parser) integrados)

(define scan&parse
  (sllgen:make-string-parser especificacionLexica especificacionGramatical))

;El Analizador Léxico (Scanner)

(define just-scan
  (sllgen:make-string-scanner especificacionLexica especificacionGramatical))

;El Interpretador (FrontEnd + Evaluación + señal para lectura )

(define interpretador
  (sllgen:make-rep-loop "--> "
    (lambda (pgm) (evaluarPrograma  pgm))
    (sllgen:make-stream-parser
      especificacionLexica
      especificacionGramatical)))

(define evaluarPrograma
  (lambda (x)
    (cases programa x
      (program (exp)
               (evaluarExpresion exp)
      )
    )
  ))

(define evaluarExpresion
  (lambda (exp)
    (cases expresion exp
      (id-exp (dato) (apply-env (init-env) dato))
      (op-exp (id1 op id2)
              (let
                  ((a (apply-env (init-env) id1))
                   (b (apply-env (init-env) id2))
                   )
                (evaluarOperador a op b)
                )
              )
      )
    )
  )

(define evaluarOperador
  (lambda (a op b)
    (cases operador op
      (sum-op () (+ a b))
      (res-op () (- a b))
      (div-op () (/ a b))
      (mul-op () (* a b))
      )
    )
  )

;;Ambientes

; Ambiente inicial
(define init-env
  (lambda ()
    (extend-env
     '(i v x)
     '(1 5 10)
     (empty-env))))
;definición del tipo de dato ambiente
(define-datatype environment environment?
  (empty-env-record)
  (extended-env-record (syms (list-of symbol?))
                       (vals (list-of scheme-value?))
                       (env environment?)))

(define scheme-value? (lambda (v) #t))

;empty-env:      -> enviroment
;función que crea un ambiente vacío
(define empty-env
  (lambda ()
    (empty-env-record)))       ;llamado al constructor de ambiente vacío


;extend-env: <list-of symbols> <list-of numbers> enviroment -> enviroment
;función que crea un ambiente extendido
(define extend-env
  (lambda (syms vals env)
    (extended-env-record syms vals env)))

;función que busca un símbolo en un ambiente
(define apply-env
  (lambda (env sym)
    (cases environment env
      (empty-env-record ()
                        (eopl:error 'apply-env "No binding for ~s" sym))
      (extended-env-record (syms vals env)
                           (let ((pos (list-find-position sym syms)))
                             (if (number? pos)
                                 (list-ref vals pos)
                                 (apply-env env sym)))))))
;****************************************************************************************
;Funciones Auxiliares

; funciones auxiliares para encontrar la posición de un símbolo
; en la lista de símbolos de unambiente

(define list-find-position
  (lambda (sym los)
    (list-index (lambda (sym1) (eqv? sym1 sym)) los)))

(define list-index
  (lambda (pred ls)
    (cond
      ((null? ls) #f)
      ((pred (car ls)) 0)
      (else (let ((list-index-r (list-index pred (cdr ls))))
              (if (number? list-index-r)
                (+ list-index-r 1)
                #f))))))