From 1ca1159c8a7ae32a4c3184e42bac97bb58efa889 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Sat, 19 Apr 2003 20:52:43 +0000 Subject: [PATCH] Add destructuring support to &REST, &BODY, &WHOLE. Detected by Paul Dietz' ANSI tests. * src/code/defmacro.lisp (parse-defmacro-lambda-list): Add &parse-body, replacing &body (<body> <decls> <doc>). Add destructuring support to &rest, &body, &whole. * src/code/eval.lisp (lambda-list-keywords): Add &parse-body. * src/code/exports.lisp ("EXTENSIONS"): Export &parse-body. * src/hemlock/table.lisp (do-words, with-folded-string): * src/hemlock/macros.lisp (with-pop-up-display): * src/compiler/macros.lisp (deftransform): * src/compiler/ir1tran.lisp (symbol-macrolet, let, locally) (let*, flet, labels) <ir1-translator>: * src/code/package.lisp (do-symbols, do-external-symbols) (do-all-symbols): * src/code/macros.lisp (defun, prog, prog*, with-open-file) (with-open-stream, with-input-from-string) (with-output-to-string, do, do*): * src/code/mach.lisp (gr-bind): * src/code/extensions.lisp (do-anonymous, do-hash, defun-cached): Use &parse-body instead of &body. --- code/defmacro.lisp | 87 +++++++++++++++++++++++++++---------------- code/eval.lisp | 5 ++- code/exports.lisp | 6 ++- code/extensions.lisp | 8 ++-- code/mach.lisp | 4 +- code/macros.lisp | 22 ++++++----- code/package.lisp | 8 ++-- compiler/ir1tran.lisp | 15 ++++---- compiler/macros.lisp | 4 +- hemlock/macros.lisp | 4 +- hemlock/table.lisp | 6 +-- 11 files changed, 98 insertions(+), 71 deletions(-) diff --git a/code/defmacro.lisp b/code/defmacro.lisp index b974be5dc..be6c9ed47 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.24 2003/02/24 10:04:10 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defmacro.lisp,v 1.25 2003/04/19 20:52:43 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -123,6 +123,15 @@ `(progn (setf ,arg-list-name (cdr ,arg-list-name))))) (push-let-binding (car rest-of-args) arg-list-name nil)) + ((and (cdr rest-of-args) (consp (cadr rest-of-args))) + (pop rest-of-args) + (let* ((destructuring-lambda-list (car rest-of-args)) + (sub (gensym "WHOLE-SUBLIST"))) + (push-sub-list-binding + sub arg-list-name destructuring-lambda-list + name error-kind error-fun) + (parse-defmacro-lambda-list + destructuring-lambda-list sub name error-kind error-fun))) (t (defmacro-error "&WHOLE" error-kind name)))) ((eq var '&environment) @@ -138,7 +147,41 @@ (setf env-arg-used t)) (t (defmacro-error "&ENVIRONMENT" error-kind name)))) - ((or (eq var '&rest) (eq var '&body)) + ;; + ;; This branch implements an extension to Common Lisp + ;; that was formerly implemented for &body. In place of + ;; a symbol following &body, there could be a list of up + ;; to three elements which will be bound to the body, + ;; declarations, and doc-string of the body. + ((eq var '&parse-body) + (unless (and (cdr rest-of-args) + (consp (cadr rest-of-args)) + (symbolp (caadr rest-of-args))) + (simple-program-error "Invalid ~a" '&parse-body)) + (setf rest-of-args (cdr rest-of-args)) + (setf restp t) + (let ((body-name (caar rest-of-args)) + (declarations-name (cadar rest-of-args)) + (doc-string-name (caddar rest-of-args)) + (parse-body-values (gensym))) + (push-let-binding + parse-body-values + `(multiple-value-list + (parse-body ,path ,env-arg-name + ,(not (null doc-string-name)))) + t) + (setf env-arg-used t) + (when body-name + (push-let-binding body-name + `(car ,parse-body-values) nil)) + (when declarations-name + (push-let-binding declarations-name + `(cadr ,parse-body-values) nil)) + (when doc-string-name + (push-let-binding doc-string-name + `(caddr ,parse-body-values) nil)))) + ;; + ((member var '(&rest &body)) (cond ((and (cddr rest-of-args) (not (member (caddr rest-of-args) lambda-list-keywords))) (defmacro-error (symbol-name var) error-kind name)) @@ -146,37 +189,15 @@ (setf rest-of-args (cdr rest-of-args)) (setf restp t) (push-let-binding (car rest-of-args) path nil)) - ;; - ;; This branch implements an incompatible extension to - ;; Common Lisp. In place of a symbol following &body, - ;; there may be a list of up to three elements which will - ;; be bound to the body, declarations, and doc-string of - ;; the body. - ((and (cdr rest-of-args) - (consp (cadr rest-of-args)) - (symbolp (caadr rest-of-args))) - (setf rest-of-args (cdr rest-of-args)) - (setf restp t) - (let ((body-name (caar rest-of-args)) - (declarations-name (cadar rest-of-args)) - (doc-string-name (caddar rest-of-args)) - (parse-body-values (gensym))) - (push-let-binding - parse-body-values - `(multiple-value-list - (parse-body ,path ,env-arg-name - ,(not (null doc-string-name)))) - t) - (setf env-arg-used t) - (when body-name - (push-let-binding body-name - `(car ,parse-body-values) nil)) - (when declarations-name - (push-let-binding declarations-name - `(cadr ,parse-body-values) nil)) - (when doc-string-name - (push-let-binding doc-string-name - `(caddr ,parse-body-values) nil)))) + ((and (cdr rest-of-args) (consp (cadr rest-of-args))) + (pop rest-of-args) + (setq restp t) + (let* ((destructuring-lambda-list (car rest-of-args)) + (sub (gensym "REST-SUBLIST"))) + (push-sub-list-binding sub path destructuring-lambda-list + name error-kind error-fun) + (parse-defmacro-lambda-list + destructuring-lambda-list sub name error-kind error-fun))) (t (defmacro-error (symbol-name var) error-kind name)))) ((eq var '&optional) diff --git a/code/eval.lisp b/code/eval.lisp index 9815d47c4..a3398d41f 100644 --- a/code/eval.lisp +++ b/code/eval.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/eval.lisp,v 1.37 2003/03/22 01:25:43 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/eval.lisp,v 1.38 2003/04/19 20:52:43 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -60,7 +60,8 @@ (defconstant lambda-list-keywords - '(&optional &rest &key &aux &body &whole &allow-other-keys &environment) + '(&optional &rest &key &aux &body &whole &allow-other-keys &environment + &parse-body) "Keywords that you can put in a lambda-list, supposing you should want to do such a thing.") diff --git a/code/exports.lisp b/code/exports.lisp index 19f03c26f..e5253d80a 100644 --- a/code/exports.lisp +++ b/code/exports.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/exports.lisp,v 1.205 2003/04/13 11:57:17 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.206 2003/04/19 20:52:43 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1064,7 +1064,9 @@ "STREAM-READ-CHAR" "STREAM-READ-CHAR-NO-HANG" "STREAM-READ-LINE" "STREAM-START-LINE-P" "STREAM-TERPRI" "STREAM-UNREAD-CHAR" "STREAM-WRITE-BYTE" "STREAM-WRITE-CHAR" "STREAM-WRITE-STRING" - "STREAM-READ-SEQUENCE" "STREAM-WRITE-SEQUENCE")) + "STREAM-READ-SEQUENCE" "STREAM-WRITE-SEQUENCE" + + "&PARSE-BODY")) (defpackage "LOOP") (dolist diff --git a/code/extensions.lisp b/code/extensions.lisp index 5dfb5798a..70b0c0871 100644 --- a/code/extensions.lisp +++ b/code/extensions.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/extensions.lisp,v 1.26 2002/09/19 17:48:17 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/extensions.lisp,v 1.27 2003/04/19 20:52:43 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -364,7 +364,7 @@ (return-from ,BLOCK (progn ,@(cdr endlist)))))))) -(defmacro do-anonymous (varlist endlist &body (body decls)) +(defmacro do-anonymous (varlist endlist &parse-body (body decls)) "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* Like DO, but has no implicit NIL block. Each Var is initialized in parallel to the value of the specified Init form. On subsequent iterations, the Vars @@ -376,7 +376,7 @@ 'do-anonymous (gensym))) (defmacro do-hash ((key-var value-var table &optional result) - &body (body decls)) + &parse-body (body decls)) "DO-HASH (Key-Var Value-Var Table [Result]) Declaration* Form* Iterate over the entries in a hash-table." (let ((gen (gensym)) @@ -572,7 +572,7 @@ ;;; (defmacro defun-cached ((name &rest options &key (values 1) default &allow-other-keys) - args &body (body decls doc)) + args &parse-body (body decls doc)) "DEFUN-CACHED (Name {Key Value}*) ({(Arg-Name Test-Function)}*) Form* Some syntactic sugar for defining a function whose values are cached by DEFINE-HASH-CACHE." diff --git a/code/mach.lisp b/code/mach.lisp index cbdc271d9..21c03e0d2 100644 --- a/code/mach.lisp +++ b/code/mach.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/mach.lisp,v 1.4 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/mach.lisp,v 1.5 2003/04/19 20:52:43 gerd Rel $") ;;; ;;; ********************************************************************** ;;; @@ -91,7 +91,7 @@ ;;; GR-Bind -- Public ;;; -(defmacro gr-bind (vars (fun . args) &body (body decls)) +(defmacro gr-bind (vars (fun . args) &parse-body (body decls)) "GR-Bind ({Var}*) (Function {Arg}*) {Form}* Call the function with the specified Args and signal an error if the first value returned is not mach:Kern-Success. If the call succeeds, diff --git a/code/macros.lisp b/code/macros.lisp index 006165bba..343f15b53 100644 --- a/code/macros.lisp +++ b/code/macros.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/macros.lisp,v 1.91 2003/03/22 16:15:21 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.92 2003/04/19 20:52:43 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -300,7 +300,7 @@ ;;; Very similar to Defmacro, but simpler. We don't have to parse the ;;; lambda-list. ;;; -(defmacro defun (&whole source name lambda-list &body (body decls doc)) +(defmacro defun (&whole source name lambda-list &parse-body (body decls doc)) (multiple-value-bind (valid block-name) (valid-function-name-p name) (declare (ignore valid)) @@ -416,13 +416,13 @@ (defmacro return (&optional (value nil)) `(return-from nil ,value)) -(defmacro prog (varlist &body (body decls)) +(defmacro prog (varlist &parse-body (body decls)) `(block nil (let ,varlist ,@decls (tagbody ,@body)))) -(defmacro prog* (varlist &body (body decls)) +(defmacro prog* (varlist &parse-body (body decls)) `(block nil (let* ,varlist ,@decls @@ -1469,7 +1469,7 @@ ;;;; With-XXX -(defmacro with-open-file ((var &rest open-args) &body (forms decls)) +(defmacro with-open-file ((var &rest open-args) &parse-body (forms decls)) "Bindspec is of the form (Stream File-Name . Options). The file whose name is File-Name is opened using the Options and bound to the variable Stream. If the call to open is unsuccessful, the forms are not @@ -1487,7 +1487,7 @@ (close ,var :abort ,abortp)))))) -(defmacro with-open-stream ((var stream) &body (forms decls)) +(defmacro with-open-stream ((var stream) &parse-body (forms decls)) "The form stream should evaluate to a stream. VAR is bound to the stream and the forms are evaluated as an implicit progn. The stream is closed upon exit." @@ -1503,7 +1503,8 @@ (close ,var :abort ,abortp)))))) -(defmacro with-input-from-string ((var string &key index start end) &body (forms decls)) +(defmacro with-input-from-string ((var string &key index start end) + &parse-body (forms decls)) "Binds the Var to an input stream that returns characters from String and executes the body. See manual for details." ;; The once-only inhibits compiler note for unreachable code when 'end' is true. @@ -1524,7 +1525,8 @@ ,@(if index `((setf ,index (string-input-stream-current ,var)))))))) -(defmacro with-output-to-string ((var &optional string) &body (forms decls)) +(defmacro with-output-to-string ((var &optional string) + &parse-body (forms decls)) "If STRING is specified, it must be a string with a fill pointer; the output is incrementally appended to the string (as if by use of VECTOR-PUSH-EXTEND)." @@ -1582,7 +1584,7 @@ ,@forms)))))) -(defmacro do (varlist endlist &body (body decls)) +(defmacro do (varlist endlist &parse-body (body decls)) "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* Iteration construct. Each Var is initialized in parallel to the value of the specified Init form. On subsequent iterations, the Vars are assigned the @@ -1595,7 +1597,7 @@ (do-do-body varlist endlist body decls 'let 'psetq 'do nil)) -(defmacro do* (varlist endlist &body (body decls)) +(defmacro do* (varlist endlist &parse-body (body decls)) "DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* Iteration construct. Each Var is initialized sequentially (like LET*) to the value of the specified Init form. On subsequent iterations, the Vars are diff --git a/code/package.lisp b/code/package.lisp index a98e5278e..9f26de0bc 100644 --- a/code/package.lisp +++ b/code/package.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/package.lisp,v 1.62 2003/03/22 16:15:20 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.63 2003/04/19 20:52:42 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -547,7 +547,7 @@ ;;;; Iteration macros. (defmacro do-symbols ((var &optional (package '*package*) result-form) - &body (body decls)) + &parse-body (body decls)) "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}* Executes the FORMs at least once for each symbol accessible in the given PACKAGE with VAR bound to the current symbol." @@ -581,7 +581,7 @@ ,result-form)))) (defmacro do-external-symbols ((var &optional (package '*package*) result-form) - &body (body decls)) + &parse-body (body decls)) "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}* Executes the FORMs once for each external symbol in the given PACKAGE with VAR bound to the current symbol." @@ -605,7 +605,7 @@ ,@decls ,result-form)))) -(defmacro do-all-symbols ((var &optional result-form) &body (body decls)) +(defmacro do-all-symbols ((var &optional result-form) &parse-body (body decls)) "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}* Executes the FORMs once for each symbol in every package with VAR bound to the current symbol." diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index c46064beb..f985397e9 100644 --- a/compiler/ir1tran.lisp +++ b/compiler/ir1tran.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/compiler/ir1tran.lisp,v 1.145 2003/04/16 13:31:18 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.146 2003/04/19 20:52:42 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -2538,7 +2538,8 @@ ;;;; Symbol macros: -(def-ir1-translator symbol-macrolet ((specs &body (body decls)) start cont) +(def-ir1-translator symbol-macrolet ((specs &parse-body (body decls)) + start cont) "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form* Define the Names as symbol macros with the given Expansions. Within the body, references to a Name will effectively be replaced with the Expansion." @@ -2828,7 +2829,7 @@ (values (vars) (vals) (names)))) -(def-ir1-translator let ((bindings &body (body decls)) +(def-ir1-translator let ((bindings &parse-body (body decls)) start cont) "LET ({(Var [Value]) | Var}*) Declaration* Form* During evaluation of the Forms, Bind the Vars to the result of evaluating the @@ -2842,7 +2843,7 @@ (reference-leaf start fun-cont fun) (ir1-convert-combination-args fun-cont cont values)))) -(def-ir1-translator locally ((&body (body decls)) +(def-ir1-translator locally ((&parse-body (body decls)) start cont) "LOCALLY Declaration* Form* Sequentially evaluates a body of Form's in a lexical environment @@ -2852,7 +2853,7 @@ -(def-ir1-translator let* ((bindings &body (body decls)) +(def-ir1-translator let* ((bindings &parse-body (body decls)) start cont) "LET* ({(Var [Value]) | Var}*) Declaration* Form* Similar to LET, but the variables are bound sequentially, allowing each Value @@ -2905,7 +2906,7 @@ (values (names) (defs))))) -(def-ir1-translator flet ((definitions &body (body decls)) +(def-ir1-translator flet ((definitions &parse-body (body decls)) start cont) "FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form* Evaluate the Body-Forms with some local function definitions. The bindings @@ -2928,7 +2929,7 @@ ;;; leaves. We also backpatch the FENV so that if the lexical environment is ;;; used for inline expansion we will get the right functions. ;;; -(def-ir1-translator labels ((definitions &body (body decls)) start cont) +(def-ir1-translator labels ((definitions &parse-body (body decls)) start cont) "LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form* Evaluate the Body-Forms with some local function definitions. The bindings enclose the new definitions, so the defined functions can call themselves or diff --git a/compiler/macros.lisp b/compiler/macros.lisp index 754864309..d23e84afe 100644 --- a/compiler/macros.lisp +++ b/compiler/macros.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/compiler/macros.lisp,v 1.50 2003/04/11 15:28:11 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/macros.lisp,v 1.51 2003/04/19 20:52:42 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -341,7 +341,7 @@ (result-type '*) &key result policy node defun-only eval-name important (when :native)) - &body (body decls doc)) + &parse-body (body decls doc)) "Deftransform Name (Lambda-List [Arg-Types] [Result-Type] {Key Value}*) Declaration* [Doc-String] Form* Define an IR1 transformation for Name. An IR1 transformation computes a diff --git a/hemlock/macros.lisp b/hemlock/macros.lisp index 7d685ab09..3047b2f37 100644 --- a/hemlock/macros.lisp +++ b/hemlock/macros.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/hemlock/macros.lisp,v 1.8 2001/03/13 15:49:56 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/macros.lisp,v 1.9 2003/04/19 20:52:42 gerd Rel $") ;;; ;;; ********************************************************************** ;;; @@ -521,7 +521,7 @@ (defmacro with-pop-up-display ((var &key height (buffer-name "Random Typeout")) - &body (body decls)) + &parse-body (body decls)) "Execute body in a context with var bound to a stream. Output to the stream appears in the buffer named buffer-name. The pop-up display appears after the body completes, but if you supply :height, the output is line buffered, diff --git a/hemlock/table.lisp b/hemlock/table.lisp index bea8f6edd..214a15af5 100644 --- a/hemlock/table.lisp +++ b/hemlock/table.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/hemlock/table.lisp,v 1.4 2001/03/13 15:50:00 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/table.lisp,v 1.5 2003/04/19 20:52:42 gerd Rel $") ;;; ;;; ********************************************************************** ;;; @@ -243,7 +243,7 @@ (eval-when (compile eval) -(defmacro do-words ((start-var end-var) &body (body decls)) +(defmacro do-words ((start-var end-var) &parse-body (body decls)) (let ((sep-pos (gensym))) `(dolist (,sep-pos *separator-positions*) (let ((,start-var (car ,sep-pos)) @@ -252,7 +252,7 @@ ,@body)))) (defmacro with-folded-string ((str-var len-var orig-str separator) - &body (body decls)) + &parse-body (body decls)) `(let ((,str-var *string-buffer*)) (declare (simple-string ,str-var)) ;; make the string simple if it isn't already -- GitLab