base: New macro for parsing function bodies.

[lisp] / mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 5203933bffdde883bed6ead569e5a238bb32ee6a..1f5a3eb17cf90925a2fff62d5c7c2ceb286472e4 100644 (file)
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -30,10 +30,10 @@ (defpackage #:mdw.base
   (:use #:common-lisp)
   (:export #:compile-time-defun
           #:show
   (:use #:common-lisp)
   (:export #:compile-time-defun
           #:show

-          #:stringify #:listify #:fix-pair #:pairify
+          #:stringify #:listify #:fix-pair #:pairify #:parse-body

           #:whitespace-char-p
           #:slot-uninitialized
           #:whitespace-char-p
           #:slot-uninitialized

-          #:nlet #:while
+          #:nlet #:while #:case2 #:ecase2

           #:with-gensyms #:let*/gensyms #:with-places
           #:locp #:locf #:ref #:with-locatives
           #:update-place #:update-place-after
           #:with-gensyms #:let*/gensyms #:with-places
           #:locp #:locf #:ref #:with-locatives
           #:update-place #:update-place-after


@@ -99,30 +99,30 @@ (defun whitespace-char-p (ch)
     ((#\space #\tab #\newline #\return #\vt #\formfeed) t)
     (t nil)))
 
     ((#\space #\tab #\newline #\return #\vt #\formfeed) t)
     (t nil)))
 

-(defmacro nlet (name binds &body body)
-  "Scheme's named let."
-  (multiple-value-bind (vars vals)
-      (loop for bind in binds
-           for (var val) = (pairify bind nil)
-           collect var into vars
-           collect val into vals
-           finally (return (values vars vals)))
-    `(labels ((,name ,vars
-               ,@body))
-       (,name ,@vals))))
-
-(defmacro while (cond &body body)
-  "If COND is false, evaluate to nil; otherwise evaluate BODY and try again."
-  `(loop
-     (unless `cond (return))
-     ,@body))
-

 (declaim (ftype (function nil ()) slot-unitialized))
 (defun slot-uninitialized ()
   "A function which signals an error.  Can be used as an initializer form in
 structure definitions without doom ensuing."
   (error "No initializer for slot."))
 
 (declaim (ftype (function nil ()) slot-unitialized))
 (defun slot-uninitialized ()
   "A function which signals an error.  Can be used as an initializer form in
 structure definitions without doom ensuing."
   (error "No initializer for slot."))
 

+(compile-time-defun parse-body (body)
+  "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)))))
+

 ;;;--------------------------------------------------------------------------
 ;;; Generating symbols.
 
 ;;;--------------------------------------------------------------------------
 ;;; Generating symbols.
 


@@ -149,6 +149,56 @@ (defmacro let*/gensyms (binds &body body)
         `(progn ,@body)
         (car (more (mapcar #'pairify (listify binds)))))))
 
         `(progn ,@body)
         (car (more (mapcar #'pairify (listify binds)))))))
 

+;;;--------------------------------------------------------------------------
+;;; Some simple yet useful control structures.
+
+(defmacro nlet (name binds &body body)
+  "Scheme's named let."
+  (multiple-value-bind (vars vals)
+      (loop for bind in binds
+           for (var val) = (pairify bind nil)
+           collect var into vars
+           collect val into vals
+           finally (return (values vars vals)))
+    `(labels ((,name ,vars
+               ,@body))
+       (,name ,@vals))))
+
+(defmacro while (cond &body body)
+  "If COND is false, evaluate to nil; otherwise evaluate BODY and try again."
+  `(loop
+     (unless ,cond (return))
+     ,@body))
+
+(compile-time-defun do-case2-like (kind vform clauses)
+  "Helper function for `case2' and `ecase2'."
+  (with-gensyms (scrutinee argument)
+    `(multiple-value-bind (,scrutinee ,argument) ,vform
+       (declare (ignorable ,argument))
+       (,kind ,scrutinee
+        ,@(mapcar (lambda (clause)
+                    (destructuring-bind
+                        (cases (&optional var) &rest forms)
+                        clause
+                      `(,cases
+                        ,@(if var
+                              (list `(let ((,var ,argument)) ,@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."
+  (do-case2-like 'case vform clauses))
+
+(defmacro ecase2 (vform &body clauses)
+  "Like `case2', but signals an error if no clause matches the SCRUTINEE."
+  (do-case2-like 'ecase vform clauses))
+

 ;;;--------------------------------------------------------------------------
 ;;; with-places
 
 ;;;--------------------------------------------------------------------------
 ;;; with-places