X-Git-Url: http://git.kpe.io/?p=lml2.git;a=blobdiff_plain;f=read-macro.lisp;fp=read-macro.lisp;h=0e173ebdbbb66547d757907ba59f7b3e55ce26a5;hp=8e97b9d4cbb72a05cdb27d600781126a3c2ce4ff;hb=9c5e52ab7792dc7e57d02141c797d95b31b23039;hpb=1156e876ab634a4634a472c79bdfa8756f583e80 diff --git a/read-macro.lisp b/read-macro.lisp index 8e97b9d..0e173eb 100644 --- a/read-macro.lisp +++ b/read-macro.lisp @@ -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)))))