#|

==========================
MetaInterprete v. 1.0b
==========================

©Freeware.
Autores: Luigi Ceccaroni, Enrique Alvarez.
UPCÕ97.

Comentarios:

MetaInterprete es un intŽrprete de CommonLisp. Actualmente, su principal
funcionalidad es a nivel pedag—gico (y de simple debugger). El sistema muestra
la gestion que se realiza del entorno de variables y funciones (a nivel temporal),
as’ como la evaluaci—n de las principales estructuras de control 
algor’tmico. Esto permite entender f‡cilmente el flujo de operaciones a lo
largo del proceso.

Expresiones Interpretadas:
   - nil
   - t
   - numeros
   - strings
   - s’mbolos
      - Todos los s’mbolos soportados por Lisp.
      - Variables propias del sistema:
		- *entorno-variables*
		Contiene el entorno de variables.
		Su estructura es '((varN valorN)...(var1 valor1)) y se gestiona en forma de pila (acceso desde la izqda.).
	  	Permite un acceso total por parte del usuario, por tanto se debe ir con CAUTELA a la hora de alterar su contenido.
        	- *entorno-funciones*
		Contiene el entorno de funciones.
	    	Su estructura es '((nomfunN listaargsN listacuerpoN)...(nomfun1 listaargs1 listacuerpo1)) y se gestiona en forma de
                pila (acceso desde la izqda.).
	    	Permite un acceso total por parte del usuario, por tanto se debe ir con CAUTELA a la hora de alterar su contenido.
       	        - *colaboradores*
	        Contiene el nœmero de interpretes (app esclavas) que colaboran con este interprete (maestro).
         	Esta version del interprete no soporta esta funcionalidad.
         	Su valor es 0. El intento de modificacion de esta variable causara un error.
       	        - *imprimir-mensajesp*
         	Variable l—gica.
         	Segœn su valor, se visualizaran o no los comentarios explicativos del proceso de interpretacion.

   - funciones:
       - quote
       - eval
       - let
       - setq
       - setf
       - if
       - when
       - unless
       - cond
       - defun
       - function
       - apply
       - funcall
       - progn
       - mapcar
       - labels
       - dolist
       - Funciones definidas por el usuario.
       - Funciones propias del sistema:
                - bye: Sale del Interprete. 
                - autores: E-mail de los autores. 




|#

(defvar *entorno-variables* nil)
(defvar *entorno-funciones* nil)
(defvar *imprimirp* t)
(defvar *colaboradores* 1)
(defvar inctab 2)

(defun metacircular (expresion)
  "Evalua una expresion.
   expresion : (va precedida por un quote) 'N
   entorno   : '((N  2)))
         ->  2 "  
  (declare (special *colaboradores*))
  (if (> *colaboradores* 1)
    (metacircular1 expresion)
    (metacircular0 expresion)))

;;**************************************************************************************************

