Commit 38c9768f by Francois-Rene Rideau

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

parent c0fdb3ad
......@@ -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")))
......@@ -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.
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
;;;; 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
`(unquote ,form))
`((unquote-splicing ,form)))
`((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."
((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))
(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)
((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)))))))
(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)
(write-char #\, stream))
(write-string ",@" stream))
(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))
......@@ -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)
(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))))
((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)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment