summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Andreas Benkard <code@mail.matthias.benkard.de>2013-07-18 17:58:45 +0200
committerMatthias Andreas Benkard <code@mail.matthias.benkard.de>2013-07-18 17:58:45 +0200
commit674615a4f75a1e74cde65fc1ac0af532a475b05e (patch)
tree008443aa42edc4b1b7ac615618ab6922529a5134
parent044615051f1f574b5055095948c97e9fea4c4872 (diff)
Partially implement declaration parsing.
-rw-r--r--sb-eval2.lisp636
1 files changed, 332 insertions, 304 deletions
diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 672d784..9ae20be 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -376,155 +376,156 @@
(declaim (ftype (function * eval-closure) prepare-lambda))
(defun prepare-lambda (lambda-form context)
- (destructuring-bind (lambda-list &rest body) lambda-form
- ;; FIXME: SPECIAL declarations!
- (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
- morep more-context more-count)
- (sb-int:parse-lambda-list lambda-list)
- (declare (ignore more-context more-count))
- (declare (ignorable auxp))
- (when morep
- (error "The interpreter does not support the lambda-list keyword ~D"
- 'sb-int:&more))
- (let* ((argvars (append required
- (mapcan #'lambda-binding-vars optional)
- (mapcan #'lambda-binding-vars keys)
- (mapcan #'lambda-simple-binding-vars aux)
- (and restp (list rest))))
- (keywords (mapcar #'lambda-key keys))
- (required-num (length required))
- (optional-num (length optional))
- (key-num (length keys))
- (aux-num (length aux))
- (varnum (length argvars))
- (envp (or (> varnum +stack-max+)
- (maybe-closes-over-p `(progn ,@body) argvars)))
- (default-values (append (mapcar #'lambda-binding-default optional)
- (mapcar #'lambda-binding-default keys)
- (mapcar #'lambda-binding-default aux)))
- (new-context (context-add-env-lexicals context required))
- (default-values*
- (loop for default-value in default-values
- for binding in (append optional keys aux)
- for vars = (lambda-binding-vars binding)
- collect (prepare-form default-value new-context)
- do (dolist (var vars)
- (context-add-env-lexical! new-context var))
- finally (when restp
- (context-add-env-lexical! new-context rest))))
- (body* (prepare-progn body new-context))
- (unbound (gensym)))
- (macrolet ((handle-arguments (args env)
- ;; All this ELT and LENGTH stuff is not as
- ;; inefficient as it looks. SBCL transforms
- ;; &rest into &more here.
- `(let* ((restnum 0)
- (rest
- (when (or restp keyp)
- (loop for i
- from (+ required-num optional-num)
- below (length ,args)
- collect (elt ,args i)
- do (incf restnum))))
- (my-default-values* default-values*)
- (my-keywords keywords))
- (declare (fixnum restnum))
- (prog ((argi 0)
- (vari 0))
- (declare (type fixnum argi vari))
- positional
- (when (>= argi (length ,args))
- (go missing-optionals))
- (when (>= argi (the fixnum (+ required-num optional-num)))
- (go keys))
- (setf (environment-value ,env 0 vari) (elt ,args argi))
- (when (>= argi required-num)
- (pop my-default-values*)
+ (destructuring-bind (lambda-list &rest exprs) lambda-form
+ (with-parsed-body (body specials) exprs
+ ;; FIXME: SPECIAL declarations!
+ (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
+ morep more-context more-count)
+ (sb-int:parse-lambda-list lambda-list)
+ (declare (ignore more-context more-count))
+ (declare (ignorable auxp))
+ (when morep
+ (error "The interpreter does not support the lambda-list keyword ~D"
+ 'sb-int:&more))
+ (let* ((argvars (append required
+ (mapcan #'lambda-binding-vars optional)
+ (mapcan #'lambda-binding-vars keys)
+ (mapcan #'lambda-simple-binding-vars aux)
+ (and restp (list rest))))
+ (keywords (mapcar #'lambda-key keys))
+ (required-num (length required))
+ (optional-num (length optional))
+ (key-num (length keys))
+ (aux-num (length aux))
+ (varnum (length argvars))
+ (envp (or (> varnum +stack-max+)
+ (maybe-closes-over-p `(progn ,@body) argvars)))
+ (default-values (append (mapcar #'lambda-binding-default optional)
+ (mapcar #'lambda-binding-default keys)
+ (mapcar #'lambda-binding-default aux)))
+ (new-context (context-add-env-lexicals context required))
+ (default-values*
+ (loop for default-value in default-values
+ for binding in (append optional keys aux)
+ for vars = (lambda-binding-vars binding)
+ collect (prepare-form default-value new-context)
+ do (dolist (var vars)
+ (context-add-env-lexical! new-context var))
+ finally (when restp
+ (context-add-env-lexical! new-context rest))))
+ (body* (prepare-progn body new-context))
+ (unbound (gensym)))
+ (macrolet ((handle-arguments (args env)
+ ;; All this ELT and LENGTH stuff is not as
+ ;; inefficient as it looks. SBCL transforms
+ ;; &rest into &more here.
+ `(let* ((restnum 0)
+ (rest
+ (when (or restp keyp)
+ (loop for i
+ from (+ required-num optional-num)
+ below (length ,args)
+ collect (elt ,args i)
+ do (incf restnum))))
+ (my-default-values* default-values*)
+ (my-keywords keywords))
+ (declare (fixnum restnum))
+ (prog ((argi 0)
+ (vari 0))
+ (declare (type fixnum argi vari))
+ positional
+ (when (>= argi (length ,args))
+ (go missing-optionals))
+ (when (>= argi (the fixnum (+ required-num optional-num)))
+ (go keys))
+ (setf (environment-value ,env 0 vari) (elt ,args argi))
+ (when (>= argi required-num)
+ (pop my-default-values*)
+ (incf vari)
+ (setf (environment-value ,env 0 vari) t))
(incf vari)
- (setf (environment-value ,env 0 vari) t))
- (incf vari)
- (incf argi)
- (go positional)
- missing-optionals
- (unless (>= argi required-num)
- (error 'sb-int:simple-program-error
- :format-arguments "invalid number of arguments: ~D" (length args)))
- (when (>= vari (the fixnum (+ required-num (the fixnum (* 2 optional-num)))))
- (go keys))
- (let ((val* (pop my-default-values*)))
- (setf (environment-value ,env 0 vari)
- (funcall (the eval-closure val*) ,env)
- (environment-value ,env 0 (1+ vari))
- nil))
- (incf vari 2)
- (go missing-optionals)
- keys
- (unless keyp
- (unless (or restp (= argi (length args)))
+ (incf argi)
+ (go positional)
+ missing-optionals
+ (unless (>= argi required-num)
(error 'sb-int:simple-program-error
:format-arguments "invalid number of arguments: ~D" (length args)))
- (go aux))
- (unless (evenp restnum)
- (error 'sb-int:simple-program-error
- :format-arguments "odd number of keyword arguments: ~D" rest))
- (when (>= vari
- (the fixnum
- (+ required-num (* 2 (+ optional-num key-num)))))
- ;; fixme: check &allow-other-keys and :allow-other-keys
- (unless (or allowp
- (getf rest :allow-other-keys nil))
- (loop for (k v) on rest by #'cddr
- unless (member k
- (cons :allow-other-keys keywords)
- :test #'eq)
- do (error 'sb-int:simple-program-error
- :format-control "unknown &KEY argument: ~A"
- :format-arguments (list k))))
- (go aux))
- (let* ((key (the keyword (pop my-keywords)))
- (val* (pop my-default-values*))
- (x (getf rest key unbound)))
- (if (eq unbound x)
- (setf (environment-value ,env 0 vari)
- (funcall (the eval-closure val*) ,env)
- (environment-value ,env 0 (1+ vari))
- nil)
- (setf (environment-value ,env 0 vari)
- x
- (environment-value ,env 0 (1+ vari))
- t)))
- (incf vari 2)
- (go keys)
- aux
- (when (>= vari
- (the fixnum
- (+ required-num
- (the fixnum (* 2 (+ optional-num key-num)))
- aux-num)))
- (go rest))
- (let ((val* (pop my-default-values*)))
- (setf (environment-value ,env 0 vari)
- (funcall (the eval-closure val*) ,env)))
- (incf vari)
- (go aux)
- rest
- (assert (null my-default-values*))
- (when restp
- (setf (environment-value ,env 0 (1- varnum))
- rest))))))
- (if envp
- (lambda (env)
- (lambda (&rest args)
- (declare (dynamic-extent args))
- (let ((new-env (make-environment env varnum)))
- (handle-arguments args new-env)
- (funcall body* new-env))))
- (lambda (env)
- (lambda (&rest args)
- (declare (dynamic-extent args))
- (with-dynamic-extent-environment (new-env env varnum)
- (handle-arguments args new-env)
- (funcall body* new-env))))))))))
+ (when (>= vari (the fixnum (+ required-num (the fixnum (* 2 optional-num)))))
+ (go keys))
+ (let ((val* (pop my-default-values*)))
+ (setf (environment-value ,env 0 vari)
+ (funcall (the eval-closure val*) ,env)
+ (environment-value ,env 0 (1+ vari))
+ nil))
+ (incf vari 2)
+ (go missing-optionals)
+ keys
+ (unless keyp
+ (unless (or restp (= argi (length args)))
+ (error 'sb-int:simple-program-error
+ :format-arguments "invalid number of arguments: ~D" (length args)))
+ (go aux))
+ (unless (evenp restnum)
+ (error 'sb-int:simple-program-error
+ :format-arguments "odd number of keyword arguments: ~D" rest))
+ (when (>= vari
+ (the fixnum
+ (+ required-num (* 2 (+ optional-num key-num)))))
+ ;; fixme: check &allow-other-keys and :allow-other-keys
+ (unless (or allowp
+ (getf rest :allow-other-keys nil))
+ (loop for (k v) on rest by #'cddr
+ unless (member k
+ (cons :allow-other-keys keywords)
+ :test #'eq)
+ do (error 'sb-int:simple-program-error
+ :format-control "unknown &KEY argument: ~A"
+ :format-arguments (list k))))
+ (go aux))
+ (let* ((key (the keyword (pop my-keywords)))
+ (val* (pop my-default-values*))
+ (x (getf rest key unbound)))
+ (if (eq unbound x)
+ (setf (environment-value ,env 0 vari)
+ (funcall (the eval-closure val*) ,env)
+ (environment-value ,env 0 (1+ vari))
+ nil)
+ (setf (environment-value ,env 0 vari)
+ x
+ (environment-value ,env 0 (1+ vari))
+ t)))
+ (incf vari 2)
+ (go keys)
+ aux
+ (when (>= vari
+ (the fixnum
+ (+ required-num
+ (the fixnum (* 2 (+ optional-num key-num)))
+ aux-num)))
+ (go rest))
+ (let ((val* (pop my-default-values*)))
+ (setf (environment-value ,env 0 vari)
+ (funcall (the eval-closure val*) ,env)))
+ (incf vari)
+ (go aux)
+ rest
+ (assert (null my-default-values*))
+ (when restp
+ (setf (environment-value ,env 0 (1- varnum))
+ rest))))))
+ (if envp
+ (lambda (env)
+ (lambda (&rest args)
+ (declare (dynamic-extent args))
+ (let ((new-env (make-environment env varnum)))
+ (handle-arguments args new-env)
+ (funcall body* new-env))))
+ (lambda (env)
+ (lambda (&rest args)
+ (declare (dynamic-extent args))
+ (with-dynamic-extent-environment (new-env env varnum)
+ (handle-arguments args new-env)
+ (funcall body* new-env)))))))))))
(defun context->native-environment (context)
;;FIXME
@@ -541,6 +542,25 @@
(declare (ignore lexenv))
(make-null-context))
+(defun body-decls&forms (exprs)
+ (let* ((decl-exprs
+ (loop while (and (consp (first exprs))
+ (eq 'declare (first (first exprs))))
+ for expr = (pop exprs)
+ collect expr))
+ (decls (mapcan #'rest decl-exprs)))
+ (values decls exprs)))
+
+(defun decl-specials (declaration)
+ (when (eq (first declaration) 'special)
+ (rest declaration)))
+
+(defmacro with-parsed-body ((forms-var specials-var) exprs &body body)
+ (let ((decls (gensym)))
+ `(multiple-value-bind (,decls ,forms-var) (body-decls&forms ,exprs)
+ (let ((,specials-var (mapcan #'decl-specials ,decls)))
+ ,@body))))
+
(defun globally-special-p (var)
(eq :special (sb-int:info :variable :kind var)))
@@ -632,154 +652,159 @@
(prepare-progn body context)
(prepare-nil))))
((flet)
- (destructuring-bind (bindings &rest body) (rest form)
- (let* ((bindings* (mapcar (lambda (form)
- (if (listp form)
- (cons (first form)
- (prepare-lambda (rest form) context))
- (cons form (prepare-nil))))
- bindings))
- (new-context (context-add-env-functions context (mapcar #'first bindings*)))
- (functions (mapcar #'cdr bindings*))
- (n (length functions))
- (body* (prepare-progn body new-context)))
- (lambda (env)
- (let ((new-env (make-environment env n)))
- (loop for i from 0 to n
- for f in functions
- do (setf (environment-value new-env 0 i)
- (funcall (the eval-closure f) env)))
- (funcall body* new-env))))))
+ (destructuring-bind (bindings &rest exprs) (rest form)
+ (with-parsed-body (body specials) exprs
+ (let* ((bindings* (mapcar (lambda (form)
+ (if (listp form)
+ (cons (first form)
+ (prepare-lambda (rest form) context))
+ (cons form (prepare-nil))))
+ bindings))
+ (new-context (context-add-env-functions context (mapcar #'first bindings*)))
+ (functions (mapcar #'cdr bindings*))
+ (n (length functions))
+ (body* (prepare-progn body new-context)))
+ (lambda (env)
+ (let ((new-env (make-environment env n)))
+ (loop for i from 0 to n
+ for f in functions
+ do (setf (environment-value new-env 0 i)
+ (funcall (the eval-closure f) env)))
+ (funcall body* new-env)))))))
((labels)
- (destructuring-bind (bindings &rest body) (rest form)
- (let* ((new-context (context-add-env-functions context (mapcar #'first bindings)))
- (bindings* (mapcar (lambda (form)
- (if (listp form)
- (cons (first form)
- (prepare-lambda (rest form) new-context))
- (cons form (prepare-nil))))
- bindings))
- (functions (mapcar #'cdr bindings*))
- (n (length functions))
- (body* (prepare-progn body new-context)))
- (lambda (env)
- (let ((new-env (make-environment env n)))
- (loop for i from 0 to n
- for f in functions
- do (setf (environment-value new-env 0 i)
- (funcall (the eval-closure f) new-env)))
- (funcall body* new-env))))))
+ (destructuring-bind (bindings &rest exprs) (rest form)
+ (with-parsed-body (body specials) exprs
+ (let* ((new-context (context-add-env-functions context (mapcar #'first bindings)))
+ (bindings* (mapcar (lambda (form)
+ (if (listp form)
+ (cons (first form)
+ (prepare-lambda (rest form) new-context))
+ (cons form (prepare-nil))))
+ bindings))
+ (functions (mapcar #'cdr bindings*))
+ (n (length functions))
+ (body* (prepare-progn body new-context)))
+ (lambda (env)
+ (let ((new-env (make-environment env n)))
+ (loop for i from 0 to n
+ for f in functions
+ do (setf (environment-value new-env 0 i)
+ (funcall (the eval-closure f) new-env)))
+ (funcall body* new-env)))))))
((let)
;; FIXME: SPECIAL declarations!
- (destructuring-bind (bindings &rest body) (rest form)
- (let* ((real-bindings (mapcar (lambda (form)
- (if (listp form)
- (cons (first form) (second form))
- (cons form nil)))
- bindings))
- (vars (mapcar #'car real-bindings))
- (varnum (length vars))
- (envp (or (> varnum +stack-max+)
- (maybe-closes-over-p `(progn ,@body) vars)))
- (new-context
- (context-add-env-lexicals context (list)))
- lexical-values*
- special-bindings*)
- (loop for (var . value-form) in real-bindings
- for val* = (prepare-form value-form context)
- if (globally-special-p var)
+ (destructuring-bind (bindings &rest exprs) (rest form)
+ (with-parsed-body (body specials) exprs
+ (let* ((real-bindings (mapcar (lambda (form)
+ (if (listp form)
+ (cons (first form) (second form))
+ (cons form nil)))
+ bindings))
+ (vars (mapcar #'car real-bindings))
+ (varnum (length vars))
+ (envp (or (> varnum +stack-max+)
+ (maybe-closes-over-p `(progn ,@body) vars)))
+ (new-context
+ (context-add-env-lexicals context (list)))
+ lexical-values*
+ special-bindings*)
+ (loop for (var . value-form) in real-bindings
+ for val* = (prepare-form value-form context)
+ if (globally-special-p var)
collect (cons var val*) into specials
- else
+ else
collect val* into lexicals
and do (context-add-env-lexical! new-context var)
- finally
- (setq lexical-values* lexicals
- special-bindings* specials))
- (let ((body* (prepare-progn body new-context))
- (special-vars (mapcar #'car special-bindings*))
- (special-vals* (mapcar #'cdr special-bindings*)))
- (if envp
- (lambda (env)
- (let ((new-env (make-environment env varnum)))
- (loop for i from 0 below varnum
- for val* in lexical-values*
- do (setf (environment-value new-env 0 i)
- (funcall (the eval-closure val*) env)))
- (progv
- special-vars
- (loop for val* in special-vals*
- collect (funcall (the eval-closure val*) env))
- (funcall body* new-env))))
- (lambda (env)
- (with-dynamic-extent-environment (new-env env varnum)
- (loop for i from 0 below varnum
- for val* in lexical-values*
- do (setf (environment-value new-env 0 i)
- (funcall (the eval-closure val*) env)))
- (progv
- special-vars
- (loop for val* in special-vals*
- collect (funcall (the eval-closure val*) env))
- (funcall body* new-env)))))))))
+ finally
+ (setq lexical-values* lexicals
+ special-bindings* specials))
+ (let ((body* (prepare-progn body new-context))
+ (special-vars (mapcar #'car special-bindings*))
+ (special-vals* (mapcar #'cdr special-bindings*)))
+ (if envp
+ (lambda (env)
+ (let ((new-env (make-environment env varnum)))
+ (loop for i from 0 below varnum
+ for val* in lexical-values*
+ do (setf (environment-value new-env 0 i)
+ (funcall (the eval-closure val*) env)))
+ (progv
+ special-vars
+ (loop for val* in special-vals*
+ collect (funcall (the eval-closure val*) env))
+ (funcall body* new-env))))
+ (lambda (env)
+ (with-dynamic-extent-environment (new-env env varnum)
+ (loop for i from 0 below varnum
+ for val* in lexical-values*
+ do (setf (environment-value new-env 0 i)
+ (funcall (the eval-closure val*) env)))
+ (progv
+ special-vars
+ (loop for val* in special-vals*
+ collect (funcall (the eval-closure val*) env))
+ (funcall body* new-env))))))))))
((let*)
;; FIXME: SPECIAL declarations!
- (destructuring-bind (bindings &rest body) (rest form)
- (let* ((real-bindings (mapcar (lambda (form)
- (if (listp form)
- (cons (first form) (second form))
- (cons form nil)))
- bindings))
- (vars (mapcar #'car real-bindings))
- (varnum (length vars))
- (envp (or (> varnum +stack-max+)
- (maybe-closes-over-p `(progn ,@body) vars)))
- (new-context
- (context-add-env-lexicals context (list)))
- lexical-values*
- special-bindings*)
- (loop for (var . value-form) in real-bindings
- for val* = (prepare-form value-form new-context)
- if (globally-special-p var)
+ (destructuring-bind (bindings &rest exprs) (rest form)
+ (with-parsed-body (body specials) exprs
+ (let* ((real-bindings (mapcar (lambda (form)
+ (if (listp form)
+ (cons (first form) (second form))
+ (cons form nil)))
+ bindings))
+ (vars (mapcar #'car real-bindings))
+ (varnum (length vars))
+ (envp (or (> varnum +stack-max+)
+ (maybe-closes-over-p `(progn ,@body) vars)))
+ (new-context
+ (context-add-env-lexicals context (list)))
+ lexical-values*
+ special-bindings*)
+ (loop for (var . value-form) in real-bindings
+ for val* = (prepare-form value-form new-context)
+ if (globally-special-p var)
collect (cons var val*) into specials
- else
+ else
collect val* into lexicals
and do (context-add-env-lexical! new-context var)
- finally
- (setq lexical-values* lexicals
- special-bindings* specials))
- (let ((body* (prepare-progn body new-context))
- (special-vars (mapcar #'car special-bindings*))
- (special-vals* (mapcar #'cdr special-bindings*)))
- (if envp
- (lambda (env)
- (let ((new-env (make-environment env varnum)))
- (loop for i from 0 below varnum
- for val* in lexical-values*
- do (setf (environment-value new-env 0 i)
- (funcall (the eval-closure val*) new-env)))
- (progv
- special-vars
- (loop for val* in special-vals*
- collect (funcall (the eval-closure val*) new-env))
- (funcall body* new-env))))
- (lambda (env)
- (with-dynamic-extent-environment (new-env env varnum)
- (loop for i from 0 below varnum
- for val* in lexical-values*
- do (setf (environment-value new-env 0 i)
- (funcall (the eval-closure val*) new-env)))
- (progv
- special-vars
- (loop for val* in special-vals*
- collect (funcall (the eval-closure val*) new-env))
- (funcall body* new-env)))))))))
+ finally
+ (setq lexical-values* lexicals
+ special-bindings* specials))
+ (let ((body* (prepare-progn body new-context))
+ (special-vars (mapcar #'car special-bindings*))
+ (special-vals* (mapcar #'cdr special-bindings*)))
+ (if envp
+ (lambda (env)
+ (let ((new-env (make-environment env varnum)))
+ (loop for i from 0 below varnum
+ for val* in lexical-values*
+ do (setf (environment-value new-env 0 i)
+ (funcall (the eval-closure val*) new-env)))
+ (progv
+ special-vars
+ (loop for val* in special-vals*
+ collect (funcall (the eval-closure val*) new-env))
+ (funcall body* new-env))))
+ (lambda (env)
+ (with-dynamic-extent-environment (new-env env varnum)
+ (loop for i from 0 below varnum
+ for val* in lexical-values*
+ do (setf (environment-value new-env 0 i)
+ (funcall (the eval-closure val*) new-env)))
+ (progv
+ special-vars
+ (loop for val* in special-vals*
+ collect (funcall (the eval-closure val*) new-env))
+ (funcall body* new-env))))))))))
((load-time-value)
(let ((load-form (cadr form)))
;; FIXME
(prepare-form load-form)))
((locally)
- (destructuring-bind (&rest body) (rest form)
- (prepare-progn body context)))
+ (destructuring-bind (&rest exprs) (rest form)
+ (with-parsed-body (body specials) exprs
+ (prepare-progn body context))))
((multiple-value-call)
(destructuring-bind (f &rest argforms) (rest form)
(let ((f* (prepare-form f context))
@@ -819,17 +844,18 @@
primary-value)))))
((multiple-value-bind)
;; FIXME: SPECIAL declarations!
- (destructuring-bind (vars value-form &body body) (rest form)
- (let* ((value-form* (prepare-form value-form context))
- (n (length (the list vars)))
- (new-context (context-add-env-lexicals context vars))
- (body* (prepare-progn body new-context)))
- (lambda (env)
- (let* ((new-env (make-environment env n))
- (values (multiple-value-list (funcall value-form* env))))
- (dotimes (i n)
- (setf (environment-value new-env 0 i) (pop values)))
- (funcall body* new-env))))))
+ (destructuring-bind (vars value-form &body exprs) (rest form)
+ (with-parsed-body (body specials) exprs
+ (let* ((value-form* (prepare-form value-form context))
+ (n (length (the list vars)))
+ (new-context (context-add-env-lexicals context vars))
+ (body* (prepare-progn body new-context)))
+ (lambda (env)
+ (let* ((new-env (make-environment env n))
+ (values (multiple-value-list (funcall value-form* env))))
+ (dotimes (i n)
+ (setf (environment-value new-env 0 i) (pop values)))
+ (funcall body* new-env)))))))
((progn)
(prepare-progn (rest form) context))
((progv)
@@ -871,24 +897,26 @@
((sb-int:named-lambda)
(prepare-lambda (cddr form) context))
((symbol-macrolet)
- (destructuring-bind (bindings &rest body) (rest form)
- (let ((bindings (mapcar (lambda (form)
- (cons (first form) (second form)))
- bindings)))
- (prepare-progn body (context-add-symbol-macros context bindings)))))
+ (destructuring-bind (bindings &rest exprs) (rest form)
+ (with-parsed-body (body specials) exprs
+ (let ((bindings (mapcar (lambda (form)
+ (cons (first form) (second form)))
+ bindings)))
+ (prepare-progn body (context-add-symbol-macros context bindings))))))
((macrolet)
;; FIXME: This doesn't actually work because we disregard
;; the lambda list when calling the macro.
- (destructuring-bind (bindings &rest body) (rest form)
- (let ((bindings (mapcar (lambda (form)
- (cons (first form)
- (funcall
- (prepare-macro-lambda (first form)
- (rest form)
- context)
- (make-null-environment))))
- bindings)))
- (prepare-progn body (context-add-macros context bindings)))))
+ (destructuring-bind (bindings &rest exprs) (rest form)
+ (with-parsed-body (body specials) exprs
+ (let ((bindings (mapcar (lambda (form)
+ (cons (first form)
+ (funcall
+ (prepare-macro-lambda (first form)
+ (rest form)
+ context)
+ (make-null-environment))))
+ bindings)))
+ (prepare-progn body (context-add-macros context bindings))))))
((go)
(let* ((go-tag (second form))
(catch-tag (context-find-go-tag context go-tag)))