X-Git-Url: http://git.kpe.io/?p=lml2.git;a=blobdiff_plain;f=read-macro.lisp;h=0e173ebdbbb66547d757907ba59f7b3e55ce26a5;hp=cea9af9fad10ce4f8b8be485cc5515e929141c56;hb=cd7657d502de822c899ad08d7e37dd6e778f3d26;hpb=be1b61b9a1a19ea618b9cd854d6539957c4efd57 diff --git a/read-macro.lisp b/read-macro.lisp index cea9af9..0e173eb 100644 --- a/read-macro.lisp +++ b/read-macro.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: read-macro.lisp,v 1.2 2003/07/12 17:54:05 kevin Exp $ +;;;; $Id$ ;;;; ;;;; This file, part of LML2, is Copyright (c) 2000-2003 by Kevin Rosenberg. ;;;; Rights of modification and redistribution are in the LICENSE file. @@ -23,58 +23,58 @@ #'(lambda (stream char) (declare (ignore char)) (let ((forms '()) - (curr-string (new-string)) - (paren-level 0) - (got-comma nil)) - (declare (type fixnum paren-level)) - (do ((ch (read-char stream t nil t) (read-char stream t nil t))) - ((eql ch #\])) - (if got-comma - (if (eql ch #\() - ;; Starting top-level ,( - (progn - #+cmu - (setf curr-string (coerce curr-string `(simple-array character (*)))) - - (push `(lml2-princ ,curr-string) forms) - (setq curr-string (new-string)) - (setq got-comma nil) - (vector-push #\( curr-string) - (do ((ch (read-char stream t nil t) (read-char stream t nil t))) - ((and (eql ch #\)) (zerop paren-level))) - (when (eql ch #\]) - (format *trace-output* "Syntax error reading #\]") - (return nil)) - (case ch - (#\( - (incf paren-level)) - (#\) - (decf paren-level))) - (vector-push-extend ch curr-string)) - (vector-push-extend #\) curr-string) - (let ((eval-string (read-from-string curr-string)) - (res (gensym))) - (push - `(let ((,res ,eval-string)) - (when ,res - (lml2-princ ,res))) - forms)) - (setq curr-string (new-string))) - ;; read comma, then non #\( char - (progn - (unless (eql ch #\,) - (setq got-comma nil)) - (vector-push-extend #\, curr-string) ;; push previous command - (vector-push-extend ch curr-string))) - ;; previous character is not a comma - (if (eql ch #\,) - (setq got-comma t) - (progn - (setq got-comma nil) - (vector-push-extend ch curr-string))))) + (curr-string (new-string)) + (paren-level 0) + (got-comma nil)) + (declare (type fixnum paren-level)) + (do ((ch (read-char stream t nil t) (read-char stream t nil t))) + ((eql ch #\])) + (if got-comma + (if (eql ch #\() + ;; Starting top-level ,( + (progn + #+cmu + (setf curr-string (coerce curr-string `(simple-array character (*)))) - #+cmu - (setf curr-string (coerce curr-string `(simple-array character (*)))) - - (push `(lml2-princ ,curr-string) forms) - `(progn ,@(nreverse forms))))) + (push `(lml2-princ ,curr-string) forms) + (setq curr-string (new-string)) + (setq got-comma nil) + (vector-push #\( curr-string) + (do ((ch (read-char stream t nil t) (read-char stream t nil t))) + ((and (eql ch #\)) (zerop paren-level))) + (when (eql ch #\]) + (format *trace-output* "Syntax error reading #\]") + (return nil)) + (case ch + (#\( + (incf paren-level)) + (#\) + (decf paren-level))) + (vector-push-extend ch curr-string)) + (vector-push-extend #\) curr-string) + (let ((eval-string (read-from-string curr-string)) + (res (gensym))) + (push + `(let ((,res ,eval-string)) + (when ,res + (lml2-princ ,res))) + forms)) + (setq curr-string (new-string))) + ;; read comma, then non #\( char + (progn + (unless (eql ch #\,) + (setq got-comma nil)) + (vector-push-extend #\, curr-string) ;; push previous command + (vector-push-extend ch curr-string))) + ;; previous character is not a comma + (if (eql ch #\,) + (setq got-comma t) + (progn + (setq got-comma nil) + (vector-push-extend ch curr-string))))) + + #+cmu + (setf curr-string (coerce curr-string `(simple-array character (*)))) + + (push `(lml2-princ ,curr-string) forms) + `(progn ,@(nreverse forms)))))