(defun metacircular0 (expresion &optional (tab 2))
  (declare (special *colaboradores* *entorno-variables* *entorno-funciones* *imprimirp* inctab))
  (cond
   ((eq nil expresion) 
    (format *imprimirp* "~&~vtEl s’mbolo ~a tiene el contenido ~a." tab expresion expresion)
    (values expresion *entorno-variables*))
   ((eq t expresion) 
    (format *imprimirp* "~&~vtEl s’mbolo ~a tiene el contenido ~a." tab expresion expresion)
    (values expresion *entorno-variables*))
   ((numberp expresion) 
    (format *imprimirp* "~&~vtEl s’mbolo ~a es un ‡tomo numŽrico." tab expresion)
    (values expresion *entorno-variables*))
   ((stringp expresion) 
    (format *imprimirp* "~&~vtEl s’mbolo ~a es una expresion de texto." tab expresion)
    (values expresion *entorno-variables*))
   ((symbolp expresion) 
    (cond  ((equalp expresion '*colaboradores*)
            (format *imprimirp* "~&~vtEl nœmero de colaboradores es: ~a." tab 
                    *colaboradores*)
            (values *colaboradores* *entorno-variables*))
           ((equalp expresion '*entorno-variables*)
            (format *imprimirp* "~&~vtEl entorno de variables actual es:" tab)
            (dolist (var *entorno-variables*)
              (format *imprimirp* "~&~vt~a" (+ tab inctab) var))
            (values *entorno-variables* *entorno-variables*))
           ((equalp expresion '*entorno-funciones*)
            (format *imprimirp* "~&~vtEl entorno de funciones actual es:" tab)
            (dolist (fun *entorno-funciones*)
              (format *imprimirp* "~&~vt~a" (+ tab inctab) fun))
            (values *entorno-funciones* *entorno-variables*))
           ((equalp expresion '*imprimir-mensajesp*)
            (format *imprimirp* "~&~vtImpresion de mensajes esta: ~a" tab *imprimirp*)
            (values *imprimirp* *entorno-variables*))
           ((assoc expresion *entorno-variables*)
            (format *imprimirp* "~&~vtEl s’mbolo ~a tiene el contenido ~a en el entorno ~a." tab 
                    expresion
                    (first (rest (assoc expresion *entorno-variables*)))
                    *entorno-variables*)
            (values (first (rest (assoc expresion *entorno-variables*))) *entorno-variables*))
           (t
            (format *imprimirp* "~&~vtError: La variable ~a no tiene contenido en el entorno de variables ~a." tab 
                    expresion
                    *entorno-variables*)
            (throw 'error 'ERROR))))

   ((eq (first expresion) 'quote) 
    (format *imprimirp* "~&~vtLa expresi—n con quote es ~a." tab  (cadr expresion))
    (values (cadr expresion) *entorno-variables*))

   ((eq (first expresion) 'eval)
    (format *imprimirp* "~&~vtEvaluando con EVAL la expresion ~a." tab  
            (cadr expresion))
    (multiple-value-bind
      (resultado2 nuevo-entorno2)
      (metacircular0 (metacircular0 (first (rest expresion)) (+ tab inctab)) (+ tab inctab))
      (values resultado2 nuevo-entorno2)))
   
   ((eq (first expresion) 'let)
    (format *imprimirp* "~&~vtEvaluando la funci—n LET en el entorno de variables ~a." tab  *entorno-variables*)
    (let ((asignaciones (second expresion))
          (asignaciones-evaluadas nil)
          (cuerpo (rest (rest expresion))))
      (dolist (asignacion asignaciones)
        (let ((resultado (metacircular0 (first (rest asignacion)) (+ tab inctab))))
          (setq asignaciones-evaluadas (append asignaciones-evaluadas
                                               (list (cons (first asignacion)
                                                           (list resultado)))))))
      (format *imprimirp* "~&~vtA–adiendo las variables temporales ~a al entorno." tab asignaciones-evaluadas)
      (dolist (asignacion asignaciones-evaluadas)
        (setq *entorno-variables* (anyade-variable-a-entorno (first asignacion) (cadr asignacion) *entorno-variables*)))
      (let ((resultado (catch 'error (eval `(metacircular0 '(progn ,@cuerpo) ,(+ tab inctab))))))
        (format *imprimirp* "~&~vtEliminando las variables temporales ~a del entorno." 
                tab
                (mapcar #'(lambda (v) (first v)) asignaciones))
        (dolist (asignacion asignaciones-evaluadas)
          (setq *entorno-variables* (borra-variable-de-entorno (first asignacion) *entorno-variables*)))
        (if (equalp resultado 'error)
          (throw 'error 'ERROR))
        (format *imprimirp* "~&~vtSaliendo del LET dejando el entorno: ~a." tab *entorno-variables*)
        (values resultado *entorno-variables*))))
   
   ((eq (first expresion) 'setq)
    (format *imprimirp* "~&~vtEvaluando la funci—n SETQ en el entorno de variables ~a." tab  *entorno-variables*)
    (do ((argumentos (rest expresion))
         (resultado nil))
        ((endp argumentos) (values resultado *entorno-variables*))
      (if (symbolp (first argumentos))
        (let ((valor (metacircular0 (second argumentos) (+ tab inctab))))
          (cond ((equalp (first argumentos) '*colaboradores*)
                 (format t "~&Lo siento!")
                 (format t "~&Esta versi—n del intŽrprete no soporta la paralelizaci—n de c—digo.")
                 (throw 'error "Quizas en septiembre...<http://www-lsi.upc.es/~luigic/metav3.lisp.hqx.gz>"))
                ((equalp (first argumentos) '*entorno-variables*)
                 (eval `(setq ,(first argumentos) ',valor))
                 (format t "~&~vtCUIDADIN: Se manipula manualmente el entorno de variables." 0 ))
                ((equalp (first argumentos) '*entorno-funciones*)
                 (eval `(setq ,(first argumentos) ',valor))
                 (format t "~&~vtCUIDADIN: Se manipula manualmente el entorno de funciones." 0 ))
                ((equalp (first argumentos) '*imprimir-mensajesp*)
                 (eval `(setq *imprimirp* ',valor)))
                ((assoc (first argumentos) *entorno-variables*)
                 (setq *entorno-variables* (asigna-a-variable-en-entorno (first argumentos) valor *entorno-variables*)))
                (t
                 (setq *entorno-variables* (anyade-variable-a-entorno (first argumentos) valor *entorno-variables*))))
          (format *imprimirp* "~&~vtLa forma especial SETQ asigna a ~a el contenido ~a obteniendo el nuevo entorno ~a." tab 
                  (first argumentos)
                  valor *entorno-variables*)
          (setq resultado valor)
          (setq argumentos (rest (rest argumentos))))
        (progn (format t "~&~vtError: ~a no es un simbolo." tab  (first argumentos))
               (throw 'error 'ERROR)))))
   
   ;;SETF == SETQ
   ((eq (first expresion) 'setf)
    (format *imprimirp* "~&~vtEvaluando la funci—n SETF en el entorno de variables ~a." tab  *entorno-variables*)
    (do ((argumentos (rest expresion))
         (resultado nil))
        ((endp argumentos) (values resultado *entorno-variables*))
      (if (symbolp (first argumentos))
        (let ((valor (metacircular0 (second argumentos) (+ tab inctab))))
          (cond ((equalp (first argumentos) '*entorno-variables*)
                 (eval `(setq ,(first argumentos) ',valor))
                 (format t "~&~vtCUIDADIN: Se va a manipular manualmente el entorno de variables." tab ))
                ((equalp (first argumentos) '*entorno-funciones*)
                 (eval `(setq ,(first argumentos) ',valor))
                 (format t "~&~vtCUIDADIN: Se va a manipular manualmente el entorno de funciones." tab ))
                ((assoc (first argumentos) *entorno-variables*)
                 (setq *entorno-variables* (asigna-a-variable-en-entorno (first argumentos) valor *entorno-variables*)))
                (t
                 (setq *entorno-variables* (anyade-variable-a-entorno (first argumentos) valor *entorno-variables*))))
          (format *imprimirp* "~&~vtLa forma especial SETF asigna a ~a el contenido ~a obteniendo el nuevo entorno ~a." tab 
                  (first argumentos)
                  valor *entorno-variables*)
          (setq resultado valor)
          (setq argumentos (rest (rest argumentos))))
        (progn (format t "~&~vtEsta version del interprete solo acepta simbolos como lugar de asignacion de un SETF." tab )
               (throw 'error 'ERROR)))))
   
   ((eq (first expresion) 'if)
    (format *imprimirp* "~&~vtIF: evaluando la condicion ~a." tab 
            (second expresion))
    (let ((condicion (metacircular0 (second expresion) (+ tab inctab))))
      (cond (condicion
             (format *imprimirp* "~&~vtLa condicion ~a se cumple. Se va a evaluar la expresion [THEN]  ~a." tab 
                     (second expresion)
                     (third expresion))
             (multiple-value-bind
               (resultado nuevo-entorno)
               (metacircular0 (third expresion) (+ tab inctab))
               (values resultado nuevo-entorno)))
            (t
             (format *imprimirp* "~&~vtLa condicion ~a no se cumple. Se va a evaluar la expresion [ELSE]  ~a." tab 
                     (second expresion)
                     (fourth expresion))
             (multiple-value-bind
               (resultado nuevo-entorno)
               (metacircular0 (fourth expresion) (+ tab inctab))
               (values resultado nuevo-entorno))))))
   
   ((eq (first expresion) 'when)
    (format *imprimirp* "~&~vtWHEN: evaluando la condici—n ~a." tab 
            (second expresion))
    (let ((condicion (metacircular0 (second expresion) (+ tab inctab))))
      (cond (condicion
             (format *imprimirp* "~&~vtLa condicion ~a se cumple." tab 
                     (second expresion))
             (let ((cuerpo (cddr expresion)))
               (multiple-value-bind                          
                 (resultado nuevo-entorno)                     
                 (eval `(metacircular0 '(progn ,@cuerpo) ,(+ tab inctab)))
                 (values resultado nuevo-entorno))))
            (t
             (format *imprimirp* "~&~vtLa condicion ~a no se cumple." tab 
                     (second expresion))
             (values nil *entorno-variables*)))))
   
   ((eq (first expresion) 'unless)
    (format *imprimirp* "~&~vtUNLESS: evaluando la condici—n ~a." tab 
            (second expresion))
    (let ((condicion (metacircular0 (second expresion) (+ tab inctab))))
      (cond (condicion
             (format *imprimirp* "~&~vtLa condicion ~a se cumple." tab 
                     (second expresion))
             (values nil *entorno-variables*))
            (t
             (format *imprimirp* "~&~vtLa condicion ~a no se cumple." tab 
                     (second expresion))
             (let ((cuerpo (cddr expresion)))
               (multiple-value-bind                          
                 (resultado nuevo-entorno)                     
                 (eval `(metacircular0 '(progn ,@cuerpo) ,(+ tab inctab)))
                 (values resultado nuevo-entorno)))))))

   ((eq (first expresion) 'cond)
    (format *imprimirp* "~&~vtAplicando COND." tab)
    (let ((resultado-cond (do* ((condiciones (rest expresion) (rest condiciones))
                                (condicion (first condiciones) (first condiciones))
                                (resultado nil))
                               ((endp condiciones) resultado)
                            (format *imprimirp* "~&~vtEvaluando la condicion ~a." (+ tab inctab) 
                                    (first condicion))
                            (let ((condicion-evaluada (metacircular0 (first condicion) (+ tab inctab inctab)))
                                  (cuerpo (rest condicion)))
                              (cond (condicion-evaluada
                                     (format *imprimirp* "~&~vtLa condicion ~a se cumple. Se van a evaluar las correspondientes expresiones." 
                                             (+ tab inctab) 
                                             (first condicion))
                                     (setq resultado (eval `(metacircular0 '(progn ,@cuerpo) ,(+ tab inctab inctab))))
                                     (setq condiciones nil))
                                    (t
                                     (format *imprimirp* "~&~vtLa condicion ~a no se cumple." (+ tab inctab) 
                                             (first condicion))))))))
      (format *imprimirp* "~&~vtLa evaluacion de la funcion COND ha dado como resultado: ~a." tab resultado-cond)
      (values resultado-cond *entorno-variables*)))
   
   ((eq (first expresion) 'defun)
    (format *imprimirp* "~&~vtConstruyendo la funci—n ~a:~&~vtArgumentos: ~a~&~vtCuerpo: "
            tab (second expresion)
            (+ tab inctab) (third expresion) (+ tab inctab))
    (dolist (sentencia (cdddr expresion))
      (format *imprimirp* "~&~vt~a."
            (+ tab inctab) sentencia))
    (cond ((not (symbolp (second expresion)))
           (format t "~&~vtError: ~a no es un simbolo." tab 
                   (second expresion))
           (throw 'error 'ERROR))
          ((not (listp (third expresion)))
           (format t "~&~vtError: ~a no es una lista." tab 
                   (third expresion))
           (throw 'error 'ERROR))
          ((simbolos-repetidosp (third expresion))
           (format t "~&~vtError: la lista de argumentos contiene variables repetidas." tab )
           (throw 'error 'ERROR))
          ((assoc (second expresion) *entorno-funciones*)
           (setq *entorno-funciones* (redefine-funcion (second expresion)
                                                       (third expresion)
                                                       (cdddr expresion)
                                                       *entorno-funciones*))
           (format *imprimirp* "~&~vtRedefinida la funcion ~a obteniendo el nuevo entorno de funciones ~a." tab 
                  (second expresion)
                  (nombres-funciones-definidas *entorno-funciones*))
           (values (second expresion) *entorno-variables*))
          (t
           (setq *entorno-funciones* (anyade-funcion-a-entorno (second expresion) 
                                                               (third expresion)
                                                               (cdddr expresion)
                                                               *entorno-funciones*))
           (format *imprimirp* "~&~vtDefinida la funcion ~a obteniendo el nuevo entorno de funciones ~a." tab 
                  (second expresion)
                  (nombres-funciones-definidas *entorno-funciones*))
           (values (second expresion) *entorno-variables*))))

   ((eq (first expresion) 'function)
    (format *imprimirp* "~&~vtAplicando FUNCTION sobre el simbolo ~a." tab  (second expresion))
    (cond ((assoc (second expresion) *entorno-funciones*)
           (format *imprimirp* "~&~vt~a es una funcion definida por el usuario." tab  (second expresion))
           (values (second expresion) *entorno-variables*))
          ((funcion-primitiva-p (second expresion))
           (format *imprimirp* "~&~vt~a es una funcion primitiva de LISP." tab  (second expresion))
           (values (second expresion) *entorno-variables*))
          (t
           (format t "~&~vtError: ~a no es una funcion definida." tab  (second expresion))
           (throw 'error 'ERROR))))
   
   ((eq (first expresion) 'apply)  
    (format *imprimirp* "~&~vtAplicando APPLY a la expresion ~a con argumentos ~a." tab  (second expresion) (cddr expresion))
    (let ((nom-funcion (metacircular0 (second expresion) (+ tab inctab))))
      (cond ((and (not (assoc nom-funcion *entorno-funciones*))
                  (not (funcion-primitiva-p nom-funcion)))
             (format t "~&~vtError: ~a no se reconoce como una funcion." tab  nom-funcion)
             (throw 'error 'ERROR))
            (t
             (let ((argumentos-apply (do ((argumentos (cddr expresion) (rest argumentos))
                                          (resultados-argumentos nil))
                                         ((endp argumentos) resultados-argumentos)
                                       (let ((argumento-evaluado (metacircular0 (first argumentos) (+ tab inctab))))
                                         (cond ((= (length argumentos) 1)
                                                (cond ((listp argumento-evaluado)
                                                       (setq resultados-argumentos (append resultados-argumentos
                                                                                           argumento-evaluado)))
                                                      (t
                                                       (format t "~&~vtError: ~a no es una lista." tab argumento-evaluado)
                                                       (throw 'error 'ERROR))))
                                               (t
                                                (setq resultados-argumentos (append resultados-argumentos 
                                                                                    (list argumento-evaluado)))))))))
               (cond ((assoc nom-funcion *entorno-funciones*)
                      (multiple-value-bind (resultado entorno)
                                           (apply-fun-user (cons nom-funcion argumentos-apply) tab)
                        (values resultado entorno)))
                     ((funcion-primitiva-p nom-funcion)
                      (multiple-value-bind (resultado entorno)
                                           (apply-fun-lisp (cons nom-funcion argumentos-apply) tab)
                        (values resultado entorno)))))))))
   
   ((eq (first expresion) 'funcall)
    (format *imprimirp* "~&~vtAplicando FUNCALL sobre ~a." tab  (second expresion))
    (let ((nom-funcion (metacircular0 (second expresion) (+ tab inctab))))
      (cond ((assoc nom-funcion *entorno-funciones*)
             (multiple-value-bind (resultado entorno)
                                  (metacircular0 (cons nom-funcion (cddr expresion)) (+ tab inctab))
               (values resultado entorno)))
            ((funcion-primitiva-p nom-funcion)
             (multiple-value-bind (resultado entorno)
                                  (metacircular0 (cons nom-funcion (cddr expresion)) (+ tab inctab))
               (values resultado entorno)))
            (t
             (format t "~&~vtError: ~a no es una funcion definida." tab  nom-funcion)
             (throw 'error 'ERROR)))))

   ((eq (first expresion) 'progn)
    (format *imprimirp* "~&~vtEjecutando PROGN." tab)
    (let ((resultado (do ((expresiones (rest expresion) (rest expresiones))
                          (ultimo-resultado nil))
                         ((endp expresiones) ultimo-resultado)
                       (setq ultimo-resultado (metacircular0 (first expresiones) (+ tab inctab))))))
      (format *imprimirp* "~&~vtPROGN dio como resultado ~a." tab resultado)
      (values resultado *entorno-variables*)))
   
   ((eq (first expresion) 'mapcar)
    (format *imprimirp* "~&~vtAplicando MAPCAR." tab)
    (let ((nom-funcion (metacircular0 (second expresion) (+ tab inctab)))
          (listas-evaluados (mapcar #'(lambda (arg)
                                        (metacircular0 arg (+ tab inctab)))
                                    (cddr expresion))))
      (cond ((and (not (assoc nom-funcion *entorno-funciones*))
                  (not (funcion-primitiva-p nom-funcion)))
             (format t "~&~vtError: ~a no se reconoce como una funcion." tab nom-funcion)
             (throw 'error 'ERROR))
            (t
             (let ((resultado-mapcar (do* ((listas-argumentos listas-evaluados (mapcar #'rest listas-argumentos))
                                           (argumentos (mapcar #'first listas-argumentos) (mapcar #'first listas-argumentos))
                                           (resultado nil))
                                          ((member nil listas-argumentos) resultado)
                                       (cond ((assoc nom-funcion *entorno-funciones*)
                                              (setq resultado (append resultado
                                                                      (list (apply-fun-user (cons nom-funcion argumentos)
                                                                                            (+ tab inctab))))))
                                             ((funcion-primitiva-p nom-funcion)
                                              (setq resultado (append resultado
                                                                      (list (apply-fun-lisp (cons nom-funcion argumentos)
                                                                                            (+ tab inctab))))))))))
               (format *imprimirp* "~&~vtLa evaluacion de la funcion de MAPCAR ha dado como resultado: ~a." tab resultado-mapcar)
               (values resultado-mapcar *entorno-variables*))))))
   
   ((eq (first expresion) 'labels)
    (format *imprimirp* "~&~vtEvaluando la funci—n LABELS en el entorno de funciones ~a." tab  *entorno-funciones*)
    (let ((asignaciones (second expresion))
          (cuerpo (rest (rest expresion))))
      (format *imprimirp* "~&~vtA–adiendo las funciones temporales ~a al entorno." 
              tab
              (mapcar (function first) asignaciones))
      (dolist (asignacion asignaciones)
        (metacircular0 (cons 'defun asignacion) (+ tab inctab)))
      (let ((resultado (catch 'error (eval `(metacircular0 '(progn ,@cuerpo) ,(+ tab inctab))))))
        (format *imprimirp* "~&~vtEliminando las funciones temporales ~a del entorno." 
                tab
                (mapcar (function first) asignaciones))
        (dolist (asignacion asignaciones)
          (setq *entorno-funciones* (borra-funcion-de-entorno (first asignacion) *entorno-funciones*)))
        (if (equalp resultado 'error)
          (throw 'error 'ERROR))
        (format *imprimirp* "~&~vtSaliendo del LABELS dejando el entorno de funciones: ~a." tab *entorno-funciones*)
        (values resultado *entorno-variables*))))
   
   ((eq (first expresion) 'dolist)
    (format *imprimirp* "~&~vtEvaluando la funci—n DOLIST." tab)   ;;(dolist (var '(1 2 3) resultform) cuerpo)
    (let* ((variable (first (second expresion)))                    
           (listform (eval `(metacircular0 ',(second (second expresion)) ,(+ tab inctab))))
           (resultform (third (second expresion)))                   
           (cuerpo (rest (rest expresion))))
      (format *imprimirp* "~&~vtA–adiendo la variable temporal del DOLIST '~a' al entorno." tab variable)
      (setq *entorno-variables* (anyade-variable-a-entorno variable nil *entorno-variables*))
      
      (let* ((resultado (catch 'error (do* ((lista-valores listform (rest lista-valores))
                                            (asignacion (list variable (first lista-valores)) (list variable (first lista-valores))))
                                           ((endp lista-valores) nil)
                                        (format *imprimirp* "~&~vtAsignando a la variable temporal ~a el valor ~a." 
                                                tab
                                                variable
                                                (cadr asignacion))
                                        (setq *entorno-variables* (asigna-a-variable-en-entorno (first asignacion) (cadr asignacion) *entorno-variables*))
                                        (eval `(metacircular0 '(progn ,@cuerpo) ,(+ tab inctab)))))))
        (cond ((equalp resultado 'error)
               (format *imprimirp* "~&~vtEliminando la variable temporal ~a del entorno." 
                tab
                variable)
               (setq *entorno-variables* (borra-variable-de-entorno variable *entorno-variables*))
               (throw 'error 'ERROR))
              (t
               (let ((resultado-dolist (metacircular0 resultform (+ tab inctab))))
                 (format *imprimirp* "~&~vtLa evaluacion de la funcion de DOLIST ha dado como resultado: ~a." tab resultado-dolist)
                 (format *imprimirp* "~&~vtEliminando la variable temporal ~a del entorno." 
                         tab
                         variable)
                 (setq *entorno-variables* (borra-variable-de-entorno variable *entorno-variables*))
                 (format *imprimirp* "~&~vtSaliendo de DOLIST dejando el entorno: ~a." tab *entorno-variables*)
                 (values resultado-dolist *entorno-variables*)))))))

   ((equalp (first expresion) 'bye)
    (throw 'salir "bye, have a nice time!"))

   ((equalp (first expresion) 'autores)
    (format t "~&luigic@lsi.upc.es~&alvarez@pe.upc.es"))

   ((assoc (first expresion) *entorno-funciones*) ;;estas son las funciones definidas por el usuario
    (format *imprimirp* "~&~vtEvaluando la expresi—n ~a con los argumentos ~a." tab 
            (first expresion)
            (rest expresion))
    (let* ((definicion-funcion (assoc (first expresion) *entorno-funciones*))
           (argumentos-definicion (second definicion-funcion)))
      (cond ((not (= (length argumentos-definicion)
                     (length (rest expresion))))
             (format t "~&~vtError: la funcion ~a esta definida con ~a argumentos." tab  
                     (first expresion) (length argumentos-definicion))
             (throw 'error 'ERROR))
            (t
             (let ((argumentos-evaluados (mapcar #'(lambda (arg)
                                                     (metacircular0 arg (+ tab inctab)))
                                                 (rest expresion))))
               (multiple-value-bind (resultado entorno)
                                    (apply-fun-user (cons (first expresion) argumentos-evaluados) tab)
                 (values resultado entorno)))))))
   
   ((funcion-primitiva-p (first expresion))
    (format *imprimirp* "~&~vtEjecutando la funci—n de LISP ~a sobre ~a." tab 
            (first expresion)
            (rest expresion))
    (let* ((argumentos (rest expresion))
           (argumentos-evaluados (mapcar #'(lambda (arg)
                                             (metacircular0 arg (+ tab inctab)))
                                         argumentos)))
      (multiple-value-bind (resultado entorno)
                           (apply-fun-lisp (cons (first expresion) argumentos-evaluados) tab)
        (values resultado entorno))))
   (t
    (format *imprimirp* "~&~vtIntentando ejecutar el funcional desconocido ~a sobre ~a." tab 
            (first expresion)
            (rest expresion))
    (multiple-value-bind (resultado error) 
                         (ignore-errors (eval `(function ,(first expresion))))
      resultado
      (cond ((typep error 'error)
             (format *imprimirp* "~&~vt..................Error: No ha habido suerte!" tab)
             (format *imprimirp* "~&~vtEl funcional ~a es o un s’mbolo desconocido o bien una macro." tab (first expresion))
             (format *imprimirp* "~&~vtRecuerda que esta versi—n del interprete no soporta macros!" tab)
             (throw 'error 'ERROR))
            (t
             (let ((argumentos (rest expresion))
                   (argumentos-evaluados nil))
               (dolist (argumento argumentos)
                 (setq argumentos-evaluados (append argumentos-evaluados (list (metacircular0 argumento (+ tab inctab))))))
               (multiple-value-bind (resultado error) 
                                    (ignore-errors (eval `(,(first expresion) ,@argumentos-evaluados)))
                 (cond ((typep error 'error)
                        (format *imprimirp* "~&~vtError recibido de LISP durante la ejecuci—n de ~a" tab (first expresion))
                        (throw 'error 'ERROR))
                       (t
                        (format *imprimirp* "~&~vtLa evaluacion de la funcion de LISP ~a ha dado como resultado: ~a." tab 
                                (first expresion) resultado)
                        (values resultado *entorno-variables*)))))))))
    ))


(defun apply-fun-user (expresion tab)
  (let* ((argumentos-evaluados (rest expresion))
         (definicion-funcion (assoc (first expresion) *entorno-funciones*))
         (argumentos-definicion (second definicion-funcion))
         (cuerpo (third definicion-funcion)))
    (format *imprimirp* "~&~vtEvaluando la funcion ~a sobre los argumentos ~a ." tab  
                   (first expresion) (rest expresion))
    (cond ((not (= (length argumentos-definicion)
                   (length (rest expresion))))
           (format t "~&~vtError: la funcion ~a esta definida con ~a argumentos." tab  
                   (first expresion) (length argumentos-definicion))
           (throw 'error 'ERROR))
          (t
           (let ((variables-ligadas (dina-meta0 argumentos-definicion
                                                argumentos-evaluados
                                                (+ tab inctab))))
             (dolist (variable-ligada variables-ligadas)
               (setq *entorno-variables* (anyade-variable-a-entorno (first variable-ligada) 
                                                                    (cadr variable-ligada)
                                                                    *entorno-variables*))
               (format *imprimirp* "~&~vtConstruyendo LIGADURA con:~&~vtVariable: ~a~&~vtValor: ~a~&~vtEntorno: ~a"
                       (+ tab inctab) 
                       (+ tab inctab inctab) (first variable-ligada) 
                       (+ tab inctab inctab) (cadr variable-ligada)
                       (+ tab inctab inctab) *entorno-variables*))
             (let ((resultado (catch 'error (eval `(metacircular0 '(progn ,@cuerpo) ,(+ tab inctab))))))
               (dolist (variable-ligada variables-ligadas)
                 (setq *entorno-variables* (borra-variable-de-entorno (first variable-ligada)
                                                                      *entorno-variables*))
                 (format *imprimirp* "~&~vtEliminando LIGADURA con:~&~vtVariable: ~a~&~vtValor: ~a~&~vtEntorno: ~a"
                         (+ tab inctab) 
                         (+ tab inctab inctab) (first variable-ligada)
                         (+ tab inctab inctab) (cadr variable-ligada)
                         (+ tab inctab inctab) *entorno-variables*))
               (if (equalp resultado 'error) (throw 'error 'ERROR))
               (format *imprimirp* "~&~vtLa evaluacion de la funcion ~a ha dado como resultado: ~a." tab
                         (first expresion) resultado)
               (values resultado *entorno-variables*)))))))

(defun apply-fun-lisp (expresion tab)
  (let ((argumentos-evaluados (rest expresion)))
    (format *imprimirp* "~&~vtEvaluando la funcion ~a sobre los argumentos ~a ." tab  
                   (first expresion) (rest expresion))
      (multiple-value-bind (resultado error) 
                           (ignore-errors (eval `(apply (function ,(first expresion)) ',argumentos-evaluados)))
        (cond ((typep error 'error)
               (format *imprimirp* "~&~vtError recibido de LISP durante la ejecuci—n de ~a" tab (first expresion))
               (throw 'error 'ERROR))
              (t
               (format *imprimirp* "~&~vtLa evaluacion de la funcion de LISP ~a ha dado como resultado: ~a." tab 
                         (first expresion) resultado)
               (values resultado *entorno-variables*))))))

(defun simbolos-repetidosp (lista)
  (cond ((null lista) nil)
        ((member (first lista) (rest lista))
         t)
        (t
         (simbolos-repetidosp (rest lista)))))

(defun nombres-funciones-definidas (entorno-funciones)
  (mapcar #'(lambda (definicion-funcion) (first definicion-funcion)) entorno-funciones))

(defun anyade-funcion-a-entorno (nombre argumentos cuerpo entorno)
  (append (list (list nombre argumentos cuerpo)) entorno))

(defun redefine-funcion (nombre argumentos cuerpo entorno)
  (cond ((null entorno) nil)
        ((equal (caar entorno) nombre)
         (cons (list nombre argumentos cuerpo)
               (cdr entorno)))
        (t
         (cons (first entorno)
               (redefine-funcion nombre argumentos cuerpo (rest entorno))))))

(defun borra-funcion-de-entorno (nombre entorno)
  (borra-variable-de-entorno nombre entorno))

(defun anyade-variable-a-entorno (variable valor entorno)
  ;;Anyade una variable al entorno. Si existe otra con el mismo nombre no se borra.
  (append (list (cons variable (list valor))) entorno))

(defun asigna-a-variable-en-entorno (variable valor entorno)
  (cond ((null entorno) nil)
        ((equal (caar entorno) variable)
         (cons (cons variable (list valor))
               (cdr entorno)))
        (t
         (cons (first entorno)
               (asigna-a-variable-en-entorno variable valor (rest entorno))))))

(defun borra-variable-de-entorno (variable entorno)
  (cond ((null entorno) nil)
        ((equal (caar entorno) variable)
         (rest entorno))
        (t
         (cons (first entorno)
               (borra-variable-de-entorno variable (rest entorno))))))

(defun funcion-primitiva-p (funcion)
  (member funcion '(+ 
                    - 
                    / 
                    < 
                    <= 
                    = 
                    > 
                    >= 
                    ABS 
                    APPEND 
                    AREF 
                    ATOM 
                    BUTLAST 
                    CAR 
                    CASE 
                    CDR 
                    CHAR-EQUAL 
                    CHAR= 
                    COND 
                    CONS 
                    COUNT-IF 
                    DEFMACRO 
                    DEFSTRUCT 
                    DEFVAR 
                    DO 
                    DO* 
                    DOLIST 
                    DOTIMES 
                    ELT 
                    ENDP 
                    EQUALP 
                    EVENP 
                    EXPT 
                    FIND-IF 
                    FIRST 
                    FIRST 
                    FLOAT 
                    FORMAT 
                    GET 
                    LAST 
                    LENGTH 
                    LET* 
                    LIST 
                    LIST-LENGTH 
                    MAKE-ARRAY 
                    MAX 
                    MEMBER 
                    MIN 
                    NCONC 
                    NOT 
                    NULL 
                    NUMBERP 
                    ODDP 
                    PRINT 
                    READ 
                    READ-CHAR 
                    READ-LINE 
                    REMOVE-IF 
                    REMOVE-IF-NOT 
                    REMPROP 
                    REST 
                    REST 
                    REVERSE 
                    ROUND 
                    SEARCH 
                    SECOND 
                    SORT 
                    SQRT 
                    STRING-EQUAL 
                    STRING= 
                    STRINGP 
                    THIRD)))

(defun dina-meta0 (args-def args-llamada &optional (tab 2))
  ;;A–ade al entorno las variables args-def enlazadas con los valores args-llamada
  (declare (special *entorno-variables* inctab))
  (cond
   ((null args-def) 
    nil)
   (t
    (anyade-variable-a-entorno (first args-def)
                       (first args-llamada)
                       (dina-meta0 (rest args-def)
                                   (rest args-llamada)
                                   tab)))))

(defun meta-loop ()
  (flet ((lee ()
           (format t "~&~a" (catch 'salir (loop
                                          (format t "~&META> ")
                                          (print (catch 'error
                                                   (multiple-value-bind 
                                                     (resultado entorno)
                                                     (metacircular (read))
                                                     entorno
                                                     resultado))))))))
    (format t "Welcome to MetaInterprete Common Lisp Version 1.0b")
    (eval-enqueue `(funcall ,#'lee))))

(meta-loop)