[movitz-cvs] CVS movitz/losp/muerte
ffjeld
ffjeld at common-lisp.net
Tue Apr 8 21:39:52 UTC 2008
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 at 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 , at lambda-list)
- ',form
- (declare (ignore ignore-operator))
- , at 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 , at lambda-list)
+ ',form
+ (declare (ignore ignore-operator))
+ , at 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)
More information about the Movitz-cvs
mailing list