some print-object stuff
Fri Jul 17 10:47:53 PDT 2009 attila.lendvai@gmail.com
* some print-object stuff
Warning: CRC errors found. These are probably harmless but should be repaired.
See 'darcs gzcrcs --help' for more information.
diff -rN -u old-cl-walker/src/duplicates.lisp new-cl-walker/src/duplicates.lisp
--- old-cl-walker/src/duplicates.lisp 2014-07-23 04:56:46.000000000 -0700
+++ new-cl-walker/src/duplicates.lisp 2014-07-23 04:56:46.000000000 -0700
@@ -220,3 +220,36 @@
rest-variable-name
whole-variable-name
env-variable-name)))
+
+;; from cl-def
+(defmacro defprint-object (&whole whole class-name* &body body)
+ "Define a PRINT-OBJECT method using PRINT-UNREADABLE-OBJECT.
+ An example:
+ (def print-object parenscript-dispatcher ; could be (parenscript-dispatcher :identity nil)
+ (when (cachep self)
+ (princ \"cached\")
+ (princ \" \"))
+ (princ (parenscript-file self)))"
+ (with-unique-names (stream printing)
+ (let ((args (ensure-list class-name*)))
+ (destructuring-bind (class-name &key (identity t) (type t) with-package (muffle-errors t))
+ args
+ (multiple-value-bind (body declarations documentation)
+ (parse-body body :documentation t :whole whole)
+ `(defmethod print-object ((-self- ,class-name) ,stream)
+ ,@(when documentation
+ (list documentation))
+ ,@declarations
+ (print-unreadable-object (-self- ,stream :type ,type :identity ,identity)
+ (let ((*standard-output* ,stream))
+ (block ,printing
+ (,@(if muffle-errors
+ `(handler-bind ((error (lambda (error)
+ (declare (ignore error))
+ (write-string "<<error printing object>>")
+ (return-from ,printing)))))
+ `(progn))
+ (let (,@(when with-package `((*package* ,(find-package with-package)))))
+ ,@body)))))
+ ;; primary PRINT-OBJECT methods are supposed to return the object
+ -self-))))))
diff -rN -u old-cl-walker/src/functions.lisp new-cl-walker/src/functions.lisp
--- old-cl-walker/src/functions.lisp 2014-07-23 04:56:46.000000000 -0700
+++ new-cl-walker/src/functions.lisp 2014-07-23 04:56:46.000000000 -0700
@@ -10,15 +10,22 @@
((operator :accessor operator-of :initarg :operator)
(arguments :accessor arguments-of :initarg :arguments)))
-(defmethod print-object ((argument application-form) stream)
- (print-unreadable-object (argument stream :type t :identity t)
- (if (slot-boundp argument 'operator)
- (format stream "~A" (operator-of argument))
- (write-string "#<unbound operator>" stream))))
-
(defunwalker-handler application-form (operator arguments)
(cons operator (unwalk-forms arguments)))
+(defprint-object application-form
+ ;; the bang sign is a weak try... but at least mark it somehow that it's not a normal sexp...
+ (princ "!(")
+ (princ (operator-of -self-))
+ (princ " ")
+ (let ((first t))
+ (dolist (arg (arguments-of -self-))
+ (unless first
+ (princ " "))
+ (princ arg)
+ (setf first nil)))
+ (princ ")"))
+
(defclass lexical-application-form (application-form)
((code :accessor code-of :initarg :code)))
@@ -199,11 +206,8 @@
(defclass function-argument-form (walked-form)
((name :accessor name-of :initarg :name)))
-(defmethod print-object ((argument function-argument-form) stream)
- (print-unreadable-object (argument stream :type t :identity t)
- (if (slot-boundp argument 'name)
- (format stream "~S" (name-of argument))
- (write-string "#<unbound name>" stream))))
+(defprint-object function-argument-form
+ (format t "~S" (name-of argument)))
(defclass required-function-argument-form (function-argument-form)
())
diff -rN -u old-cl-walker/src/handlers.lisp new-cl-walker/src/handlers.lisp
--- old-cl-walker/src/handlers.lisp 2014-07-23 04:56:46.000000000 -0700
+++ new-cl-walker/src/handlers.lisp 2014-07-23 04:56:46.000000000 -0700
@@ -21,9 +21,8 @@
(cons `(quote ,value))
(t value))))
-(defmethod print-object ((node constant-form) stream)
- (print-unreadable-object (node stream :type t :identity t)
- (format stream "~S" (value-of node))))
+(defprint-object constant-form
+ (format t "!~S" (value-of -self-)))
(defclass variable-reference-form (walked-form)
((name :accessor name-of :initarg :name)))
@@ -31,9 +30,8 @@
(defunwalker-handler variable-reference-form (name)
name)
-(defmethod print-object ((v variable-reference-form) stream)
- (print-unreadable-object (v stream :type t :identity t)
- (format stream "~S" (name-of v))))
+(defprint-object variable-reference-form
+ (format t "!~S" (name-of -self-)))
(defclass lexical-variable-reference-form (variable-reference-form)
())
@@ -329,6 +327,23 @@
(defunwalker-handler progn-form (body)
`(progn ,@(unwalk-forms body)))
+(defprint-object progn-form
+ (let ((body (body-of -self-)))
+ (pprint-logical-block (*standard-output* body :prefix "(" :suffix ")")
+ (princ "progn")
+ (pprint-indent :block 1)
+ (pprint-newline :mandatory)
+ (pprint-exit-if-list-exhausted)
+ (loop
+ :with first? = t
+ :for el = (pprint-pop)
+ :do
+ (unless first?
+ (pprint-newline :mandatory))
+ (princ el)
+ (pprint-exit-if-list-exhausted)
+ (setf first? nil)))))
+
;;;; PROGV
(defclass progv-form (walked-form implicit-progn-mixin)
diff -rN -u old-cl-walker/src/infrastructure.lisp new-cl-walker/src/infrastructure.lisp
--- old-cl-walker/src/infrastructure.lisp 2014-07-23 04:56:46.000000000 -0700
+++ new-cl-walker/src/infrastructure.lisp 2014-07-23 04:56:46.000000000 -0700
@@ -341,15 +341,14 @@
(defmethod make-load-form ((object walked-form) &optional env)
(make-load-form-saving-slots object :environment env))
-(defmethod print-object ((form walked-form) stream)
- (print-unreadable-object (form stream :type t :identity t)
- (if (and (slot-boundp form 'source)
- (source-of form))
- (let ((*print-readably* nil)
- (*print-level* 0)
- (*print-length* 4))
- (format stream "~S" (source-of form)))
- (call-next-method))))
+(defprint-object walked-form
+ (if (and (slot-boundp -self- 'source)
+ (source-of -self-))
+ (let ((*print-readably* nil)
+ (*print-level* 0)
+ (*print-length* 4))
+ (format t "~S" (source-of -self-)))
+ (call-next-method)))
(defmacro make-form-object (type parent &rest initargs)
(with-unique-names (custom-type)
diff -rN -u old-cl-walker/src/progn.lisp new-cl-walker/src/progn.lisp
--- old-cl-walker/src/progn.lisp 2014-07-23 04:56:46.000000000 -0700
+++ new-cl-walker/src/progn.lisp 2014-07-23 04:56:46.000000000 -0700
@@ -9,11 +9,8 @@
(defclass implicit-progn-mixin ()
((body :accessor body-of :initarg :body)))
-(defmethod print-object ((argument implicit-progn-mixin) stream)
- (print-unreadable-object (argument stream :type t :identity t)
- (if (slot-boundp argument 'body)
- (format stream "~A" (body-of argument))
- (write-string "#<unbound body>" stream))))
+(defprint-object implicit-progn-mixin
+ (format t "~A" (body-of -self-)))
(defclass implicit-progn-with-declare-mixin (implicit-progn-mixin)
((declares :initform nil :accessor declares-of :initarg :declares)))