Add pretty-printer for quasiquote, from SBCL. Tweaks.

diff --git a/fare-matcher.asd b/fare-matcher.asd
index 7403197..2fb97ac 100644 (file)
--- a/fare-matcher.asd
+++ b/fare-matcher.asd
@@ -8,6 +8,7 @@
               (:file "matcher")
               #-gcl ; it currently fails. quasiquote necessitates a big revamp anyway
                (:file "quasiquote")
+               (:file "pp-quasiquote")
                ;;#-gcl ; 2.7.0-64.1 cannot defgeneric in a eval-now
               (:file "clos-match")
               (:file "mrd-extensions")))

diff --git a/matcher.lisp b/matcher.lisp
index 820eea3..e855113 100644 (file)
--- a/matcher.lisp
+++ b/matcher.lisp
@@ -12,7 +12,7 @@ In case you want the latest version of the software, check the git repo at:
 This package depends on package fare-utils in neighbouring git repository.
 
 This software is released under the bugroff license. Use at your own risk.
-       http://www.geocities.com/SoHo/Cafe/5947/bugroff.html
+       http://tunes.org/legalese/bugroff.html
 At the insistence of several hackers, I hereby state what is obvious to me,
 that they can reuse any software released under the bugroff license
 and publish it as part or totality of packages under any other license

