X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/2b525992937f759211ea42e6e6f2bf0e695de96c..0eed4749891adf0a7be89e786b8968ee805a8d41:/mdw-base.lisp diff --git a/mdw-base.lisp b/mdw-base.lisp index b9e9257..2bad2c2 100644 --- a/mdw-base.lisp +++ b/mdw-base.lisp @@ -219,94 +219,6 @@ (car (more (mapcar #'pairify (listify binds))))))) ;;;-------------------------------------------------------------------------- -;;; Some simple yet useful control structures. - -(export 'nlet) -(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)))) - -(export 'while) -(defmacro while (cond &body body) - "If COND is false, evaluate to nil; otherwise evaluate BODY and try again." - `(loop (unless ,cond (return)) (progn ,@body))) - -(export 'until) -(defmacro until (cond &body body) - "If COND is true, evaluate to nil; otherwise evaluate BODY and try again." - `(loop (when ,cond (return)) (progn ,@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 varx vary) &rest forms) - clause - `(,cases - ,@(if varx - (list `(let ((,(or vary varx) ,argument) - ,@(and vary - `((,varx ,scrutinee)))) - ,@forms)) - forms)))) - clauses))))) - -(export 'caase2) -(defmacro case2 (vform &body clauses) - "VFORM is a form which evaluates to two values, SCRUTINEE and 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)) - -(export 'ecase2) -(defmacro ecase2 (vform &body clauses) - "Like `case2', but signals an error if no clause matches the SCRUTINEE." - (do-case2-like 'ecase vform clauses)) - -(export 'setf-default) -(defmacro setf-default (&rest specs &environment env) - "Like setf, but only sets places which are currently nil. - - The arguments are an alternating list of PLACEs and DEFAULTs. If a PLACE - is nil, the DEFAULT is evaluated and stored in the PLACE; otherwise the - default is /not/ stored. The result is the (new) value of the last - PLACE." - (labels ((doit (specs) - (cond ((null specs) nil) - ((null (cdr specs)) - (error "Odd number of arguments for SETF-DEFAULT.")) - (t - (let ((place (car specs)) - (default (cadr specs)) - (rest (cddr specs))) - (multiple-value-bind - (vars vals store-vals writer reader) - (get-setf-expansion place env) - `(let* ,(mapcar #'list vars vals) - (or ,reader - (multiple-value-bind ,store-vals ,default - ,writer)) - ,@(and rest (list (doit rest)))))))))) - (doit specs))) - -;;;-------------------------------------------------------------------------- ;;; Capturing places as symbols. (defmacro %place-ref (getform setform newtmp) @@ -379,6 +291,85 @@ ,@body)))) ;;;-------------------------------------------------------------------------- +;;; Some simple yet useful control structures. + +(export 'nlet) +(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)))) + +(export 'while) +(defmacro while (cond &body body) + "If COND is false, evaluate to nil; otherwise evaluate BODY and try again." + `(loop (unless ,cond (return)) (progn ,@body))) + +(export 'until) +(defmacro until (cond &body body) + "If COND is true, evaluate to nil; otherwise evaluate BODY and try again." + `(loop (when ,cond (return)) (progn ,@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 varx vary) &rest forms) + clause + `(,cases + ,@(if varx + (list `(let ((,(or vary varx) ,argument) + ,@(and vary + `((,varx ,scrutinee)))) + ,@forms)) + forms)))) + clauses))))) + +(export 'caase2) +(defmacro case2 (vform &body clauses) + "VFORM is a form which evaluates to two values, SCRUTINEE and 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)) + +(export 'ecase2) +(defmacro ecase2 (vform &body clauses) + "Like `case2', but signals an error if no clause matches the SCRUTINEE." + (do-case2-like 'ecase vform clauses)) + +(export 'setf-default) +(defmacro setf-default (&rest specs) + "Like setf, but only sets places which are currently nil. + + The arguments are an alternating list of PLACEs and DEFAULTs. If a PLACE + is nil, the DEFAULT is evaluated and stored in the PLACE; otherwise the + default is /not/ stored. The result is the (new) value of the last + PLACE." + `(progn ,@(do ((list nil) + (specs specs (cddr specs))) + ((endp specs) (nreverse list)) + (unless (cdr specs) + (error "Odd number of arguments for `setf-default'.")) + (push (with-places/gensyms ((place (car specs))) + `(or ,place (setf ,place ,(cadr specs)))) + list)))) + +;;;-------------------------------------------------------------------------- ;;; Update-in-place macros built using with-places. (export 'update-place) @@ -412,8 +403,8 @@ (export 'locp) (defstruct (loc (:predicate locp) (:constructor make-loc (reader writer))) "Locative data type. See `locf' and `ref'." - (reader (slot-uninitialized) :type function) - (writer (slot-uninitialized) :type function)) + (reader (slot-uninitialized) :type function :read-only t) + (writer (slot-uninitialized) :type function :read-only t)) (export 'locf) (defmacro locf (place &environment env)