fix nested qq reader bug and add log statements. the interesting change is small, getting the previous unquote reader in read-quasi-quote, the rest is logging and indenting
Fri Dec 26 10:00:08 PST 2008 attila.lendvai@gmail.com
* fix nested qq reader bug and add log statements. the interesting change is small, getting the previous unquote reader in read-quasi-quote, the rest is logging and indenting
diff -rN -u old-cl-syntax-sugar/src/package.lisp new-cl-syntax-sugar/src/package.lisp
--- old-cl-syntax-sugar/src/package.lisp 2014-07-30 16:23:57.000000000 -0700
+++ new-cl-syntax-sugar/src/package.lisp 2014-07-30 16:23:57.000000000 -0700
@@ -23,4 +23,6 @@
;; export it early, we don't know in which order the integrations are loaded
#:register-readtable-for-swank
- ))
+ )
+ (:shadow
+ #:log))
diff -rN -u old-cl-syntax-sugar/src/quasi-quote.lisp new-cl-syntax-sugar/src/quasi-quote.lisp
--- old-cl-syntax-sugar/src/quasi-quote.lisp 2014-07-30 16:23:57.000000000 -0700
+++ new-cl-syntax-sugar/src/quasi-quote.lisp 2014-07-30 16:23:57.000000000 -0700
@@ -35,7 +35,7 @@
(when (and dispatched-quasi-quote-name
(eql start-character #\`))
(error "You requested the dispatched-quasi-quote reader, which is registered on the #\` character, and also provided #\` to be the start-character. Which one should win?"))
- (bind ((reader (make-quasi-quote-reader nil nil nil
+ (bind ((reader (make-quasi-quote-reader nil nil
start-character end-character
quasi-quote-wrapper nested-quasi-quote-wrapper
unquote-character unquote-wrapper
@@ -55,10 +55,8 @@
(set-macro-character start-character reader t *readtable*))))
(when dispatched-quasi-quote-name
(bind ((previous-reader-on-backtick (get-macro-character #\`))
- (previous-reader-on-comma (get-macro-character #\,))
(dispatching-reader (make-quasi-quote-reader dispatched-quasi-quote-name
previous-reader-on-backtick
- previous-reader-on-comma
#\` nil
quasi-quote-wrapper nested-quasi-quote-wrapper
unquote-character unquote-wrapper
@@ -74,7 +72,6 @@
(defun make-quasi-quote-reader (dispatched-quasi-quote-name
previous-reader-on-backtick
- previous-reader-on-comma
start-character end-character
quasi-quote-wrapper nested-quasi-quote-wrapper
unquote-character unquote-wrapper
@@ -87,116 +84,138 @@
(when (and dispatched-quasi-quote-name
end-character)
(error "What?! dispatched-quasi-quote is always installed on #\` and should not have an end-character..."))
- (bind ((dispatched? (not (null dispatched-quasi-quote-name))))
- (labels ((toplevel-quasi-quote-reader (stream &optional char1 char2)
- (declare (ignore char1 char2))
- (read-quasi-quote nil stream))
- (read-using-original-reader (stream char)
- ;; KLUDGE this is a random workaround only. we should have our own ` reader...
- (if previous-reader-on-backtick
+ (macrolet ((log (message &rest args)
+ (declare (ignorable message args))
+ #+nil
+ `(progn
+ (write-string (make-string (* 2 *quasi-quote-depth*) :initial-element #\Space) *debug-io*)
+ (format *debug-io* ,message ,@args)
+ (format *debug-io* " (dispatched-quasi-quote-name: ~S, start/end character: ~S ~S)" dispatched-quasi-quote-name start-character end-character)
+ (terpri *debug-io*)
+ (values))))
+ (bind ((dispatched? (not (null dispatched-quasi-quote-name)))
+ (previous-reader-on-comma nil))
+ (labels ((toplevel-quasi-quote-reader (stream &optional char1 char2)
+ (declare (ignore char1 char2))
+ (log "TOPLEVEL-QUASI-QUOTE-READER entering")
+ (multiple-value-prog1
+ (read-quasi-quote nil stream)
+ (log "TOPLEVEL-QUASI-QUOTE-READER leaving")))
+ (read-using-previous-reader (stream char)
+ (log "READ-USING-PREVIOUS-READER entering, previous-reader-on-backtick: ~A, previous-reader-on-comma: ~A" previous-reader-on-backtick previous-reader-on-comma)
+ (if previous-reader-on-backtick
+ (with-local-readtable
+ (set-macro-character #\, previous-reader-on-comma)
+ (funcall previous-reader-on-backtick stream char))
+ (simple-reader-error stream "No dispatched quasi-quote reader with name ~S" dispatched-quasi-quote-name)))
+ (dispatching-toplevel-quasi-quote-reader (stream char)
+ (log "DISPATCHING-TOPLEVEL-QUASI-QUOTE-READER entering, *dispatched-quasi-quote-name* ~S" *dispatched-quasi-quote-name*)
+ (assert dispatched?)
+ (assert (char= start-character char))
+ (if (or *dispatched-quasi-quote-name*
+ (char-equal (elt (string dispatched-quasi-quote-name) 0)
+ (peek-char nil stream t nil t)))
+ (bind ((name (or *dispatched-quasi-quote-name*
+ (read stream t nil t))))
+ (if (or (eq name dispatched-quasi-quote-name)
+ (string= (string-downcase name) (string-downcase dispatched-quasi-quote-name)))
+ (bind ((*dispatched-quasi-quote-name* nil))
+ ;; ok, we've got a match, read it in.
+ (read-quasi-quote t stream))
+ (bind ((*dispatched-quasi-quote-name* name))
+ ;; FIXME this will do something horribly wrong for a `foo()
+ ;; if there's no handler for it and the default reader is called.
+ (read-using-previous-reader stream char))))
+ (read-using-previous-reader stream char)))
+ (read-quasi-quoted-body (stream)
+ (log "READ-QUASI-QUOTED-BODY entering")
+ (if (and body-reader
+ (not dispatched?))
+ (funcall body-reader stream)
+ (if end-character
+ (with-local-readtable
+ ;; we must set the syntax on the end char to be like #\)
+ ;; until we read out our entire body. this is needed to
+ ;; make "[... 5] style inputs work where '5' is not
+ ;; separated from ']'.
+ ;; doin this is not necessary when invoked from the nested reader
+ ;; but doesn't hurt either. wastes some cycles, but...
+ (set-syntax-from-char end-character #\) *readtable*)
+ (read-delimited-list end-character stream t))
+ (read stream t nil t))))
+ (read-quasi-quote (dispatched? stream)
+ (log "READ-QUASI-QUOTE entering, unquote-reader on ~S is ~A" unquote-character (get-macro-character* unquote-character *readtable*))
+ (setf previous-reader-on-comma (get-macro-character #\,))
+ (bind ((entering-readtable *readtable*)
+ (entering-quasi-quote-nesting-level *quasi-quote-nesting-level*)
+ (*quasi-quote-depth* (1+ *quasi-quote-depth*))
+ (*quasi-quote-nesting-level* (1+ *quasi-quote-nesting-level*))
+ (*toplevel-readtable* (or *toplevel-readtable* *readtable*)))
(with-local-readtable
- (set-macro-character #\, previous-reader-on-comma)
- (funcall previous-reader-on-backtick stream char))
- (simple-reader-error stream "No dispatched quasi-quote reader with name ~S" dispatched-quasi-quote-name)))
- (dispatching-toplevel-quasi-quote-reader (stream char)
- (assert dispatched?)
- (assert (char= start-character char))
- (if (or *dispatched-quasi-quote-name*
- (char-equal (elt (string dispatched-quasi-quote-name) 0)
- (peek-char nil stream t nil t)))
- (bind ((name (or *dispatched-quasi-quote-name*
- (read stream t nil t))))
- (if (or (eq name dispatched-quasi-quote-name)
- (string= (string-downcase name) (string-downcase dispatched-quasi-quote-name)))
- (bind ((*dispatched-quasi-quote-name* nil))
- ;; ok, we've got a match, read it in.
- (read-quasi-quote t stream))
- (bind ((*dispatched-quasi-quote-name* name))
- ;; FIXME this will do something horribly wrong for a `foo()
- ;; if there's no handler for it and the default reader is called.
- (read-using-original-reader stream char))))
- (read-using-original-reader stream char)))
- (read-quasi-quoted-body (stream)
- (if (and body-reader
- (not dispatched?))
- (funcall body-reader stream)
- (if end-character
- (with-local-readtable
- ;; we must set the syntax on the end char to be like #\)
- ;; until we read out our entire body. this is needed to
- ;; make "[... 5] style inputs work where '5' is not
- ;; separated from ']'.
- ;; doin this is not necessary when invoked from the nested reader
- ;; but doesn't hurt either. wastes some cycles, but...
- (set-syntax-from-char end-character #\) *readtable*)
- (read-delimited-list end-character stream t))
- (read stream t nil t))))
- (read-quasi-quote (dispatched? stream)
- (bind ((entering-readtable *readtable*)
- (entering-quasi-quote-nesting-level *quasi-quote-nesting-level*)
- (*quasi-quote-depth* (1+ *quasi-quote-depth*))
- (*quasi-quote-nesting-level* (1+ *quasi-quote-nesting-level*))
- (*toplevel-readtable* (or *toplevel-readtable* *readtable*)))
- (with-local-readtable
- (set-macro-character unquote-character (make-unquote-reader entering-quasi-quote-nesting-level entering-readtable))
- (bind ((original-sharp-dot-reader (get-dispatch-macro-character #\# #\.)))
- ;; make sure #. reader is called in the restored readtable-case.
- ;; TODO this should be generalized to wrap all the readers installed in the readtable? probably it's not worth the trouble...
- (set-dispatch-macro-character #\# #\. (lambda (&rest args)
- (with-local-readtable
- (setf (readtable-case *readtable*) (readtable-case *toplevel-readtable*))
- (apply original-sharp-dot-reader args)))))
- (when end-character
- ;; there's no point in handling nesting when we are installed on a pair of parens.
- ;; e.g. in <element <child>> child should not be qq wrapped... so, we enable a
- ;; special nested reader when we are installed on a pair of parens.
- (set-macro-character start-character (make-nested-quasi-quote-reader entering-quasi-quote-nesting-level)))
- (when readtable-case
- (setf (readtable-case *readtable*) readtable-case))
+ (set-macro-character unquote-character (make-unquote-reader entering-quasi-quote-nesting-level entering-readtable))
+ (bind ((original-sharp-dot-reader (get-dispatch-macro-character #\# #\.)))
+ ;; make sure #. reader is called in the restored readtable-case.
+ ;; TODO this should be generalized to wrap all the readers installed in the readtable? probably it's not worth the trouble...
+ (set-dispatch-macro-character #\# #\. (lambda (&rest args)
+ (with-local-readtable
+ (setf (readtable-case *readtable*) (readtable-case *toplevel-readtable*))
+ (apply original-sharp-dot-reader args)))))
+ (when end-character
+ ;; there's no point in handling nesting when we are installed on a pair of parens.
+ ;; e.g. in <element <child>> child should not be qq wrapped... so, we enable a
+ ;; special nested reader when we are installed on a pair of parens.
+ (set-macro-character start-character (make-nested-quasi-quote-reader entering-quasi-quote-nesting-level)))
+ (when readtable-case
+ (setf (readtable-case *readtable*) readtable-case))
+ (bind ((body (read-quasi-quoted-body stream)))
+ (if (functionp quasi-quote-wrapper)
+ (funcall quasi-quote-wrapper body dispatched?)
+ (list quasi-quote-wrapper body))))))
+ (make-nested-quasi-quote-reader (entering-quasi-quote-nesting-level)
+ (named-lambda nested-quasi-quote-reader (stream char)
+ (declare (ignore char))
+ (log "NESTED-QUASI-QUOTE-READER entering")
+ (assert (>= *quasi-quote-nesting-level* entering-quasi-quote-nesting-level))
(bind ((body (read-quasi-quoted-body stream)))
- (if (functionp quasi-quote-wrapper)
- (funcall quasi-quote-wrapper body dispatched?)
- (list quasi-quote-wrapper body))))))
- (make-nested-quasi-quote-reader (entering-quasi-quote-nesting-level)
- (named-lambda nested-quasi-quote-reader (stream char)
- (declare (ignore char))
- (assert (>= *quasi-quote-nesting-level* entering-quasi-quote-nesting-level))
- (bind ((body (read-quasi-quoted-body stream)))
- (if (functionp nested-quasi-quote-wrapper)
- (funcall nested-quasi-quote-wrapper body dispatched?)
- (list nested-quasi-quote-wrapper body)))))
- (make-unquote-reader (entering-quasi-quote-nesting-level entering-readtable)
- (named-lambda unquote-reader (stream char)
- (declare (ignore char))
- (with-local-readtable ; this is only needed when actually restoring the original readers, but then it's needed inside the recursive READ call down at the end, so wrap it all up with a copy
- (bind ((*quasi-quote-nesting-level* (1- *quasi-quote-nesting-level*))
- (modifier (switch ((peek-char nil stream t nil t) :test 'char=)
- (splice-character :splice)
- (destructive-splice-character :destructive-splice))))
- (when modifier
- (read-char stream t nil t))
- (assert (>= *quasi-quote-nesting-level* entering-quasi-quote-nesting-level))
- (when (= *quasi-quote-nesting-level* entering-quasi-quote-nesting-level)
- ;;; restore the original readers when we are leaving our nesting. this way it's possible
- ;;; to use the ` and , in their previous meanings when being outside our own nesting levels.
- ;;; we don't restore the reader on the end character, if there was any, because that
- ;;; would break things like [a ,b] due to a #\] being nonterminating by default.
- (when unquote-readtable-case
- (ecase unquote-readtable-case
- ((:upcase :downcase :preserve)
- (setf (readtable-case *readtable*) unquote-readtable-case))
- (:parent
- (setf (readtable-case *readtable*) (readtable-case entering-readtable)))
- (:toplevel
- (setf (readtable-case *readtable*) (readtable-case *toplevel-readtable*)))))
- (apply 'set-macro-character unquote-character (multiple-value-list (get-macro-character* unquote-character entering-readtable)))
- (when end-character
- (set-macro-character start-character (funcall toplevel-reader-wrapper #'toplevel-quasi-quote-reader))))
- (bind ((body (read stream t nil t)))
- (if (functionp unquote-wrapper)
- (funcall unquote-wrapper body modifier)
- (list unquote-wrapper body modifier))))))))
- (funcall toplevel-reader-wrapper
- (if dispatched?
- #'dispatching-toplevel-quasi-quote-reader
- #'toplevel-quasi-quote-reader)))))
+ (if (functionp nested-quasi-quote-wrapper)
+ (funcall nested-quasi-quote-wrapper body dispatched?)
+ (list nested-quasi-quote-wrapper body)))))
+ (make-unquote-reader (entering-quasi-quote-nesting-level entering-readtable)
+ (named-lambda unquote-reader (stream char)
+ (declare (ignore char))
+ (log "UNQUOTE-READER entering, *quasi-quote-nesting-level* ~A, entering-quasi-quote-nesting-level ~A"
+ *quasi-quote-nesting-level* entering-quasi-quote-nesting-level)
+ (with-local-readtable ; this is only needed when actually restoring the original readers, but then it's needed inside the recursive READ call down at the end, so wrap it all up with a copy
+ (bind ((*quasi-quote-nesting-level* (1- *quasi-quote-nesting-level*))
+ (modifier (switch ((peek-char nil stream t nil t) :test 'char=)
+ (splice-character :splice)
+ (destructive-splice-character :destructive-splice))))
+ (when modifier
+ (read-char stream t nil t))
+ (assert (>= *quasi-quote-nesting-level* entering-quasi-quote-nesting-level))
+ (when (= *quasi-quote-nesting-level* entering-quasi-quote-nesting-level)
+ ;; restore the original readers when we are leaving our nesting. this way it's possible
+ ;; to use the ` and , in their previous meanings when being outside our own nesting levels.
+ ;; we don't restore the reader on the end character, if there was any, because that
+ ;; would break things like [a ,b] due to a #\] being nonterminating by default.
+ (when unquote-readtable-case
+ (ecase unquote-readtable-case
+ ((:upcase :downcase :preserve)
+ (setf (readtable-case *readtable*) unquote-readtable-case))
+ (:parent
+ (setf (readtable-case *readtable*) (readtable-case entering-readtable)))
+ (:toplevel
+ (setf (readtable-case *readtable*) (readtable-case *toplevel-readtable*)))))
+ (log "UNQUOTE-READER restoring original reader on the unquote char ~S, it is ~A" unquote-character (get-macro-character* unquote-character entering-readtable))
+ (apply 'set-macro-character unquote-character (multiple-value-list (get-macro-character* unquote-character entering-readtable)))
+ (when end-character
+ (set-macro-character start-character (funcall toplevel-reader-wrapper #'toplevel-quasi-quote-reader))))
+ (log "UNQUOTE-READER calling READ")
+ (bind ((body (read stream t nil t)))
+ (if (functionp unquote-wrapper)
+ (funcall unquote-wrapper body modifier)
+ (list unquote-wrapper body modifier))))))))
+ (funcall toplevel-reader-wrapper
+ (if dispatched?
+ #'dispatching-toplevel-quasi-quote-reader
+ #'toplevel-quasi-quote-reader))))))
Warning: CRC errors found. These are probably harmless but should be repaired.
See 'darcs gzcrcs --help' for more information.