From a6878d103a9cf83c721167ec9f2931e834e0a4e4 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Sun, 4 May 2003 13:39:19 +0000 Subject: [PATCH] &ENVIRONMENT variable is bound at the start, regardless of where it appears in the lambda list. Found by Paul Dietz. * src/code/defmacro.lisp (append-let-binding): New function. (parse-defmacro-lambda-list): Use it for &environment. --- code/defmacro.lisp | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/code/defmacro.lisp b/code/defmacro.lisp index 6dac5ce38..5d8c37083 100644 --- a/code/defmacro.lisp +++ b/code/defmacro.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defmacro.lisp,v 1.26 2003/05/03 21:15:38 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defmacro.lisp,v 1.27 2003/05/04 13:39:19 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -144,7 +144,7 @@ "&environment only valid at top level of lambda-list."))) (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) (setf rest-of-args (cdr rest-of-args)) - (push-let-binding (car rest-of-args) env-arg-name nil) + (append-let-binding (car rest-of-args) env-arg-name nil) (setf env-arg-used t)) (t (defmacro-error "&ENVIRONMENT" error-kind name)))) @@ -341,7 +341,7 @@ *system-lets*))) (defun push-let-binding (variable path systemp &optional condition - (init-form *default-default*)) + (init-form *default-default*)) (let ((let-form (if condition `(,variable (if ,condition ,path ,init-form)) `(,variable ,path)))) @@ -349,6 +349,15 @@ (push let-form *system-lets*) (push let-form *user-lets*)))) +(defun append-let-binding (variable path systemp &optional condition + (init-form *default-default*)) + (let ((let-form (if condition + `(,variable (if ,condition ,path ,init-form)) + `(,variable ,path)))) + (if systemp + (setq *system-lets* (nconc *system-lets* (list let-form))) + (setq *user-lets* (nconc *user-lets* (list let-form)))))) + (defun push-optional-binding (value-var init-form supplied-var condition path name error-kind error-fun) (unless supplied-var -- GitLab