X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/05c1e7c3367de14f38e81e9ecdc0a36904dbc13e..1a50efd8a9e976bf16a29ce381ea38c6b9a39ea1:/infix.lisp

diff --git a/infix.lisp b/infix.lisp
index 93ec028..a77f51e 100644
--- a/infix.lisp
+++ b/infix.lisp
@@ -11,12 +11,12 @@
 ;;; 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.
@@ -34,7 +34,8 @@
 	   #:++ #:--
 	   #:<< #:>>
 	   #:if #:then #:else
-	   #:let #:let* #:in))
+	   #:let #:let* #:in
+	   #:bind))
 
 (defpackage #:infix
   (:use #:common-lisp #:infix-keywords)
@@ -69,7 +70,7 @@
   (name nil :type symbol)
   (lprec nil :type (or fixnum null))
   (rprec nil :type (or fixnum null))
-  (func (lambda () nil) :type (function () t)))
+  (func (lambda () nil) :type #-ecl (function () t) #+ecl function))
 
 ;;;--------------------------------------------------------------------------
 ;;; Global parser state.
@@ -93,8 +94,12 @@
 ;;;--------------------------------------------------------------------------
 ;;; The tokenizer.
 
-(defconstant eof (cons :eof nil)
-  "A magical object which `get-token' returns at end-of-file.")
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (let ((value (cons :eof nil)))
+    (unless (and (boundp 'eof)
+		 (equal (symbol-value 'eof) value))
+      (defconstant eof (cons :eof nil)
+	"A magical object which `get-token' returns at end-of-file."))))
 
 (defun default-get-token ()
   "Read a token from *stream* and store it in *token*."
@@ -608,18 +613,20 @@
   (get-token)
   (pushval `(loop ,@(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)))))
+(defopfunc bind operand
+  (labels ((loopy ()
+	    (let ((ids (parse-ident-list))
+		  (valform (progn (delim '=) (parse-infix 0)))
+		  (body (if (delim '|,| nil)
+			    (loopy)
+			    (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 (loopy)))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Parsing function bodies and lambda lists.
@@ -670,7 +677,7 @@
   (cond ((delim '|(| nil)
 	 (prog1 (parse-infix) (delim '|)|)))
 	(t (prog1 *token* (get-token)))))
-	 
+
 (defopfunc lambda operand
   (get-token)
   (pushval `(lambda ,(parse-lambda-list) ,@(strip-progn (parse-infix 0)))))
@@ -714,14 +721,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 +819,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.