X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/lisp/blobdiff_plain/861345b43569790e39df152c6b495b14e7dab360..e09b6d1d4ad8756be39b092f1fe72f771cb2296c:/mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 3111832..21948fa 100644
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -31,7 +31,9 @@ (defpackage #:mdw.base
 	   #:whitespace-char-p
 	   #:slot-uninitialized
 	   #:with-gensyms #:let*/gensyms #:with-places
-	   #:locp #:locf #:ref #:with-locatives))
+	   #:locp #:locf #:ref #:with-locatives
+	   #:update-place #:update-place-after
+	   #:incf-after #:decf-after))
 (in-package #:mdw.base)
 
 (defmacro compile-time-defun (name args &body body)
@@ -86,6 +88,24 @@ (defun whitespace-char-p (ch)
     ((#\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
@@ -155,6 +175,25 @@ (defmacro with-places ((&key environment) places &body body)
                                          body))))))))))
           (car (more (mapcar #'pairify (listify places))))))))
 
+(defmacro update-place (op place arg &environment env)
+  "Update PLACE with the value of OP PLACE ARG, returning the new value."
+  (with-places (:environment env) (place)
+    `(setf ,place (,op ,place ,arg))))
+(defmacro update-place-after (op place arg &environment env)
+  "Update PLACE with the value of OP PLACE ARG, returning the old value."
+  (with-places (:environment env) (place)
+    (with-gensyms (x)
+      `(let ((,x ,place))
+         (setf ,place (,op ,x ,arg))
+         ,x))))
+(defmacro incf-after (place &optional (by 1))
+  "Increment PLACE by BY, returning the old value."
+  `(update-place-after + ,place ,by))
+(defmacro decf-after (place &optional (by 1))
+  "Decrement PLACE by BY, returning the old value."
+  `(update-place-after - ,place ,by))
+
+
 (defstruct (loc (:predicate locp) (:constructor make-loc (reader writer)))
   "Locative data type.  See `locf' and `ref'."
   (reader (slot-uninitialized) :type function)