[movitz-cvs] CVS movitz/losp/muerte
ffjeld
ffjeld at common-lisp.net
Wed Jul 9 20:11:23 UTC 2008
Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv22261
Modified Files:
eval.lisp
Log Message:
Add and employ define-eval-special-operator.
--- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/27 16:14:10 1.34
+++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/07/09 20:11:23 1.35
@@ -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.34 2008/04/27 16:14:10 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.35 2008/07/09 20:11:23 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -19,6 +19,23 @@
(in-package muerte)
+(define-compile-time-variable *eval-special-operators*
+ (make-hash-table :test #'eq))
+
+(defmacro define-eval-special-operator (operator lambda-list &body body)
+ (let ((name (intern (format nil "~A-~A" 'eval-special-operator operator))))
+ `(progn
+ (eval-when (:compile-toplevel)
+ (setf (gethash (find-symbol ,(symbol-name operator))
+ *eval-special-operators*)
+ ',name))
+ (defun ,name ,lambda-list , at body))))
+
+(defun special-operator-p (symbol)
+ (if (gethash symbol *eval-special-operators*)
+ t
+ nil))
+
(defun eval (form)
(eval-form form nil))
@@ -77,6 +94,130 @@
;;;
;;;Figure 3-2. Common Lisp Special Operators
+(define-eval-special-operator quote (form env)
+ (declare (ignore env))
+ (cadr form))
+
+(define-eval-special-operator progn (form env)
+ (eval-progn (cdr form) env))
+
+(define-eval-special-operator if (form env)
+ (if (eval-form (second form) env)
+ (eval-form (third form) env)
+ (eval-form (fourth form) env)))
+
+(define-eval-special-operator block (form env)
+ (catch form
+ (eval-progn (cddr form)
+ (cons (list* +eval-binding-type-block+
+ (cadr form)
+ form)
+ env))))
+
+(define-eval-special-operator return-from (form env)
+ (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))))
+
+(define-eval-special-operator macrolet (form env)
+ (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))
+
+(define-eval-special-operator let (form env)
+ (let ((var-specs (cadr form))
+ (declarations-and-body (cddr form)))
+ (let (special-vars
+ special-values
+ (local-env env))
+ (multiple-value-bind (body declarations)
+ (parse-declarations-and-body declarations-and-body)
+ (dolist (var-spec var-specs)
+ (multiple-value-bind (var init-form)
+ (if (atom var-spec)
+ (values var-spec nil)
+ (values (car var-spec) (cadr var-spec)))
+ (cond
+ ((or (symbol-special-variable-p var)
+ (declared-special-p var declarations))
+ ;; special
+ (push var special-vars)
+ (push (eval-form init-form env) special-values))
+ (t ;; lexical
+ (push (cons var (eval-form init-form env))
+ local-env)))))
+ (if (null special-vars)
+ (eval-progn body local-env)
+ (progv special-vars special-values
+ (eval-progn body local-env)))))))
+
+(define-eval-special-operator let* (form env)
+ (let ((var-specs (cadr form))~)
+ (if (null var-specs)
+ (eval-progn body env)
+ (multiple-value-bind (body declarations)
+ (parse-declarations-and-body (cddr form))
+ (multiple-value-bind (var init-form)
+ (let ((var-spec (pop var-specs)))
+ (if (atom var-spec)
+ (values var-spec nil)
+ (destructuring-bind (var init-form)
+ var-spec
+ (values var init-form))))
+ (if (or (symbol-special-variable-p var)
+ (declared-special-p var declarations))
+ (progv (list var) (list (eval-form init-form env))
+ (eval-let* var-specs
+ declarations
+ body
+ env))
+ (eval-let* var-specs
+ declarations
+ body
+ (cons (cons var
+ (eval-form init-form env))
+ env))))))))
+
+(define-eval-special-operator multiple-value-call (form env)
+ (apply (eval-form (cadr form) env)
+ (mapcan (lambda (args-form)
+ (multiple-value-list (eval-form args-form env)))
+ (cddr form))))
+
+(define-eval-special-operator catch (form env)
+ (catch (eval-form (second form) env)
+ (eval-progn (cddr form) env)))
+
+(define-eval-special-operator throw (form env)
+ (throw (eval-form (second form) env)
+ (eval-form (third form) env)))
+
+(define-eval-special-operator unwind-protect (form env)
+ (unwind-protect
+ (eval-form (second form) env)
+ (eval-progn (cddr form) env)))
+
+(define-eval-special-operator the (form env)
+ (destructuring-bind (value-type form)
+ (cdr form)
+ (declare (ignore value-type))
+ (eval-form form env)))
+
+(define-eval-special-operator multiple-value-prog1 (form env)
+ (multiple-value-prog1 (eval-form (cadr form) env)
+ (eval-progn (cddr form) env)))
+
+(define-eval-special-operator symbol-macrolet (form env)
+ (error "Special operator ~S not implemented in ~S." (car form) 'eval))
(defun eval-cons (form env)
"3.1.2.1.2 Conses as Forms"
@@ -93,80 +234,16 @@
: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)))
- ((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)))))
+ (let ((special-operator (gethash (car form) *eval-special-operators*)))
+ (if special-operator
+ (funcall special-operator form env)
+ (case (car form)
+ (setq (eval-setq form env))
+ (setf (eval-setf form env))
+;; ((defvar) (eval-defvar form env))
+ ((multiple-value-bind)
+ (eval-m-v-bind form env))
+ (t (eval-funcall form env)))))))
(defun eval-progn (forms env)
(do ((p forms (cdr p)))
@@ -249,17 +326,6 @@
declarations
docstring)))))))
-(defun parse-docstring-declarations-and-body (forms &optional (declare 'declare))
- "From the list of FORMS, return first the list of non-declaration forms, ~
-second the list of declaration-specifiers, third any docstring."
- (assert (eq declare 'declare))
- (if (or (not (cdr forms))
- (not (stringp (car forms))))
- (parse-declarations-and-body forms)
- (multiple-value-call #'values
- (parse-declarations-and-body (cdr forms))
- (car forms))))
-
(defun compute-function-block-name (function-name)
(cond
((symbolp function-name) function-name)
@@ -275,22 +341,6 @@
(member var (cdr d)))
(return t))))
-(defun eval-defun (name lambda-list body env)
- (with-simple-restart (continue "Defun ~S anyway." name)
- (assert (not (eq (symbol-package name)
- (find-package 'common-lisp)))
- () "Won't allow defun of the Common Lisp symbol ~S." name))
- (setf (symbol-function name)
- (install-funobj-name name
- (lambda (&rest args)
- (declare (dynamic-extent args))
- (eval-progn body (make-destructuring-env
- lambda-list args env
- :environment-p nil
- :recursive-p nil
- :whole-p nil)))))
- name)
-
(defun decode-optional-formal (formal)
"3.4.1.2 Specifiers for optional parameters.
Parse {var | (var [init-form [supplied-p-parameter]])}
@@ -405,31 +455,6 @@
env)
env)))
-(defun eval-let (var-specs declarations-and-body env)
- (let (special-vars
- special-values
- (local-env env))
- (multiple-value-bind (body declarations)
- (parse-declarations-and-body declarations-and-body)
- (dolist (var-spec var-specs)
- (multiple-value-bind (var init-form)
- (if (atom var-spec)
- (values var-spec nil)
- (values (car var-spec) (cadr var-spec)))
- (cond
- ((or (symbol-special-variable-p var)
- (declared-special-p var declarations))
- ;; special
- (push var special-vars)
- (push (eval-form init-form env) special-values))
- (t ;; lexical
- (push (cons var (eval-form init-form env))
- local-env)))))
- (if (null special-vars)
- (eval-progn body local-env)
- (progv special-vars special-values
- (eval-progn body local-env))))))
-
(defun eval-let* (var-specs declarations body env)
(if (null var-specs)
(eval-progn body env)
@@ -475,27 +500,28 @@
env)))))
(eval-progn body env)))))
-(defun eval-function (function-name env)
- (etypecase function-name
- (symbol
- (let ((binding (cdr (op-env-binding env function-name +eval-binding-type-flet+))))
- (or (and binding (cdr binding))
- (symbol-function function-name))))
- (list
- (ecase (car function-name)
- ((setf)
- (symbol-function (lookup-setf-function (second function-name))))
- ((lambda)
- (let ((lambda-list (cadr function-name))
- (lambda-body (parse-docstring-declarations-and-body (cddr function-name))))
- (install-funobj-name :anonymous-lambda
- (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))))))))))
+(define-eval-special-operator function (form env)
+ (let ((function-name (second form)))
+ (etypecase function-name
+ (symbol
+ (let ((binding (cdr (op-env-binding env function-name +eval-binding-type-flet+))))
+ (or (and binding (cdr binding))
+ (symbol-function function-name))))
+ (list
+ (ecase (car function-name)
+ ((setf)
+ (symbol-function (lookup-setf-function (second function-name))))
+ ((lambda)
+ (let ((lambda-list (cadr function-name))
+ (lambda-body (parse-docstring-declarations-and-body (cddr function-name))))
+ (install-funobj-name :anonymous-lambda
+ (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)))))))))))
(defun lookup-setf-function (name)
(let ((setf-name (gethash name *setf-namespace*)))
@@ -515,28 +541,27 @@
(cons (eval-form (car list) env)
(eval-arglist (cdr list) env))))
-(defun eval-tagbody (form env)
+(define-eval-special-operator tagbody (form env)
;; build the..
(do* ((pc (cdr form) (cdr pc))
(instruction (car pc) (car pc)))
- ((endp pc))
+ ((endp pc))
(when (typep instruction '(or integer symbol))
(push (list* +eval-binding-type-go-tag+ instruction form)
env)))
;; execute body..
(prog ((pc (cdr form)))
start
- (let ((tag (catch form
- (do () ((endp pc) (go end))
- (let ((instruction (pop pc)))
[19 lines skipped]
More information about the Movitz-cvs
mailing list