meval.lsp

lisp下面编写的meval的lisp语言解释器

;
; meta evaluateur
;

(defun meval (exp env)
  (cond
   ; constante
   ((and (atom exp) (constantp exp)) 
    ;(print "constante")
    exp)

   ; variable
   ((atom exp) 
    ;(if debug (print "variable"))
    (get-val exp env))

   ; defun
   ((eq 'defun (car exp))
    (mdefun (cdr exp)))

   ; and, or binaires
   ((eq 'and (car exp))
    (and (meval (cadr exp) env) (meval (caddr exp) env)))
   ((eq 'or (car exp))
    (or (meval (cadr exp) env) (meval (caddr exp) env)))

   ; setf
   ((eq 'setf (car exp))
    ;(if debug (print "setf"))
    (meval-setf (cadr exp) (meval (caddr exp) env) env))

   ; quote
   ((eq 'quote (car exp))
    ;(if debug (print "quote"))
    (cadr exp))

   ; cond
   ((eq 'cond (car exp))
    ;(if debug (print "cond"))
    (meval-cond (cdr exp) env))

   ; progn
   ((eq 'progn (car exp))
    ;(if debug (print "progn"))
    (meval-progn (cdr exp) env))

   ; labels
   ((eq 'labels (car exp))
    ;(if debug (print "labels"))
    (meval-labels (cdr exp) env))

   ; if
   ((eq 'if (car exp))
    ;(if debug (print "if"))
    (if (meval (cadr exp) env)
	(meval (caddr exp) env)
      (if (not (null (cdr exp)))
        (meval (cadddr exp) env))))
   
   ; let
   ((eq 'let (car exp))
    ;(if debug (print "let"))
    (meval-let exp env))

   ; apply
;   ((eq 'apply (car exp))
;    (print "apply, le mien!")
;    ;  (let ((args (meval-args (caddr exp) env)))
;    ;  (fn (meval (cadr args) env)))
;    (meval (cons (cadr exp) (get-apply-args (cddr exp))) env))

   ; function
;   ((eq 'function (car exp))
;    ;(if debug (print "function"))
;    (cond ((consp (cadr exp))
;	   `(:closure ,(cadr exp) ,env)))
;    (setf (get (cadr exp) :defun)
;	  `(lambda ,@(cddr exp))))

   ; lambda-expression
   ((and (consp (car exp)) (eq 'lambda (caar exp)))
    ;(if debug (print "lambda"))
    (meval-lambda (car exp) (meval-args (cdr exp) env) env))
    
   ; execution d'une fonction locale
   ((get-local-fonction (car exp) env)
    (meval-lambda (get-local-fonction (car exp) env)
		  (meval-args (cdr exp) env) env))

   ; execution d'une fonction globale
   ((and (atom (car exp)) (get (car exp) :defun))
    (meval-lambda (get (car exp) :defun) 
		  (meval-args (cdr exp) env) env))

   ; execution d'une fonction primitive ou non mdefinie
   ((symbol-function (car exp))
    ;(if debug (print "exec primitive"))
    (apply (symbol-function (car exp))
	   (meval-args (cdr exp) env)))

   ; le reste on 関alue par CLISP
   (t (print "Execution par CLISP")
      (apply (car exp) (meval-args (cdr exp) env)))))

; meval-args
; liste args -> liste des valeurs des args
(defun meval-args (var env)
  (if (null var)
      nil
    (cons (meval (car var) env) (meval-args (cdr var) env))))

; format d'une lambda exp
;           v (cadar exp)      v (cdr exp)
; ((lambda (parametres) corps) arguments)
;  ^ (car exp)         ^ (cddar exp)
; 1. evaluer les arguments
; 2. creer l'env param/val
; 3. evaluer le corps dans cet env
(defun meval-lambda (lmd largs env)
  ;(meval-progn (caddr lmd) (make-env (cadr lmd) largs env)))
  ; ??? cddr pour permettre plusieurs instructions dans une lambda
  (meval-progn (cddr lmd) (make-env (cadr lmd) largs env)))

(defun make-env (var val env)
  (if (null var)
      env
    (cons
      (cons (car var) (car val))
      (make-env (cdr var) (cdr val) env))))

(defun get-val (var env)
  (if (or (null var) (null env))
      (warn "Erreur d'arguments dans get-val: variable ~s inconnue" var)
    (if (eq (caar env) var)
	(cdar env)
      (get-val var (cdr env)))))

(defun meval-setf (place valeur env)
  (if (symbolp place)
      (let ((cell (assoc place env))
	    (val (meval valeur env)))
	(if cell
	    (setf (cdr cell) val)
	  (error "meval-setf: variable inconnue")))
    (cond ((eq 'get (car place))
	   (setf (get (cadr place) (caddr place))
		 valeur)))))

(defun meval-let (exp env)
  (meval-progn (cddr exp) (make-env-let (cadr exp) env)))

(defun make-env-let (args env)
  (if (null args)
      env      
    (cons (cons (caar args) (meval (cadar args) env)) (make-env-let (cdr args) env))))
;	       (list (append (reverse (let-args (cadr exp)))))))
	       

(defun meval-progn (exp env)
  (if (null exp)
      nil
    (cond 
      ((atom exp)
       (meval exp env))
      ((null (cdr exp))
       (meval (car exp) env))
      (t
       (meval (car exp) env)
       (meval-progn (cdr exp) env)))))

(defun mload (fic)
  (labels ((lit (X)
		(let ((r (read X nil nil nil)))
		  (if r
		      (progn (meval r nil) (lit X))
		    T))))
    (lit (open fic))))

(defun get-apply-args (exp)
  (if (null (cdr exp))
    (car exp)
    (cons (car exp) (get-apply-args (cdr exp)))))
    ;(atom list) (eval list)
    ;(cons (car list) (get-apply-args (cdr list)))))

(defun explode (list)
  (if (null list) ()
    (cons (car list) (explode (cdr list)))))

; defun = meval defun
(defun mdefun (exp)
  ;(if debug (print "mdefun"))
  (setf (get (car exp) :defun)
	`(lambda ,@(cdr exp))))

; rajoute les fonctions locales dans l'environnement sous la forme:
; ( (fonc arg1 arg2) (if ..) )
; puis execute le corps avec le nouvel environnement ainsi cr殚
(defun meval-labels (exp env)
  (if (null (car exp))
    (progn
      (meval-progn (cdr exp) env))
    (meval-labels (cons (cdar exp) (cdr exp))
		  (cons 
		    (cons 
		      (cons (caaar exp) (cadaar exp))
		      (cadr (cdaar exp)))
		    env))))

(defun get-local-fonction (nom env)
  (if (null env)
      nil
    (if (and (consp (caar env)) (eq nom (caaar env)))
        `(lambda ,(cdaar env) ,(cdar env))
      (get-local-fonction nom (cdr env)))))

(defun meval-cond (exp env)
  (if (null exp)
      nil
    (if (null (meval (caar exp) env))
	(meval-cond (cdr exp) env)
      (meval-progn (cdar exp) env))))