diff --git a/pp-quasiquote.lisp b/pp-quasiquote.lisp
new file mode 100644 (file)
index 0000000..0576d0b
--- /dev/null
+++ b/pp-quasiquote.lisp
@@ -0,0 +1,110 @@
+;;;; pretty-printing of backquote expansions
+
+;;;; This software is derived from the CMU CL system via SBCL.
+;;;; CMU CL was written at Carnegie Mellon University and released into
+;;;; the public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty.
+
+(in-package :fare-quasiquote)
+
+(defun unparse-quasiquote-1 (form splicing)
+  (ecase splicing
+    ((nil)
+     `(unquote ,form))
+    (:append
+     `((unquote-splicing ,form)))
+    (:nconc
+     `((unquote-nsplicing ,form)))
+    ))
+
+(defun unparse-quasiquote (form &optional splicing)
+  "Given a lisp form containing the magic functions LIST, LIST*,
+  APPEND, etc. produced by the backquote reader macro, will return a
+  corresponding backquote input form. In this form, `,' `,@' and `,.' are
+  represented by lists whose cars are UNQUOTE, UNQUOTE-SPLICING, and
+  UNQUOTE-NSPLICING respectively, and whose cadrs are the form after the comma.
+  SPLICING indicates whether a comma-escape return should be modified for
+  splicing with other forms: a value of :APPEND or :NCONC meaning that an extra
+  level of parentheses should be added."
+  (cond
+   ((atom form)
+    (unparse-quasiquote-1 form splicing))
+   ((not (null (cdr (last form))))
+    ;; FIXME: this probably throws a recursive error
+    (error "found illegal dotted quasiquote form: ~S" form))
+   (t
+    (case (car form)
+      ((list cl:list)
+       (mapcar #'unparse-quasiquote (cdr form)))
+      ((list* cl:list*)
+       (do ((tail (cdr form) (cdr tail))
+            (accum nil))
+           ((null (cdr tail))
+            (nconc (nreverse accum)
+                   (unparse-quasiquote (car tail) :append)))
+         (push (unparse-quasiquote (car tail)) accum)))
+      ((append cl:append)
+       (apply #'cl:append
+              (mapcar (lambda (el) (unparse-quasiquote el :append))
+                      (cdr form))))
+      ((nconc cl:nconc)
+       (apply #'cl:append
+              (mapcar (lambda (el) (unparse-quasiquote el :nconc))
+                      (cdr form))))
+      ((cons cl:cons)
+       (cl:cons (unparse-quasiquote (cadr form) nil)
+                (unparse-quasiquote (caddr form) :append)))
+      ((vector cl:vector)
+       (coerce (unparse-quasiquote (cadr form)) 'cl:vector))
+      ((quote cl:quote)
+       (cond
+         ((atom (cadr form)) (cadr form))
+         ((and (consp (cadr form))
+               (member (caadr form) *quasiquote-tokens*))
+          (unparse-quasiquote-1 form splicing))
+         (t (cons (unparse-quasiquote `(cl:quote ,(caadr form)))
+                  (unparse-quasiquote `(cl:quote ,(cdadr form)))))))
+      (t
+       (unparse-quasiquote-1 form splicing))))))
+
+(defun pprint-quasiquote (stream form &rest noise)
+  (declare (ignore noise))
+  (write-char #\` stream)
+  (write (unparse-quasiquote form) :stream stream))
+
+(defun pprint-unquote (stream form &rest noise)
+  (declare (ignore noise))
+  (ecase (car form)
+    ((unquote)
+     (write-char #\, stream))
+    ((unquote-splicing)
+     (write-string ",@" stream))
+    ((unquote-nsplicing)
+     (write-string ",." stream)))
+  (let ((output (with-output-to-string (s)
+                  (write (cadr form) :stream s
+                         :level (min 1 (or *print-level* 1))
+                         :length (min 1 (or *print-length* 1))))))
+    (unless (= (length output) 0)
+      (when (and (eql (car form) 'unquote)
+                 (or (char= (char output 0) #\.)
+                     (char= (char output 0) #\@)))
+        (write-char #\Space stream))
+      (write (cadr form) :stream stream))))
+
+;;; This is called by !PPRINT-COLD-INIT, fairly late, because
+;;; SET-PPRINT-DISPATCH doesn't work until the compiler works.
+;;;
+;;; FIXME: It might be cleaner to just make these be toplevel forms and
+;;; enforce the delay by putting this file late in the build sequence.
+(defun !backq-pp-cold-init ()
+  (set-pprint-dispatch '(cons (eql list)) #'pprint-quasiquote)
+  (set-pprint-dispatch '(cons (eql list*)) #'pprint-quasiquote)
+  (set-pprint-dispatch '(cons (eql append)) #'pprint-quasiquote)
+  (set-pprint-dispatch '(cons (eql nconc)) #'pprint-quasiquote)
+  (set-pprint-dispatch '(cons (eql cons)) #'pprint-quasiquote)
+  (set-pprint-dispatch '(cons (eql vector)) #'pprint-quasiquote)
+
+  (set-pprint-dispatch '(cons (eql unquote)) #'pprint-unquote)
+  (set-pprint-dispatch '(cons (eql unquote-splicing)) #'pprint-unquote)
+  (set-pprint-dispatch '(cons (eql unquote-nsplicing)) #'pprint-unquote))

diff --git a/quasiquote.lisp b/quasiquote.lisp
index 5f03cd7..9132269 100644 (file)
--- a/quasiquote.lisp
+++ b/quasiquote.lisp
@@ -25,6 +25,10 @@
  quote cl:quote
  vector cl:vector)
 
+(defvar *quasiquote-tokens*
+  '(unquote unquote-splicing unquote-splicing
+    list list* append nconc cons vector n-vector knil))
+
 (make-single-arg-form quote kwote)
 (make-single-arg-form quasiquote)
 (make-single-arg-form unquote)
@@ -56,17 +60,6 @@
   #-quasiquote-quotes-literals nil)
 );eval-when
 
-(defvar *comma* 'comma)
-(defvar *comma-atsign* 'comma-atsign)
-(defvar *comma-dot* 'comma-dot)
-(defvar *bq-list* 'list)
-(defvar *bq-append* 'append)
-(defvar *bq-list** 'list*)
-(defvar *bq-nconc* 'nconc)
-(defvar *bq-clobberable* 'clobberable)
-(defvar *bq-quote* 'quote)
-(defvar *bq-quote-nil* knil)
-
 (defparameter *quasiquote-level* 0
   "current depth of quasiquote nesting")
 (defparameter *simplify* t
@@ -106,7 +99,7 @@ When combining backquoted expressions, tokens are used for simplifications."
    ((vector-form-p x)
     (multiple-value-bind (top contents) (quasiquote-expand-0 (cdr x))
       (values 'vector (quasiquote-expand-1 top contents))))
-   #+quasiquote-at-macro-expansion-time
+   ;;#+quasiquote-at-macro-expansion-time
    ((simple-vector-p x)
     (values 'vector (quasiquote-expand (coerce x 'cl:list))))
    ((quasiquotep x)
@@ -230,7 +223,7 @@ of the result of the top operation applied to the expression"
 (defun self-evaluating-p (x)
   (or (literalp x)
       (not (or (symbolp x) (combinationp x)
-               #+quasiquote-at-macro-expansion-time (simple-vector-p x)
+               #|#+quasiquote-at-macro-expansion-time|# (simple-vector-p x)
               ))))
 (defun constant-form-p (x)
   (or #-quasiquote-quotes-literals (self-evaluating-p x)