From: Mark Wooding <mdw@distorted.org.uk>
Date: Wed, 17 May 2006 19:25:30 +0000 (+0100)
Subject: Merge branch 'master' of git+ssh://metalzone.distorted.org.uk/~mdw/public-git/lisp
X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/commitdiff_plain/a035dd4a8175317f19a35cd04568d1655fb8d417?hp=4e49cfb96372b469ced1fd1888deda0c20594bb4

Merge branch 'master' of git+ssh://metalzone.distorted.org.uk/~mdw/public-git/lisp

* 'master' of git+ssh://metalzone.distorted.org.uk/~mdw/public-git/lisp:
  asdf: Provide more package information and dependencies.
  sys-base: Only use the extensions package from CMUCL.
  base: Export unsigned-fixnum as a handy type to have.
  mop: Use CMUCL's `mop' package instead of `pcl'.
  base: New `until' macro does the obvious thing.
---

diff --git a/infix.lisp b/infix.lisp
index a0d320d..ea78422 100644
--- a/infix.lisp
+++ b/infix.lisp
@@ -34,7 +34,8 @@
 	   #:++ #:--
 	   #:<< #:>>
 	   #:if #:then #:else
-	   #:let #:let* #:in))
+	   #:let #:let* #:in
+	   #:bind))
 
 (defpackage #:infix
   (:use #:common-lisp #:infix-keywords)
@@ -356,9 +357,9 @@
 ;;;--------------------------------------------------------------------------
 ;;; Infrastructure for operator definitions.
 
-(defun delim (delim &key (requiredp t))
+(defun delim (delim &optional (requiredp t))
   "Parse DELIM, and read the next token.  Returns t if the DELIM was found,
-   or nil if not (and requiredp was nil)."
+   or nil if not (and REQUIREDP was nil)."
   (cond ((eq *token* delim) (get-token) t)
 	(requiredp (error "expected `~(~A~)'; found ~S" delim *token*))
 	(t nil)))
@@ -413,7 +414,7 @@
   (let ((stuff nil))
     (loop
       (push (parse-infix 0) stuff)
-      (unless (delim '|,| :requiredp nil)
+      (unless (delim '|,| nil)
 	(return)))
     (nreverse stuff)))
 
@@ -425,7 +426,7 @@
         (error "expected symbol; found ~S" *token*))
       (push *token* stuff)
       (get-token)
-      (unless (delim '|,| :requiredp nil)
+      (unless (delim '|,| nil)
 	(return)))
     (nreverse stuff)))
 
@@ -606,20 +607,22 @@
 
 (defopfunc loop operand
   (get-token)
-  (pushval `(loop ,@(progn (strip-progn (parse-infix 0))))))
-
-(defopfunc multiple-value-bind operand
-  (get-token)
-  (pushval `(multiple-value-bind
-	        ,(parse-ident-list)
-	        ,(progn (delim '=) (parse-infix))
-	      ,@(progn (delim 'in) (strip-progn (parse-infix 0))))))
-
-(defopfunc multiple-value-setq operand
-  (get-token)
-  (pushval `(multiple-value-setq
-	        ,(parse-ident-list)
-	        ,(progn (delim '=) (parse-infix 0)))))
+  (pushval `(loop ,@(strip-progn (parse-infix 0)))))
+
+(defopfunc bind operand
+  (labels ((loop ()
+	    (let ((ids (parse-ident-list))
+		  (valform (progn (delim '=) (parse-infix 0)))
+		  (body (if (delim '|,| nil)
+			    (loop)
+			    (progn
+			      (delim 'in)
+			      (strip-progn (parse-infix 0))))))
+	      (list (if (and ids (null (cdr ids)))
+			`(let ((,(car ids) ,valform)) ,@body)
+			`(multiple-value-bind ,ids ,valform ,@body))))))
+    (get-token)
+    (pushval (car (loop)))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Parsing function bodies and lambda lists.
@@ -648,18 +651,18 @@
 		    (get-token)
 		    (when (eq *token* '|)|)
 		      (go done))
-		    (delim '|,| :requiredp nil)
+		    (delim '|,| nil)
 		    (go loop))
 		   ((symbolp *token*)
 		    (let ((name *token*))
 		      (get-token)
-		      (if (delim '= :requiredp nil)
+		      (if (delim '= nil)
 			  (push (list name (parse-infix 0)) args)
 			  (push name args))))
 		   (t
 		    (push *token* args)
 		    (get-token)))
-	     (when (delim '|,| :requiredp nil)
+	     (when (delim '|,| nil)
 	       (go loop))
 	   done)))
       (delim '|)|)
@@ -667,7 +670,7 @@
 
 (defun parse-func-name ()
   "Parse a function name and return its Lisp equivalent."
-  (cond ((delim '|(| :requiredp nil)
+  (cond ((delim '|(| nil)
 	 (prog1 (parse-infix) (delim '|)|)))
 	(t (prog1 *token* (get-token)))))
 	 
@@ -692,7 +695,7 @@
       (push `(,(parse-func-name) ,(parse-lambda-list)
 	       ,@(strip-progn (parse-infix 0)))
 	    clauses)
-      (unless (delim '|,| :requiredp nil)
+      (unless (delim '|,| nil)
 	(return)))
     (delim 'in)
     (pushval `(,kind ,(nreverse clauses) ,@(strip-progn (parse-infix 0))))))
@@ -714,14 +717,27 @@
       (unless (eq *token* delim)
 	(error "expected ~S; found ~S" delim *token*)))))
 
-(defun install-infix-reader (&optional (char #\$))
-  "Installs a macro character `$ INFIX...  $' for translating infix notation
+(defun install-infix-reader
+    (&optional (start #\{) (end #\}) &key dispatch (readtable *readtable*))
+  "Installs a macro character `{ INFIX... }' for translating infix notation
    to Lisp forms.  You also want to (use-package :infix-keywords) if you do
    this."
-  (let ((delim (intern (string #\$) 'infix-keywords)))
-    (set-macro-character char (lambda (stream ch)
-				(declare (ignore ch))
-				(read-infix stream :delim delim)))))
+  (let ((delim (intern (string end) 'infix-keywords)))
+    (flet ((doit (stream &rest noise)
+	     (declare (ignore noise))
+	     (read-infix stream :delim delim)))
+      (if dispatch
+	  (set-dispatch-macro-character dispatch start #'doit readtable)
+	  (set-macro-character start #'doit nil readtable))
+      (unless (or (eql start end)
+		  (multiple-value-bind
+		      (func nontermp)
+		      (get-macro-character end readtable)
+		    (and func (not nontermp))))
+	(set-macro-character end (lambda (noise)
+				   (declare (ignore noise))
+				   (error "Unexpected `~C'." end))
+			     nil readtable)))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Testing things.
@@ -799,8 +815,14 @@
      (labels ((foo (x) (+ x 1)) (bar (x) (- x 1))) (foo (bar y))))
     ("defun foo (x) x - 6" .
      (defun foo (x) (- x 6)))
-    ("multiple-value-bind x, y, z = values(4, 6, 8) in x + y + z" .
-     (multiple-value-bind (x y z) (values 4 6 8) (+ x y z)))))
+    ("bind x = 3 in x - 2" . (let ((x 3)) (- x 2)))
+    ("bind x, y = values(1, 2),
+           z = 3,
+           docs, decls, body = parse-body(body) in complicated" .
+     (multiple-value-bind (x y) (values 1 2)
+       (let ((z 3))
+	 (multiple-value-bind (docs decls body) (parse-body body)
+	   complicated))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Debugging guff.
diff --git a/optparse-test b/optparse-test
index 0fe74b9..b5fe41f 100755
--- a/optparse-test
+++ b/optparse-test
@@ -53,7 +53,7 @@
 	    (#\k "keywword" (:arg "KEYWORD") (keyword opt-keyword)
 		 ("Set an arbitrary keyword."))
 	    (#\e "enumeration" (:arg "ENUM")
-		 (keyword opt-enum :apple :apple-pie :abacus :banana)
+		 (keyword opt-enum (list :apple :apple-pie :abacus :banana))
 		 ("Set a keyword from a fixed set."))
 	    (#\x "xray" (:arg "WAVELENGTH")
 		 "Report an option immediately.")
diff --git a/optparse.lisp b/optparse.lisp
index 9f835fc..5f28365 100644
--- a/optparse.lisp
+++ b/optparse.lisp
@@ -571,29 +571,38 @@ Ambiguous long option `~A' -- could be any of:~{~%  --~A~}"
   "Stores ARG in VAR, just as it is."
   (setf var arg))
 
-(defopthandler keyword (var arg) (&rest valid)
-  (if (null valid)
-      (setf var (intern (string-upcase arg) :keyword))
-      (let ((matches nil)
-	    (guess (string-upcase arg))
-	    (len (length arg)))
-	(dolist (k valid)
-	  (let* ((kn (symbol-name k))
-		 (klen (length kn)))
-	    (cond ((string= kn guess)
-		   (setf matches (list k))
-		   (return))
-		  ((and (< len klen)
-			(string= guess kn :end2 len))
-		   (push k matches)))))
-	(case (length matches)
-	  (0 (option-parse-error "Argument `~A' invalid: must be one of:~
-                                   ~{~%~8T~(~A~)~}"
-				 arg valid))
-	  (1 (setf var (car matches)))
-	  (t (option-parse-error "Argument `~A' ambiguous: may be any of:~
-                                   ~{~%~8T~(~A~)~}"
-				 arg matches))))))
+(defopthandler keyword (var arg) (&optional (valid t))
+  "Converts ARG into a keyword.  If VALID is t, then any ARG string is
+   acceptable: the argument is uppercased and interned in the keyword
+   package.  If VALID is a list, then we ensure that ARG matches one of the
+   elements of the list; unambigious abbreviations are allowed."
+  (etypecase valid
+    ((member t)
+     (setf var (intern (string-upcase arg) :keyword)))
+    (list
+     (let ((matches nil)
+	   (guess (string-upcase arg))
+	   (len (length arg)))
+       (dolist (k valid)
+	 (let* ((kn (symbol-name k))
+		(klen (length kn)))
+	   (cond ((string= kn guess)
+		  (setf matches (list k))
+		  (return))
+		 ((and (< len klen)
+		       (string= guess kn :end2 len))
+		  (push k matches)))))
+       (cond
+	 ((null matches)
+	  (option-parse-error "Argument `~A' invalid: must be one of:~
+			       ~{~%~8T~(~A~)~}"
+			      arg valid))
+	 ((null (cdr matches))
+	  (setf var (car matches)))
+	 (t
+	  (option-parse-error "Argument `~A' ambiguous: may be any of:~
+			       ~{~%~8T~(~A~)~}"
+			      arg matches)))))))
 
 (defopthandler list (var arg) (&optional handler &rest handler-args)
   "Collect ARGs in a list at VAR.  ARGs are translated by the HANDLER first,