X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/lisp/blobdiff_plain/0ff9df03bb54ba792cefa551face51748ae34259..e2a3c9236277551b174d522db7161c4eec29f97f:/mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index cde1d7a..269b398 100644
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -105,24 +105,24 @@ (defun slot-uninitialized ()
    structure definitions without doom ensuing."
   (error "No initializer for slot."))
 
-(compile-time-defun parse-body (body)
+(compile-time-defun parse-body (body &key (allow-docstring-p t))
   "Given a BODY (a list of forms), parses it into three sections: a
    docstring, a list of declarations (forms beginning with the symbol
    `declare') and the body forms.  The result is returned as three lists
    (even the docstring), suitable for interpolation into a backquoted list
-   using `@,'."
-  (multiple-value-bind
-      (doc body)
-      (if (and (consp body)
-	       (stringp (car body)))
-	  (values (list (car body)) (cdr body))
-	  (values nil body))
-    (loop for forms on body
-	  for form = (car forms)
-	  while (and (consp form)
-		     (eq (car form) 'declare))
-	  collect form into decls
-	  finally (return (values doc decls forms)))))
+   using `@,'.  If ALLOW-DOCSTRING-P is nil, docstrings aren't allowed at
+   all."
+  (let ((doc nil) (decls nil))
+    (do ((forms body (cdr forms))) (nil)
+      (let ((form (and forms (car forms))))
+	(cond ((and allow-docstring-p (not doc) (stringp form) (cdr forms))
+	       (setf doc form))
+	      ((and (consp form)
+		    (eq (car form) 'declare))
+	       (setf decls (append decls (cdr form))))
+	      (t (return (values (and doc (list doc))
+				 (and decls (list (cons 'declare decls)))
+				 forms))))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Generating symbols.
@@ -179,21 +179,26 @@ (compile-time-defun do-case2-like (kind vform clauses)
        (,kind ,scrutinee
 	 ,@(mapcar (lambda (clause)
 		     (destructuring-bind
-			 (cases (&optional var) &rest forms)
+			 (cases (&optional varx vary) &rest forms)
 			 clause
 		       `(,cases
-			 ,@(if var
-			       (list `(let ((,var ,argument)) ,@forms))
+			 ,@(if varx
+			       (list `(let ((,(or vary varx) ,argument)
+					    ,@(and vary
+						   `((,varx ,scrutinee))))
+				        ,@forms))
 			       forms))))
 		   clauses)))))
 
 (defmacro case2 (vform &body clauses)
   "VFORM is a form which evaluates to two values, SCRUTINEE and ARGUMENT.
-   The CLAUSES have the form (CASES ([VAR]) FORMS...), where a standard
-   `case' clause has the form (CASES FORMS...).  The `case2' form evaluates
-   the VFORM, and compares the SCRUTINEE to the various CASES, in order, just
-   like `case'.  If there is a match, then the corresponding FORMs are
-   evaluated with VAR (if specified) bound to the value of ARGUMENT."
+   The CLAUSES have the form (CASES ([[SCRUVAR] ARGVAR]) FORMS...), where a
+   standard `case' clause has the form (CASES FORMS...).  The `case2' form
+   evaluates the VFORM, and compares the SCRUTINEE to the various CASES, in
+   order, just like `case'.  If there is a match, then the corresponding
+   FORMs are evaluated with ARGVAR bound to the ARGUMENT and SCRUVAR bound to
+   the SCRUTINEE (where specified).  Note the bizarre defaulting behaviour:
+   ARGVAR is less optional than SCRUVAR."
   (do-case2-like 'case vform clauses))
 
 (defmacro ecase2 (vform &body clauses)