From 9911ed42e9e156a15ca6d9ad32bd7345ab7e0486 Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Thu, 28 Sep 2023 08:21:23 -0400 Subject: [PATCH] Clasp updates --- code/dispatch.lisp | 41 ++++++++++++----------------------------- code/interface.lisp | 1 - code/packages.lisp | 1 - code/types.lisp | 37 +++++++++++++++---------------------- 4 files changed, 27 insertions(+), 53 deletions(-) diff --git a/code/dispatch.lisp b/code/dispatch.lisp index e25c1f0..5c9c515 100644 --- a/code/dispatch.lisp +++ b/code/dispatch.lisp @@ -195,30 +195,34 @@ ((cons (member progv)) -20 pprint-progv) - #+(or clisp ecl mezzano sbcl) - ((cons (member #+clisp system::backquote + #+(or clasp clisp ecl mezzano sbcl) + ((cons (member #+clasp ext:quasiquote + #+clisp system::backquote #+ecl si:quasiquote #+mezzano mezzano.internals::backquote #+sbcl sb-int:quasiquote) (cons t null)) -20 pprint-macro-char t nil #\`) - #+(or clisp ecl mezzano) - ((cons (member #+clisp system::unquote + #+(or clasp clisp ecl mezzano) + ((cons (member #+clasp ext:unquote + #+clisp system::unquote #+ecl si:unquote #+mezzano mezzano.internals::bq-comma) (cons t null)) -20 pprint-macro-char t t #\,) - #+(or clisp ecl mezzano) - ((cons (member #+clisp system::splice + #+(or clasp clisp ecl mezzano) + ((cons (member #+clasp ext:unquote-splice + #+clisp system::splice #+ecl si:unquote-splice #+mezzano mezzano.internals::bq-comma-atsign) (cons t null)) -20 pprint-macro-char t t #\, #\@) - #+(or clisp ecl mezzano) - ((cons (member #+clisp system::nsplice + #+(or clasp clisp ecl mezzano) + ((cons (member #+clasp ext:unquote-nsplice + #+clisp system::nsplice #+ecl si:unquote-nsplice #+mezzano mezzano.internals::bq-comma-dot) (cons t null)) @@ -286,33 +290,12 @@ -10 pprint-symbol))) -(defvar +quasiquote-entries+ - #-clasp nil - #+clasp - '(("ECLECTOR.READER" "QUASIQUOTE" - -20 - pprint-macro-char t nil #\`) - ("ECLECTOR.READER" "UNQUOTE" - -20 - pprint-macro-char t t #\,) - ("ECLECTOR.READER" "UNQUOTE-SPLICING" - -20 - pprint-macro-char t t #\, #\@))) - (defmethod copy-pprint-dispatch (client (table null) &optional read-only) (declare (ignore table)) (let ((new-table (make-instance 'dispatch-table :default-dispatch-function (make-dispatch-function client :client-object-stream #'incless:print-object nil)))) (loop for (type priority name . rest) in +initial-dispatch-entries+ do (set-pprint-dispatch client new-table type (fdefinition name) priority :client-stream-object rest)) - (loop for (package symbol priority name . rest) in +quasiquote-entries+ - for pkg = (find-package package) - for sym = (when pkg - (find-symbol symbol pkg)) - when sym - do (set-pprint-dispatch client new-table - `(cons (member ,sym) (cons t null)) - (fdefinition name) priority :client-stream-object rest)) (when read-only (setf (dispatch-table-read-only-p new-table) t)) new-table)) diff --git a/code/interface.lisp b/code/interface.lisp index 3b53453..478a1ef 100644 --- a/code/interface.lisp +++ b/code/interface.lisp @@ -241,7 +241,6 @@ block, obeying *print-length* and *print-circle*." (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK.")) (defun ,initialize-func (&aux *print-pretty*) - (find-unquote-symbols) (setf ,initial-pprint-dispatch-var (copy-pprint-dispatch ,client-var nil t) ,standard-pprint-dispatch-var (copy-pprint-dispatch ,client-var nil t) ,print-pprint-dispatch-var (copy-pprint-dispatch ,client-var nil)) diff --git a/code/packages.lisp b/code/packages.lisp index f29a21f..b503001 100644 --- a/code/packages.lisp +++ b/code/packages.lisp @@ -22,7 +22,6 @@ #:define-interface #:execute-logical-block #:expand-logical-block - #:find-unquote-symbols #:get-named-style #:make-dispatch-function #:make-pretty-stream diff --git a/code/types.lisp b/code/types.lisp index 3179160..5500304 100644 --- a/code/types.lisp +++ b/code/types.lisp @@ -43,27 +43,20 @@ (and (member kind '(:line-relative :section-relative)) t)) -(defvar +unquote-symbols+ nil) - -(defun find-unquote-symbols () - (setf +unquote-symbols+ - (loop for (package symbol) in #+clasp '(("ECLECTOR.READER" "UNQUOTE") - ("ECLECTOR.READER" "UNQUOTE-SPLICING")) - #+ecl '(("SI" "UNQUOTE") - ("SI" "UNQUOTE-SPLICE") - ("SI" "UNQUOTE-NSPLICE")) - #-(or clasp ecl) nil - for pkg = (find-package package) - for sym = (when pkg - (find-symbol symbol pkg)) - when sym - collect sym))) - -(find-unquote-symbols) +(deftype unquote-form () + '(cons (member #+clasp ext:unquote + #+clasp ext:unquote-splice + #+clasp ext:unquote-nsplice + #+clisp system::unquote + #+clisp system::splice + #+clisp system::nsplice + #+ecl si:unquote + #+ecl si:unquote-splice + #+ecl si:unquote-nsplice + #+mezzano mezzano.internals::bq-comma + #+mezzano mezzano.internals::bq-comma-atsign + #+mezzano mezzano.internals::bq-comma-dot) + (cons t null))) (defun unquote-form-p (form) - (and (consp form) - (consp (cdr form)) - (null (cddr form)) - (member (car form) +unquote-symbols+) - t)) + (typep form 'unquote-form))