Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3556

Modified Files: eval.lisp Log Message: In eval, support lambda-forms, and &aux bindings.

--- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/21 22:27:17 1.28 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/08 21:39:52 1.29 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.28 2008/03/21 22:27:17 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.29 2008/04/08 21:39:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -54,6 +54,7 @@ (defconstant +eval-binding-type-go-tag+ 1) (defconstant +eval-binding-type-block+ 2) (defconstant +eval-binding-type-macrolet+ 3) +(defconstant +eval-binding-type-declaration+ 4)

(defun eval-symbol (form env) "3.1.2.1.1 Symbols as Forms" @@ -79,80 +80,98 @@

(defun eval-cons (form env) "3.1.2.1.2 Conses as Forms" - (case (car form) - (quote (cadr form)) - (function (eval-function (second form) env)) - (if (if (eval-form (second form) env) - (eval-form (third form) env) - (eval-form (fourth form) env))) - (progn (eval-progn (cdr form) env)) - (prog1 (prog1 (eval-form (cadr form) env) - (eval-progn (cddr form) env))) - (tagbody (eval-tagbody form env)) - ((block) - (catch form - (eval-progn (cddr form) - (cons (list* +eval-binding-type-block+ - (cadr form) - form) - env)))) - ((macrolet) - (dolist (macrolet (cadr form)) - (destructuring-bind (name lambda &body body) - macrolet - (check-type name symbol) - (check-type lambda list) - (push (list* +eval-binding-type-macrolet+ - name - (cdr macrolet)) - env))) - (eval-progn (cddr form) - env)) - ((return-from) - (let ((b (cdr (op-env-binding env (cadr form) +eval-binding-type-block+)))) - (unless b (error "Block ~S is not visible." (cadr form))) - (throw (cdr b) - (eval-form (caddr form) env)))) - (go (eval-go form env)) - (setq (eval-setq form env)) - (setf (eval-setf form env)) - ((defvar) (eval-defvar form env)) - ((let) - (eval-let (cadr form) (cddr form) env)) - ((let*) - (multiple-value-bind (body declarations) - (parse-declarations-and-body (cddr form)) - (eval-let* (cadr form) declarations body env))) - ((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env)) - ((lambda) (eval-function form env)) ; the lambda macro.. - ((multiple-value-call) - (apply (eval-form (cadr form) env) - (mapcan (lambda (args-form) - (multiple-value-list (eval-form args-form env))) - (cddr form)))) - ((multiple-value-bind) - (eval-m-v-bind form env)) - ((multiple-value-prog1) - (multiple-value-prog1 (eval-form (cadr form) env) - (eval-progn (cddr form) env))) - ((destructuring-bind) - (eval-progn (cdddr form) - (make-destructuring-env (cadr form) - (eval-form (caddr form) env) - env))) - ((catch) - (catch (eval-form (second form) env) - (eval-progn (cddr form) env))) - ((throw) - (throw (eval-form (second form) env) - (eval-form (third form) env))) - ((unwind-protect) - (unwind-protect - (eval-form (second form) env) - (eval-progn (cddr form) env))) - ((symbol-macrolet let*) - (error "Special operator ~S not implemented in ~S." (car form) 'eval)) - (t (eval-funcall form env)))) + (if (and (consp (car form)) + (eq 'lambda (caar form))) + (eval-funcall (cons (let ((lambda-list (cadar form)) + (lambda-body (parse-docstring-declarations-and-body (cddar form)))) + (lambda (&rest args) + (declare (dynamic-extent args)) + (eval-progn lambda-body + (make-destructuring-env lambda-list args env + :environment-p nil + :recursive-p nil + :whole-p nil)))) + (cdr form)) + env) + (case (car form) + (quote (cadr form)) + (function (eval-function (second form) env)) + (if (if (eval-form (second form) env) + (eval-form (third form) env) + (eval-form (fourth form) env))) + (progn (eval-progn (cdr form) env)) + (prog1 (prog1 (eval-form (cadr form) env) + (eval-progn (cddr form) env))) + (tagbody (eval-tagbody form env)) + ((block) + (catch form + (eval-progn (cddr form) + (cons (list* +eval-binding-type-block+ + (cadr form) + form) + env)))) + ((macrolet) + (dolist (macrolet (cadr form)) + (destructuring-bind (name lambda &body body) + macrolet + (check-type name symbol) + (check-type lambda list) + (push (list* +eval-binding-type-macrolet+ + name + (cdr macrolet)) + env))) + (eval-progn (cddr form) + env)) + ((return-from) + (let ((b (cdr (op-env-binding env (cadr form) +eval-binding-type-block+)))) + (unless b (error "Block ~S is not visible." (cadr form))) + (throw (cdr b) + (eval-form (caddr form) env)))) + (go (eval-go form env)) + (setq (eval-setq form env)) + (setf (eval-setf form env)) + ((defvar) (eval-defvar form env)) + ((let) + (eval-let (cadr form) (cddr form) env)) + ((let*) + (multiple-value-bind (body declarations) + (parse-declarations-and-body (cddr form)) + (eval-let* (cadr form) declarations body env))) + ((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env)) + ;; ((lambda) (eval-function form env)) ; the lambda macro.. + ((multiple-value-call) + (apply (eval-form (cadr form) env) + (mapcan (lambda (args-form) + (multiple-value-list (eval-form args-form env))) + (cddr form)))) + ((multiple-value-bind) + (eval-m-v-bind form env)) + ((multiple-value-prog1) + (multiple-value-prog1 (eval-form (cadr form) env) + (eval-progn (cddr form) env))) + ((destructuring-bind) + (eval-progn (cdddr form) + (make-destructuring-env (cadr form) + (eval-form (caddr form) env) + env))) + ((catch) + (catch (eval-form (second form) env) + (eval-progn (cddr form) env))) + ((throw) + (throw (eval-form (second form) env) + (eval-form (third form) env))) + ((unwind-protect) + (unwind-protect + (eval-form (second form) env) + (eval-progn (cddr form) env))) + ((symbol-macrolet) + (error "Special operator ~S not implemented in ~S." (car form) 'eval)) + ((the) + (destructuring-bind (value-type form) + (cdr form) + (declare (ignore value-type)) + (eval-form form env))) + (t (eval-funcall form env)))))

(defun eval-progn (forms env) (do ((p forms (cdr p))) @@ -165,17 +184,17 @@ a0 a1) (if (null form) (funcall f) - (if (null (progn (setf a0 (eval-form (pop form) env)) form)) - (funcall f a0) - (if (null (progn (setf a1 (eval-form (pop form) env)) form)) - (funcall f a0 a1) - (apply (lambda (f env a0 a1 &rest args) - (declare (dynamic-extent args)) - (let ((evaluated-args (do ((p args (cdr p))) - ((endp p) args) - (setf (car p) (eval-form (car p) env))))) - (apply f a0 a1 evaluated-args))) - f env a0 a1 form)))))) + (if (null (progn (setf a0 (eval-form (pop form) env)) form)) + (funcall f a0) + (if (null (progn (setf a1 (eval-form (pop form) env)) form)) + (funcall f a0 a1) + (apply (lambda (f env a0 a1 &rest args) + (declare (dynamic-extent args)) + (let ((evaluated-args (do ((p args (cdr p))) + ((endp p) args) + (setf (car p) (eval-form (car p) env))))) + (apply f a0 a1 evaluated-args))) + f env a0 a1 form))))))

(defun parse-declarations-and-body (forms) "From the list of FORMS, return first the list of non-declaration forms, ~ @@ -259,7 +278,7 @@ (eq '&environment (car pattern))) (setf env-var (cadr pattern) pattern (cddr pattern))) - (loop with next-states = '(&optional &rest &key) + (loop with next-states = '(&optional &rest &key &aux) with state = 'requireds for pp on pattern as p = (car pp) if (member p next-states) @@ -313,7 +332,14 @@ present-p) env)) (push (cons var value) - env)))))) + env)))) + (&aux + (multiple-value-bind (var init-form) + (if (consp p) + (values (car p) (cadr p)) + (values p nil)) + (push (cons var (eval-form init-form env)) + env))))) (t (error "Illegal destructuring pattern: ~S" pattern))) (when (not (listp (cdr pp))) (push (cons (cdr pp) values) @@ -519,25 +545,26 @@ (defun macroexpand-1 (form &optional env) (if (atom form) (values form nil) ; no symbol-macros yet - (let* ((operator (car form)) - (macrolet-binding (op-env-binding env operator +eval-binding-type-macrolet+))) - (if macrolet-binding - (destructuring-bind (lambda-list &body body) - (cddr macrolet-binding) - (let ((expander (lambda (form env) - (eval-form `(destructuring-bind (ignore-operator ,@lambda-list) - ',form - (declare (ignore ignore-operator)) - ,@body) - env)))) - (values (funcall *macroexpand-hook* expander form env) - t))) - (let ((macro-function (macro-function operator))) - (if macro-function - (values (funcall *macroexpand-hook* macro-function form env) - t) - (values form - nil))))))) + (let ((operator (car form))) + (when (symbolp operator) + (let ((macrolet-binding (op-env-binding env operator +eval-binding-type-macrolet+))) + (if macrolet-binding + (destructuring-bind (lambda-list &body body) + (cddr macrolet-binding) + (let ((expander (lambda (form env) + (eval-form `(destructuring-bind (ignore-operator ,@lambda-list) + ',form + (declare (ignore ignore-operator)) + ,@body) + env)))) + (values (funcall *macroexpand-hook* expander form env) + t))) + (let ((macro-function (macro-function operator))) + (if macro-function + (values (funcall *macroexpand-hook* macro-function form env) + t) + (values form + nil)))))))))

(defun macroexpand (form &optional env) (do ((expanded-at-all-p nil)) (nil)