Merge branch 'svn'

diff --git a/anaphora.lisp b/anaphora.lisp
new file mode 100644 (file)
index 0000000..c7a4b08
--- /dev/null
+++ b/anaphora.lisp
@@ -0,0 +1,106 @@
+;;; -*-lisp-*-
+;;;
+;;; $Id$
+;;;
+;;; Anaphoric extensions
+;;;
+;;; (c) 2005 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;; 
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;; 
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(defpackage #:mdw.anaphora
+  (:use #:common-lisp)
+  (:export #:it
+          #:aif #:aif2 #:awhen #:awhen2
+          #:aand #:awhile #:asetf #:acond))
+(in-package #:mdw.anaphora)
+
+(defmacro aif (cond then &optional else)
+  "Bind `it' to result of COND when evaluating THEN or ELSE."
+  `(let ((it ,cond))
+     (if it ,then ,@(and else (list else)))))
+(defmacro aif2 (cond then &optional else)
+  "Bind `it' to first value of COND; switch on second."
+  (let ((tmp (gensym)))
+    `(multiple-value-bind (it ,tmp) ,cond
+       (declare (ignorable it))
+       (if ,tmp ,then ,@(and else (list else))))))
+
+(defmacro awhen (cond &body body)
+  "Bind `it' to result of COND when evaluating BODY."
+  `(let ((it ,cond))
+     (when it ,@body)))
+(defmacro awhen2 (cond &body body)
+  "Bind `it' to first value of COND; switch on second."
+  (let ((tmp (gensym)))
+    `(multiple-value-bind (it ,tmp) ,cond
+       (declare (ignorable it))
+       (when ,tmp ,@body))))
+
+(defmacro aand (&rest things)
+  "Like `and', with `it' bound to previous value."
+  (labels ((foo (things)
+            (if (cdr things)
+                `(let ((it ,(car things)))
+                   (if it ,(foo (cdr things))))
+                (car things))))
+    (if things
+       (foo things)
+       t)))
+
+(defmacro awhile (cond &body body)
+  "Like `while', with `it' bound to value of COND in BODY."
+  `(loop
+     (let ((it ,cond))
+       (unless it (return))
+       ,@body)))
+
+(defmacro asetf (&rest pairs &environment env)
+  "Set PLACE to value of FORM; in FORM, `it' is bound to current value of
+PLACE."
+  (labels ((foo (pairs)
+            (when pairs
+              (let ((place (car pairs))
+                    (form (cadr pairs))
+                    (rest (cddr pairs)))
+                (cons (multiple-value-bind
+                          (valtmps valforms newtmps setform getform)
+                          (get-setf-expansion place env)
+                        `(let* ,(mapcar #'list valtmps valforms)
+                           (let* ((it ,getform)
+                                  (,(car newtmps) ,form))
+                             ,setform)))
+                      (foo rest))))))
+    (cons 'progn (foo pairs))))
+                 
+(defmacro acond (&rest clauses)
+  "Like `cond', but in each clause the consequent has `it' bound to the value
+of its guard."
+  (labels ((foo (clauses)
+            (when clauses
+              (let ((tmp (gensym))
+                    (clause (car clauses)))
+                `(let ((,tmp ,(car clause)))
+                   (if ,tmp
+                       (let ((it ,tmp))
+                         (declare (ignorable it))
+                         ,@(cdr clause))
+                       ,(foo (cdr clauses))))))))
+    (foo clauses)))
+
+;;;----- That's all, folks --------------------------------------------------

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 3111832bc5b5c31fafad68573be2ab1872d9cc74..edebebb275e3b8a386f0e0e3217eb93122459a21 100644 (file)
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -86,6 +86,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

diff --git a/mdw.asd b/mdw.asd
index d65d5027d49622cd70031d79bfdf017f49c3784d..32ad40dc83fedfdd0849ebe4579c620809b22064 100644 (file)
--- a/mdw.asd
+++ b/mdw.asd
@@ -6,6 +6,7 @@
 
 (defsystem "mdw"
   :components ((:file "mdw-base")
+              (:file "anaphora")
               (:file "sys-base")
               (:file "str")
               (:file "collect")

diff --git a/sys-base.lisp b/sys-base.lisp
index fdbf4fb6b7ab4852f0dfecf3710ced94600af45a..47ef2fb325d7329c807f50a796e5b3aae52f5d98 100644 (file)
--- a/sys-base.lisp
+++ b/sys-base.lisp
@@ -45,9 +45,10 @@ (defun exit (&optional (code 0))
         (abort))))
 
 #+cmu
-(defun hard-exit (code)
+(defun hard-exit (&optional (code 0))
   "Stops the program immediately in its tracks.  Does nothing else.  Use
 after fork, for example, to avoid flushing buffers."
+  (declare (type (unsigned-byte 32) code))
   (unix::void-syscall ("_exit" c-call:int) code))
 
 #+cmu