Add define-interface and improve symbol quoting

s-expressionists · Oct 15, 2023 · 9f759be · 9f759be
1 parent c198fdf
commit 9f759be
Show file tree

Hide file tree

Showing 9 changed files with 178 additions and 279 deletions.
diff --git a/incless-extrinsic.asd b/incless-extrinsic.asd
@@ -11,8 +11,7 @@
                 :pathname "src/extrinsic/"
                 :serial t
                 :components ((:file "package")
-                             (:file "interface")
-                             (:file "print-object")))))
+                             (:file "interface")))))
 
 ;;; This is really a test of the whole printer suite. It's not
 ;;; really possible to test the printer without testing the

diff --git a/incless-intrinsic.asd b/incless-intrinsic.asd
@@ -10,5 +10,4 @@
                 :pathname "src/intrinsic/"
                 :serial t
                 :components ((:file "package")
-                             (:file "interface")
-                             (:file "print-object")))))
+                             (:file "interface")))))
diff --git a/src/extrinsic/interface.lisp b/src/extrinsic/interface.lisp
@@ -4,92 +4,4 @@
 
 (defvar *client* (make-instance 'extrinsic-client))
 
-(defmethod incless:client-form ((client extrinsic-client))
-  '*client*)
-
-(defgeneric print-object (object stream))
-
-(defun write
-    (object
-     &key (stream *standard-output*)
-          ((:array *print-array*) *print-array*)
-          ((:base *print-base*) *print-base*)
-          ((:case *print-case*) *print-case*)
-          ((:circle *print-circle*) *print-circle*)
-          ((:escape *print-escape*) *print-escape*)
-          ((:gensym *print-gensym*) *print-gensym*)
-          ((:length *print-length*) *print-length*)
-          ((:level *print-level*) *print-level*)
-          ((:lines *print-lines*) *print-lines*)
-          ((:miser-width *print-miser-width*) *print-miser-width*)
-          ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*)
-          ((:pretty *print-pretty*) *print-pretty*)
-          ((:radix *print-radix*) *print-radix*)
-          ((:readably *print-readably*) *print-readably*)
-          ((:right-margin *print-right-margin*) *print-right-margin*))
-  (incless:write-object *client* object stream)
-  object)
-
-(defun write-to-string
-    (object
-     &key ((:array *print-array*) *print-array*)
-          ((:base *print-base*) *print-base*)
-          ((:case *print-case*) *print-case*)
-          ((:circle *print-circle*) *print-circle*)
-          ((:escape *print-escape*) *print-escape*)
-          ((:gensym *print-gensym*) *print-gensym*)
-          ((:length *print-length*) *print-length*)
-          ((:level *print-level*) *print-level*)
-          ((:lines *print-lines*) *print-lines*)
-          ((:miser-width *print-miser-width*) *print-miser-width*)
-          ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*)
-          ((:pretty *print-pretty*) *print-pretty*)
-          ((:radix *print-radix*) *print-radix*)
-          ((:readably *print-readably*) *print-readably*)
-          ((:right-margin *print-right-margin*) *print-right-margin*))
-  (with-output-to-string (stream)
-    (incless:write-object *client* object stream)))
-
-(defun prin1 (object &optional (stream *standard-output*)
-              &aux (*print-escape* t))
-  (incless:write-object *client* object stream)
-  object)
-
-(defun princ (object &optional (stream *standard-output*)
-              &aux (*print-escape* nil)
-                   (*print-readably* nil))
-  (incless:write-object *client* object stream)
-  object)
-
-(defun print (object &optional (stream *standard-output*))
-  (write-char #\Newline stream)
-  (prin1 object stream)
-  (write-char #\Space stream)
-  object)
-
-(defun pprint (object &optional (stream *standard-output*)
-               &aux (*print-pretty* t))
-  (write-char #\Newline stream)
-  (prin1 object stream)
-  (values))
-
-(defun prin1-to-string (object)
-  (with-output-to-string (stream)
-    (prin1 object stream)))
-
-(defun princ-to-string (object)
-  (with-output-to-string (stream)
-    (princ object stream)))
-
-(defmacro print-unreadable-object
-    ((object stream &key type identity) &body body)
-  `(incless:write-unreadable-object *client* ,object ,stream ,type ,identity
-                                    (lambda () ,@body)))
-
-(defmethod incless:print-object ((client extrinsic-client) object stream)
-  (declare (ignore client))
-  (print-object object stream))
-
-(defmethod incless:write-object ((client extrinsic-client) object stream)
-  (incless:handle-circle client object stream #'print-object)
-  object)
+(incless:define-interface *client* extrinsic-client)
diff --git a/src/extrinsic/print-object.lisp b/src/extrinsic/print-object.lisp
diff --git a/src/interface.lisp b/src/interface.lisp
@@ -72,3 +72,149 @@
         *readtable*)))
 
 (defgeneric client-form (client))
+
+(defmacro define-interface (client-var client-class &optional intrinsic)
+  (let* ((pkg (if intrinsic (find-package "COMMON-LISP") *package*))
+         (print-object-name (intern "PRINT-OBJECT" pkg)))
+    `(progn
+       (defmethod client-form ((client ,client-class))
+         ',client-var)
+
+       (defgeneric ,print-object-name (object stream))
+
+       (defun ,(intern "WRITE" pkg)
+           (object
+            &key (stream *standard-output*)
+              ((:array *print-array*) *print-array*)
+              ((:base *print-base*) *print-base*)
+              ((:case *print-case*) *print-case*)
+              ((:circle *print-circle*) *print-circle*)
+              ((:escape *print-escape*) *print-escape*)
+              ((:gensym *print-gensym*) *print-gensym*)
+              ((:length *print-length*) *print-length*)
+              ((:level *print-level*) *print-level*)
+              ((:lines *print-lines*) *print-lines*)
+              ((:miser-width *print-miser-width*) *print-miser-width*)
+              ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*)
+              ((:pretty *print-pretty*) *print-pretty*)
+              ((:radix *print-radix*) *print-radix*)
+              ((:readably *print-readably*) *print-readably*)
+              ((:right-margin *print-right-margin*) *print-right-margin*))
+         (write-object ,client-var object stream)
+         object)
+
+       (defun ,(intern "WRITE-TO-STRING" pkg)
+           (object
+            &key ((:array *print-array*) *print-array*)
+              ((:base *print-base*) *print-base*)
+              ((:case *print-case*) *print-case*)
+              ((:circle *print-circle*) *print-circle*)
+              ((:escape *print-escape*) *print-escape*)
+              ((:gensym *print-gensym*) *print-gensym*)
+              ((:length *print-length*) *print-length*)
+              ((:level *print-level*) *print-level*)
+              ((:lines *print-lines*) *print-lines*)
+              ((:miser-width *print-miser-width*) *print-miser-width*)
+              ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*)
+              ((:pretty *print-pretty*) *print-pretty*)
+              ((:radix *print-radix*) *print-radix*)
+              ((:readably *print-readably*) *print-readably*)
+              ((:right-margin *print-right-margin*) *print-right-margin*))
+         (with-output-to-string (stream)
+           (write-object ,client-var object stream)))
+
+       (defun ,(intern "PRIN1" pkg) (object &optional (stream *standard-output*)
+                                     &aux (*print-escape* t))
+         (write-object ,client-var object stream)
+         object)
+
+       (defun ,(intern "PRINC" pkg) (object &optional (stream *standard-output*)
+                                     &aux (*print-escape* nil)
+                                       (*print-readably* nil))
+         (write-object ,client-var object stream)
+         object)
+
+       (defun ,(intern "PRINT" pkg) (object &optional (stream *standard-output*)
+                                     &aux (*print-escape* t))
+         (write-char #\Newline stream)
+         (write-object ,client-var object stream)
+         (write-char #\Space stream)
+         object)
+
+       (defun ,(intern "PPRINT" pkg) (object &optional (stream *standard-output*)
+                                      &aux (*print-escape* t)
+                                        (*print-pretty* t))
+         (write-char #\Newline stream)
+         (write-object ,client-var object stream)
+         (values))
+
+       (defun ,(intern "PRIN1-TO-STRING" pkg) (object
+                                               &aux (*print-escape* t))
+         (with-output-to-string (stream)
+           (write-object ,client-var object stream)))
+
+       (defun ,(intern "PRINC-TO-STRING" pkg) (object
+                                               &aux (*print-escape* nil)
+                                                 (*print-readably* nil))
+         (with-output-to-string (stream)
+           (write-object ,client-var object stream)))
+
+       (defmacro ,(intern "PRINT-UNREADABLE-OBJECT" pkg)
+           ((object stream &key type identity) &body body)
+         (list 'write-unreadable-object
+               ,client-var object stream type identity
+               (list* 'lambda '() body)))
+
+       (defmethod print-object ((client ,client-class) object stream)
+         (declare (ignore client))
+         (,print-object-name object stream))
+
+       (defmethod write-object ((client ,client-class) object stream)
+         (handle-circle client object stream #',print-object-name)
+         object)
+
+       (defmethod ,print-object-name (object stream)
+         (write-unreadable-object ,client-var object stream t t nil)
+         object)
+
+       (defmethod ,print-object-name ((object array) stream)
+         (print-array ,client-var object stream))
+
+       (defmethod ,print-object-name ((object bit-vector) stream)
+         (print-bit-vector ,client-var object stream))
+
+       (defmethod ,print-object-name ((object character) stream)
+         (print-character ,client-var object stream))
+
+       (defmethod ,print-object-name ((object complex) stream)
+         (print-complex ,client-var object stream))
+
+       (defmethod ,print-object-name ((object cons) stream)
+         (print-cons ,client-var object stream))
+
+       (defmethod ,print-object-name ((object integer) stream)
+         (print-integer ,client-var object *print-base* *print-radix* stream))
+
+       (defmethod ,print-object-name ((object float) stream)
+         (print-float ,client-var object stream))
+
+       (defmethod ,print-object-name ((object pathname) stream)
+         (print-pathname ,client-var object stream))
+
+       (defmethod ,print-object-name ((object random-state) stream)
+         (print-random-state ,client-var object stream))
+
+       (defmethod ,print-object-name ((object rational) stream)
+         (print-rational ,client-var object stream))
+
+       (defmethod ,print-object-name ((object string) stream)
+         (print-string ,client-var object stream))
+
+       (defmethod ,print-object-name ((object structure-object) stream)
+         (print-structure ,client-var object stream))
+
+       (defmethod ,print-object-name ((object symbol) stream)
+         (print-symbol ,client-var object stream))
+
+       (defmethod ,print-object-name ((object vector) stream)
+         (print-vector ,client-var object stream)))))