Start migration toward ~/ friendly interface

code/dispatch.lisp

@@ -23,39 +23,23 @@
              :initform 0
              :type real)))
 
-(defun cons-names (type-specifier)
+(defun cons-eql-specifier-p (type-specifier)
   (and (consp type-specifier)
        (eql 'cons (first type-specifier))
        (consp (cdr type-specifier))
        (consp (cadr type-specifier))
-       (member (caadr type-specifier) '(eql member))
-       (cdadr type-specifier)))
+       (member (caadr type-specifier) '(eql member))))
 
 (defun make-test-function (type-specifier)
-  (if (or (not (listp type-specifier))
-          (not (equal 'cons (car type-specifier))))
-      (lambda (object)
-        (typep object type-specifier))
-      (let* ((car-type (second type-specifier))
-             (cdr-type (third type-specifier))
-             (cons-type-p (and (consp car-type)
-                               (member (car car-type) '(eql member)))))
-        (cond ((and cons-type-p cdr-type)
-               (lambda (object)
-                 (typep object cdr-type)))
-              (cons-type-p
-               (lambda (object)
-                 (declare (ignore object))
-                 t))
-              (cdr-type
-               (lambda (object)
-                 (and (consp object)
-                      (typep (car object) car-type)
-                      (typep (cdr object) cdr-type))))
-              (t
-               (lambda (object)
-                 (and (consp object)
-                      (typep (car object) cdr-type))))))))
+  (cond ((not (cons-eql-specifier-p type-specifier))
+         (lambda (object)
+           (typep object type-specifier)))
+        ((or (null (cddr type-specifier))
+             (eq t (third type-specifier)))
+         (constantly t))
+        (t
+         (lambda (object)
+           (typep object (third type-specifier))))))
 
 (defclass dispatch-table ()
   ((entries :accessor dispatch-table-entries
@@ -130,7 +114,7 @@
                    deftype
                    defun))
      -20
-     pprint-defun)
+     pprint-defun t nil)
     ((cons (member do
                    do*))
      -20
@@ -315,7 +299,7 @@
      -20
      pprint-macro-char t t #\, #\@)))
 
-(defmethod copy-pprint-dispatch (client (table (eql nil)) &optional read-only)
+(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))))
@@ -333,6 +317,17 @@
       (setf (dispatch-table-read-only-p new-table) t))
     new-table))
 
+(defmethod copy-pprint-dispatch (client (table (eql :empty)) &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))))
+    (when read-only
+      (setf (dispatch-table-read-only-p new-table) t))
+    new-table))
+
 (defmethod copy-pprint-dispatch (client (table (eql t)) &optional read-only)
   (declare (ignore table))
   (let ((new-table (make-instance 'dispatch-table
@@ -395,14 +390,15 @@
                                                :key #'dispatch-entry-type-specifier :test #'equal)
         (dispatch-table-non-cons-entries table) (delete type-specifier (dispatch-table-non-cons-entries table)
                                                         :key #'dispatch-entry-type-specifier :test #'equal))
-  (loop with cons-entries = (dispatch-table-cons-entries table)
-        for name in (cons-names type-specifier)
-        for entries = (delete type-specifier (gethash name cons-entries)
-                              :key #'dispatch-entry-type-specifier :test #'equal)
-        if entries
-          do (setf (gethash name cons-entries) entries)
-        else
-          do (remhash name cons-entries))
+  (when (cons-eql-specifier-p type-specifier)
+    (loop with cons-entries = (dispatch-table-cons-entries table)
+          for name in (cdadr type-specifier)
+          for entries = (delete type-specifier (gethash name cons-entries)
+                                :key #'dispatch-entry-type-specifier :test #'equal)
+          if entries
+            do (setf (gethash name cons-entries) entries)
+          else
+            do (remhash name cons-entries)))
   nil)
 
 (defmethod set-pprint-dispatch (client (table dispatch-table) type-specifier function &optional priority pattern arguments)
@@ -415,13 +411,12 @@
                               :dispatch-function (make-dispatch-function client (or pattern :stream-object) function arguments)
                               :priority (or priority 0)
                               :pattern (or pattern :stream-object)
-                              :arguments arguments))
-        (names (cons-names type-specifier)))
+                              :arguments arguments)))
     (setf (dispatch-table-entries table) (sort (cons entry (dispatch-table-entries table))
                                                #'> :key #'dispatch-entry-priority))
-    (if names
+    (if (cons-eql-specifier-p type-specifier)
         (loop with cons-entries = (dispatch-table-cons-entries table)
-              for name in names
+              for name in (cdadr type-specifier)
               do (setf (gethash name cons-entries) (sort (cons entry (gethash name cons-entries))
                                                          #'> :key #'dispatch-entry-priority)))
         (setf (dispatch-table-non-cons-entries table) (sort (cons entry (dispatch-table-non-cons-entries table))
@@ -441,5 +436,3 @@
                     (dispatch-entry-pattern entry)
                     (dispatch-entry-arguments entry)))
           (values nil nil nil nil nil nil)))))
-
-

code/extrinsic/packages.lisp

@@ -20,6 +20,8 @@
            #:*standard-pprint-dispatch*
            #:copy-pprint-dispatch
            #:intrinsic-client
+           #:pprint-bindings
+           #:pprint-defun
            #:pprint-dispatch
            #:pprint-exit-if-list-exhausted
            #:pprint-fill

code/form-printers.lisp

@@ -34,13 +34,15 @@
         do (pop lambda-list)
         finally (return (values patterns nil))))
 
-(defmacro pprint-body-form ((client stream object) &body body)
-  `(pprint-list (,client ,stream ,object :paren t :newline :linear)
-     ,@body
-     (pprint-exit-if-list-exhausted)
-     (pprint-indent ,client ,stream :block 1)
-     (write-char #\Space ,stream)
-     (pprint-newline ,client ,stream :linear)))
+(defmacro pprint-body-form ((client stream object &key paren newline) &body body)
+  (let ((newline-var (gensym)))
+    `(let ((,newline-var (or ,newline :linear)))
+       (pprint-list (,client ,stream ,object :paren ,paren :newline ,newline-var)
+         ,@body
+         (pprint-exit-if-list-exhausted)
+         (pprint-indent ,client ,stream :block 1)
+         (write-char #\Space ,stream)
+         (pprint-newline ,client ,stream ,newline-var)))))
 
 (defmacro pprint-tagbody-form ((client stream object) &body body)
   `(pprint-format-logical-block (,client ,stream ,object :paren t)
@@ -64,14 +66,14 @@
               (write-char #\Space ,stream)
               (pprint-newline ,client ,stream (or ,newline :fill)))))
 
-(defmethod pprint-bindings (client stream object &rest options &key &allow-other-keys)
-  (declare (ignore options))
-  (pprint-format-logical-block (client stream object :paren t)
+(defmethod pprint-bindings (client stream object &optional colon-p at-sign-p)
+  (pprint-format-logical-block (client stream object :paren colon-p)
     (pprint-exit-if-list-exhausted)
-    (loop do (pprint-fill client stream (pprint-pop) t nil)
+    (loop with newline = (if at-sign-p :fill :linear)
+          do (pprint-fill client stream (pprint-pop) t nil)
              (pprint-exit-if-list-exhausted)
              (write-char #\Space stream)
-             (pprint-newline client stream :linear))))
+             (pprint-newline client stream newline))))
 
 (defun pprint-defpackage (client stream object &rest options &key &allow-other-keys)
   (declare (ignore options))
@@ -89,9 +91,8 @@
           (pprint-newline client stream :linear)
           (pprint-function-call client stream (pprint-pop) :newline :linear))))
 
-(defun pprint-defun (client stream object &rest options &key &allow-other-keys)
-  (declare (ignore options))
-  (pprint-body-form (client stream object)
+(defmethod pprint-defun (client stream object &optional colon-p at-sign-p)
+  (pprint-body-form (client stream object :paren colon-p :newline (if at-sign-p :fill :linear))
     (pprint-exit-if-list-exhausted)
     (incless:write-object client (pprint-pop) stream)
     (pprint-exit-if-list-exhausted)
@@ -105,7 +106,7 @@
     (pprint-lambda-list client stream (pprint-pop))))
 
 (defun pprint-destructuring-bind (client stream object)
-  (pprint-body-form (client stream object)
+  (pprint-body-form (client stream object :paren t)
     (pprint-exit-if-list-exhausted)
     (incless:write-object client (pprint-pop) stream)
     (pprint-exit-if-list-exhausted)
@@ -119,7 +120,7 @@
     (incless:write-object client (pprint-pop) stream)))
 
 (defun pprint-defmethod-with-qualifier (client stream object)
-  (pprint-body-form (client stream object)
+  (pprint-body-form (client stream object :paren t)
     (pprint-exit-if-list-exhausted)
     (incless:write-object client (pprint-pop) stream)
     (pprint-exit-if-list-exhausted)
@@ -143,7 +144,7 @@
     (write-char #\Space stream)
     (pprint-indent client stream :current 0)
     (pprint-newline client stream :miser)
-    (pprint-bindings client stream (pprint-pop))
+    (pprint-bindings client stream (pprint-pop) t)
     (pprint-exit-if-list-exhausted)
     (write-char #\Space stream)
     (pprint-newline client stream :linear)
@@ -160,7 +161,7 @@
     (pprint-fill client stream (pprint-pop) t nil)))
 
 (defun pprint-eval-when (client stream object)
-  (pprint-body-form (client stream object)
+  (pprint-body-form (client stream object :paren t)
     (pprint-exit-if-list-exhausted)
     (incless:write-object client (pprint-pop) stream)
     (pprint-exit-if-list-exhausted)
@@ -170,14 +171,14 @@
     (pprint-fill client stream (pprint-pop) t nil)))
 
 (defun pprint-let (client stream object)
-  (pprint-body-form (client stream object)
+  (pprint-body-form (client stream object :paren t)
     (pprint-exit-if-list-exhausted)
     (incless:write-object client (pprint-pop) stream)
     (pprint-exit-if-list-exhausted)
     (write-char #\Space stream)
     (pprint-indent client stream :block 3)
     (pprint-newline client stream :miser)
-    (pprint-bindings client stream (pprint-pop))))
+    (pprint-bindings client stream (pprint-pop) t)))
 
 (defun pprint-prog (client stream object)
   (pprint-tagbody-form (client stream object)
@@ -187,10 +188,10 @@
     (write-char #\Space stream)
     (pprint-indent client stream :current 0)
     (pprint-newline client stream :miser)
-    (pprint-bindings client stream (pprint-pop))))
+    (pprint-bindings client stream (pprint-pop) t)))
 
 (defun pprint-prog1 (client stream object)
-  (pprint-body-form (client stream object)
+  (pprint-body-form (client stream object :paren t)
     (pprint-exit-if-list-exhausted)
     (incless:write-object client (pprint-pop) stream)
     (pprint-exit-if-list-exhausted)
@@ -200,7 +201,7 @@
     (incless:write-object client (pprint-pop) stream)))
 
 (defun pprint-prog2 (client stream object)
-  (pprint-body-form (client stream object)
+  (pprint-body-form (client stream object :paren t)
     (pprint-exit-if-list-exhausted)
     (incless:write-object client (pprint-pop) stream)
     (pprint-exit-if-list-exhausted)
@@ -214,12 +215,12 @@
     (incless:write-object client (pprint-pop) stream)))
 
 (defun pprint-progn (client stream object)
-  (pprint-body-form (client stream object)
+  (pprint-body-form (client stream object :paren t)
     (pprint-exit-if-list-exhausted)
     (incless:write-object client (pprint-pop) stream)))
 
 (defun pprint-progv (client stream object)
-  (pprint-body-form (client stream object)
+  (pprint-body-form (client stream object :paren t)
     (pprint-exit-if-list-exhausted)
     (incless:write-object client (pprint-pop) stream)
     (pprint-exit-if-list-exhausted)
@@ -250,7 +251,7 @@
   (pprint-function-call-form (client stream object :argument-count argument-count :newline newline)))
 
 (defun pprint-with (client stream object &key argument-count newline)
-  (pprint-body-form (client stream object)
+  (pprint-body-form (client stream object :paren t)
     (pprint-exit-if-list-exhausted)
     (incless:write-object client (pprint-pop) stream)
     (pprint-exit-if-list-exhausted)
@@ -301,7 +302,8 @@
                 (:required
                  (pprint-lambda-list client stream arg))
                 ((:optional :key)
-                 (pprint-format-logical-block (client stream arg :paren t)
+                 (pprint-fill client stream arg t)
+                 #+(or)(pprint-format-logical-block (client stream arg :paren t)
                    (pprint-exit-if-list-exhausted)
                    (if (eq state :key)
                        (pprint-format-logical-block (client stream (pprint-pop) :paren t)
@@ -390,7 +392,7 @@
 
 (defun pprint-loop (client stream object)
   (if (consp (second object))
-      (pprint-list (client stream object :paren t :newline :mandatory)
+      (pprint-list (client stream object :paren t :newline :linear)
         (pprint-exit-if-list-exhausted)
         (incless:write-object client (pprint-pop) stream)
         (pprint-exit-if-list-exhausted)
@@ -486,7 +488,7 @@
          (incless:write-object client (aref object) stream))))
 
 (defun pprint-lambda (client stream object)
-  (pprint-body-form (client stream object)
+  (pprint-body-form (client stream object :paren t)
     (pprint-exit-if-list-exhausted)
     (incless:write-object client (pprint-pop) stream)
     (pprint-exit-if-list-exhausted)
@@ -543,7 +545,7 @@
           (pprint-newline client stream :mandatory))))
 
 (defun pprint-flet (client stream object)
-  (pprint-body-form (client stream object)
+  (pprint-body-form (client stream object :paren t)
     (pprint-exit-if-list-exhausted)
     (incless:write-object client (pprint-pop) stream)
     (pprint-exit-if-list-exhausted)
@@ -571,7 +573,7 @@
               (parse-lambda-list (lambda-list (first object)))
             (case terminator
               (&body
-               (pprint-body-form (client stream object)
+               (pprint-body-form (client stream object :paren t)
                  (pprint-exit-if-list-exhausted)
                  (incless:write-object client (pprint-pop) stream)
                  (pprint-exit-if-list-exhausted)
@@ -688,7 +690,7 @@
 
 (defun pprint-symbol-macrolet (client stream object &rest options &key &allow-other-keys)
   (declare (ignore options))
-  (pprint-body-form (client stream object)
+  (pprint-body-form (client stream object :paren t)
     (pprint-exit-if-list-exhausted)
     (incless:write-object client (pprint-pop) stream)
     (pprint-exit-if-list-exhausted)

code/interface.lisp

@@ -107,7 +107,9 @@
 
 (defgeneric normalize-text (client stream text))
 
-(defgeneric pprint-bindings (client stream object &rest options &key &allow-other-keys))
+(defgeneric pprint-bindings (client stream object &optional colon-p at-sign-p))
+
+(defgeneric pprint-defun (client stream object &optional colon-p at-sign-p))
 
 (defgeneric pprint-function-call (client stream object &rest options &key &allow-other-keys))
 
@@ -189,6 +191,14 @@
          (pprint-tabular ,client-var (coerce-output-stream-designator stream)
                                   object colon-p at-sign-p tabsize)
          nil)
+       (defun ,(intern "PPRINT-BINDINGS") (stream object &optional (colon-p t) at-sign-p)
+         (pprint-bindings ,client-var (coerce-output-stream-designator stream)
+                                   object colon-p at-sign-p)
+         nil)
+       (defun ,(intern "PPRINT-DEFUN") (stream object &optional (colon-p t) at-sign-p)
+         (pprint-defun ,client-var (coerce-output-stream-designator stream)
+                                   object colon-p at-sign-p)
+         nil)
        (defun ,(intern "PPRINT-INDENT" intrinsic-pkg) (relative-to n &optional stream)
          (check-type relative-to (member :block :current))
          (pprint-indent ,client-var (coerce-output-stream-designator stream)

code/intrinsic/packages.lisp

@@ -4,5 +4,7 @@
            #:*standard-pprint-dispatch*
            #:initialize
            #:intrinsic-client
+           #:pprint-bindings
+           #:pprint-defun
            #:pprint-macro-char
            #:pretty-stream-p))