;;; 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.
#:++ #:--
#:<< #:>>
#:if #:then #:else
- #:let #:let* #:in))
+ #:let #:let* #:in
+ #:bind))
(defpackage #:infix
(:use #:common-lisp #:infix-keywords)
(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.
;;;--------------------------------------------------------------------------
;;; 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*."
;;;--------------------------------------------------------------------------
;;; 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)))
(let ((stuff nil))
(loop
(push (parse-infix 0) stuff)
- (unless (delim '|,| :requiredp nil)
+ (unless (delim '|,| nil)
(return)))
(nreverse stuff)))
(error "expected symbol; found ~S" *token*))
(push *token* stuff)
(get-token)
- (unless (delim '|,| :requiredp nil)
+ (unless (delim '|,| nil)
(return)))
(nreverse stuff)))
(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 ((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.
(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 '|)|)
(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)))))
-
+
(defopfunc lambda operand
(get-token)
(pushval `(lambda ,(parse-lambda-list) ,@(strip-progn (parse-infix 0)))))
(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))))))
(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.
(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.
~mdw / lisp / blobdiff