From 5fbe205f76922b8914aaecaa4b7f3f2eb044e092 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Sun, 20 Apr 2003 18:26:56 +0000
Subject: [PATCH] *** empty log message ***

---
 bootfiles/18e/boot5.lisp | 243 +++++++++++++++++++++++++++++++++++++++
 1 file changed, 243 insertions(+)
 create mode 100644 bootfiles/18e/boot5.lisp

diff --git a/bootfiles/18e/boot5.lisp b/bootfiles/18e/boot5.lisp
new file mode 100644
index 000000000..1a41345e9
--- /dev/null
+++ b/bootfiles/18e/boot5.lisp
@@ -0,0 +1,243 @@
+;;;
+;;; Bootfile for changes in macro lambda-list processing.
+;;; Destructuring in &REST, &BODY, and &WHOLE.  Addition
+;;; of EXT:&PARSE-BODY.
+;;;
+
+(in-package :kernel)
+
+(defun parse-defmacro-lambda-list
+       (lambda-list arg-list-name name error-kind error-fun
+		    &optional top-level env-illegal env-arg-name)
+  (let ((path (if top-level `(cdr ,arg-list-name) arg-list-name))
+	(now-processing :required)
+	(maximum 0)
+	(minimum 0)
+	(keys ())
+	rest-name restp allow-other-keys-p env-arg-used)
+    ;; This really strange way to test for '&whole is neccessary because member
+    ;; does not have to work on dotted lists, and dotted lists are legal
+    ;; in lambda-lists.
+    (when (and (do ((list lambda-list (cdr list)))
+		   ((atom list) nil)
+		 (when (eq (car list) '&whole) (return t)))
+	       (not (eq (car lambda-list) '&whole)))
+      (simple-program-error "&Whole must appear first in ~S lambda-list."
+                            error-kind))
+    (do ((rest-of-args lambda-list (cdr rest-of-args)))
+	((atom rest-of-args)
+	 (cond ((null rest-of-args) nil)
+	       ;; Varlist is dotted, treat as &rest arg and exit.
+	       (t (push-let-binding rest-of-args path nil)
+		  (setf restp :dotted))))
+      (let ((var (car rest-of-args)))
+	(cond ((eq var '&whole)
+	       (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
+		      (setf rest-of-args (cdr rest-of-args))
+		      ;; For compiler macros, we have to do something
+		      ;; special in case the form has a car eq to
+		      ;; funcall, as specified in the CLHS.  In this
+		      ;; case, we skip over the funcall and pretend
+		      ;; that the rest of the form is the actual form.
+		      ;;
+		      ;; This is a gross hack because we look at
+		      ;; error-kind to figure out if we're defining a
+		      ;; compiler macro or not.
+		      (when (eq error-kind 'define-compiler-macro)
+			(push-let-binding arg-list-name arg-list-name
+			  t
+			  `(progn
+			    (not (and (listp ,arg-list-name)
+				  (eq 'funcall (car ,arg-list-name)))))
+			  `(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)
+	       (cond (env-illegal
+		      (simple-program-error "&environment not valid with ~S."
+                                            error-kind))
+		     ((not top-level)
+		      (simple-program-error
+		       "&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)
+		      (setf env-arg-used t))
+		     (t
+		      (defmacro-error "&ENVIRONMENT" error-kind name))))
+	      ;;
+	      ;; 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))
+		     ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
+		      (setf rest-of-args (cdr rest-of-args))
+		      (setf restp t)
+		      (push-let-binding (car rest-of-args) path 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)
+	       (setf now-processing :optionals))
+	      ((eq var '&key)
+	       (setf now-processing :keywords)
+	       (setf rest-name (gensym "KEYWORDS-"))
+	       (push rest-name *ignorable-vars*)
+	       (setf restp t)
+	       (push-let-binding rest-name path t))
+	      ((eq var '&allow-other-keys)
+	       (setf allow-other-keys-p t))
+	      ((eq var '&aux)
+	       (setf now-processing :auxs))
+	      ((listp var)
+	       (case now-processing
+		 (:required
+		  (let ((sub-list-name (gensym "SUBLIST-")))
+		    (push-sub-list-binding sub-list-name `(car ,path) var
+					   name error-kind error-fun)
+		    (parse-defmacro-lambda-list var sub-list-name name
+						error-kind error-fun))
+		  (setf path `(cdr ,path))
+		  (incf minimum)
+		  (incf maximum))
+		 (:optionals
+		  (when (> (length var) 3)
+		    (cerror "Ignore extra noise."
+			    "More than variable, initform, and suppliedp ~
+			    in &optional binding - ~S"
+			    var))
+		  (push-optional-binding (car var) (cadr var) (caddr var)
+					 `(not (null ,path)) `(car ,path)
+					 name error-kind error-fun)
+		  (setf path `(cdr ,path))
+		  (incf maximum))
+		 (:keywords
+		  (let* ((keyword-given (consp (car var)))
+			 (variable (if keyword-given
+				       (cadar var)
+				       (car var)))
+			 (keyword (if keyword-given
+				      (caar var)
+				      (make-keyword variable)))
+			 (supplied-p (caddr var)))
+		    (push-optional-binding variable (cadr var) supplied-p
+					   `(keyword-supplied-p ',keyword
+								,rest-name)
+					   `(lookup-keyword ',keyword
+							    ,rest-name)
+					   name error-kind error-fun)
+		    (push keyword keys)))
+		 (:auxs (push-let-binding (car var) (cadr var) nil))))
+	      ((symbolp var)
+	       (case now-processing
+		 (:required
+		  (incf minimum)
+		  (incf maximum)
+		  (push-let-binding var `(car ,path) nil)
+		  (setf path `(cdr ,path)))
+		 (:optionals
+		  (incf maximum)
+		  (push-let-binding var `(car ,path) nil `(not (null ,path)))
+		  (setf path `(cdr ,path)))
+		 (:keywords
+		  (let ((key (make-keyword var)))
+		    (push-let-binding var `(lookup-keyword ,key ,rest-name)
+				      nil)
+		    (push key keys)))
+		 (:auxs
+		  (push-let-binding var nil nil))))
+	      (t
+	       (simple-program-error "Non-symbol in lambda-list - ~S." var)))))
+    ;; Generate code to check the number of arguments, unless dotted
+    ;; in which case length will not work.
+    (unless (eq restp :dotted)
+       (push `(unless (<= ,minimum
+			  (length (the list ,(if top-level
+						 `(cdr ,arg-list-name)
+					       arg-list-name)))
+			  ,@(unless restp
+				    (list maximum)))
+		      ,(let ((arg (if top-level
+				      `(cdr ,arg-list-name)
+				    arg-list-name)))
+			 (if (eq error-fun 'error)
+			     `(do-arg-count-error ',error-kind ',name ,arg
+						  ',lambda-list ,minimum
+						  ,(unless restp maximum))
+			   `(,error-fun 'defmacro-ll-arg-count-error
+				 :kind ',error-kind
+				 ,@(when name `(:name ',name))
+				 :argument ,arg
+				 :lambda-list ',lambda-list
+				 :minimum ,minimum
+				 ,@(unless restp `(:maximum ,maximum))))))
+	     *arg-tests*))
+    (if keys
+	(let ((problem (gensym "KEY-PROBLEM-"))
+	      (info (gensym "INFO-")))
+	  (push `(multiple-value-bind
+		     (,problem ,info)
+		     (verify-keywords ,rest-name ',keys ',allow-other-keys-p)
+		   (when ,problem
+		     (,error-fun
+		      'defmacro-ll-broken-key-list-error
+		      :kind ',error-kind
+		      ,@(when name `(:name ',name))
+		      :problem ,problem
+		      :info ,info)))
+		*arg-tests*)))
+    (values env-arg-used minimum (if (null restp) maximum nil))))
+
+;;; end of file
-- 
GitLab