diff --git a/src/org/armedbear/lisp/compile-system.lisp b/src/org/armedbear/lisp/compile-system.lisp index 142e22933..30b763be0 100644 --- a/src/org/armedbear/lisp/compile-system.lisp +++ b/src/org/armedbear/lisp/compile-system.lisp @@ -312,6 +312,7 @@ (load (do-compile "print.lisp")) (load (do-compile "pprint-dispatch.lisp")) (load (do-compile "pprint.lisp")) + (load (do-compile "pprint-backquote.lisp")) (load (do-compile "format.lisp")) (load (do-compile "delete.lisp")) (load (do-compile "concatenate.lisp")) diff --git a/src/org/armedbear/lisp/pprint-backquote.lisp b/src/org/armedbear/lisp/pprint-backquote.lisp new file mode 100644 index 000000000..e043fb6e4 --- /dev/null +++ b/src/org/armedbear/lisp/pprint-backquote.lisp @@ -0,0 +1,121 @@ +;;;; pretty-printing of backquote expansions + +;;;; This file is part of ABCL, adapted from SBCL + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which 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. See the COPYING and CREDITS +;;;; files for more information. + + +(in-package :xp) + +(defvar *backq-tokens* + '(backq-comma backq-comma-at backq-comma-dot sys::backq-list + sys::backq-list* sys::backq-append sys::backq-nconc sys::backq-cons sys::backq-vector)) + +(defstruct (backq-comma (:constructor make-backq-comma (form)) + (:copier nil) (:predicate nil)) + form) +(defstruct (backq-comma-at (:include backq-comma) + (:constructor make-backq-comma-at (form)) + (:copier nil) (:predicate nil))) + +(defstruct (backq-comma-dot (:include backq-comma) + (:constructor make-backq-comma-dot (form)))) + + +(defun backq-unparse-expr (form splicing) + (ecase splicing + ((nil) (make-backq-comma form)) + ((t) `(,(make-backq-comma-at form))) + (:nconc `(,(make-backq-comma-dot form))))) + +(defun backq-unparse (form &optional splicing) + "Given a lisp form containing the magic functions BACKQ-LIST, BACKQ-LIST*, + BACKQ-APPEND, etc. produced by the backquote reader macro, will return a + corresponding backquote input form. In this form, `,' `,@' and `,.' are + represented by structures of type BACKQ-COMMA, BACKQ-COMMA-AT, and + BACKQ-COMMA-DOT respectively. + SPLICING indicates whether a comma-escape return should be modified for + splicing with other forms: a value of T or :NCONC meaning that an extra + level of parentheses should be added." + (cond + ((null form) nil) + ((atom form) + (backq-unparse-expr form splicing)) + ((not (null (cdr (last form)))) + ;; FIXME: this probably throws a recursive error + (bug "found illegal dotted backquote form: ~S" form)) + (t + (case (car form) + (sys::backq-list + (mapcar #'backq-unparse (cdr form))) + (sys::backq-list* + (do ((tail (cdr form) (cdr tail)) + (accum nil)) + ((null (cdr tail)) + (nconc (nreverse accum) + (backq-unparse (car tail) t))) + (push (backq-unparse (car tail)) accum))) + (sys::backq-append + (apply #'append + (mapcar (lambda (el) (backq-unparse el t)) + (cdr form)))) + (sys::backq-nconc + (apply #'append + (mapcar (lambda (el) (backq-unparse el :nconc)) + (cdr form)))) + (sys::backq-cons + (cons (backq-unparse (cadr form) nil) + (backq-unparse (caddr form) t))) + (sys::backq-vector + ;; The special-case of empty vector isn't technically necessary, + ;; but avoids the valid though ugly result "`#(,@NIL)" + (let ((it (cadr form))) + (cond (it (coerce (backq-unparse it t) 'vector)) + (t #())))) + (quote + ;; FIXME: This naively assumes that the form is exactly (QUOTE x). + ;; Therefore (QUOTE . x) and (QUOTE x y z*) will lose. + (let ((thing (cadr form))) + (cond ((atom thing) + (if (typep thing 'backq-comma) + (backq-unparse-expr form splicing) + thing)) + ((member (car thing) *backq-tokens*) + (backq-unparse-expr form splicing)) + (t + (cons (backq-unparse `(quote ,(car thing))) + (backq-unparse `(quote ,(cdr thing)))))))) + (t + (backq-unparse-expr form splicing)))))) + +(defun pprint-backquote (stream form &rest noise) + (declare (ignore noise)) + (write-char #\` stream) + (write (backq-unparse form) :stream stream)) + +(defun pprint-backq-comma (stream thing &rest noise) + (declare (ignore noise) (backq-comma thing)) + (etypecase thing + (backq-comma-at + (write-string ",@" stream)) + (backq-comma-dot + (write-string ",." stream)) + (backq-comma + (write-char #\, stream) +#-abcl (setf (sb!pretty::pretty-stream-char-out-oneshot-hook stream) + (lambda (stream char) + ;; Ensure a space is written before any output that would + ;; erroneously be interpreted as a splicing frob on readback. + (when (or (char= char #\.) (char= char #\@)) + (write-char #\Space stream)))) + + )) + (write (backq-comma-form thing) :stream stream)) + diff --git a/src/org/armedbear/lisp/pprint-dispatch.lisp b/src/org/armedbear/lisp/pprint-dispatch.lisp index e98e8dcf6..537b1710f 100644 --- a/src/org/armedbear/lisp/pprint-dispatch.lisp +++ b/src/org/armedbear/lisp/pprint-dispatch.lisp @@ -313,6 +313,15 @@ (set-pprint-dispatch+ '(cons (member with-open-stream)) 'block-like '(0) *ipd*) (set-pprint-dispatch+ '(cons (member with-output-to-string)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (eql sys::backq-list)) 'pprint-backquote '(0) *ipd*) +(set-pprint-dispatch+ '(cons (eql sys::backq-list*)) 'pprint-backquote '(0) *ipd*) +(set-pprint-dispatch+ '(cons (eql sys::backq-append)) 'pprint-backquote '(0) *ipd*) +(set-pprint-dispatch+ '(cons (eql sys::backq-nconc)) 'pprint-backquote '(0) *ipd*) +(set-pprint-dispatch+ '(cons (eql sys::backq-cons)) 'pprint-backquote '(0) *ipd*) +(set-pprint-dispatch+ '(cons (eql sys::backq-vector)) 'pprint-backquote '(0) *ipd*) +(set-pprint-dispatch+ 'backq-comma 'pprint-backq-comma '(0) *ipd*) + + (defun pprint-dispatch-print (xp table) (let ((stuff (copy-list (others table)))) (maphash #'(lambda (key val) (declare (ignore key)) @@ -336,4 +345,4 @@ (setf *print-pprint-dispatch* (copy-pprint-dispatch nil)) -(provide "PPRINT-DISPATCH") \ No newline at end of file +(provide "PPRINT-DISPATCH")