(: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
- #:nlet #:while
+ #:nlet #:while #:case2 #:ecase2
#:with-gensyms #:let*/gensyms #:with-places
#:locp #:locf #:ref #:with-locatives
#:update-place #:update-place-after
((#\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."))
+(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.
(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
(defmacro %place-ref (getform setform newtmp)
~mdw / lisp / blobdiff