Coverage report: /home/ellis/comp/core/app/skel/core/print.lisp

KindCoveredAll%
expression0169 0.0
branch016 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; print.lisp --- Skel Printer
2
 
3
 ;; SK-PRINT
4
 
5
 ;;; Commentary:
6
 
7
 ;; SK-PRINT is the top-level interface, and dispatches on all sorts of SKEL
8
 ;; objects. The output is different than the PRINT-OBJECT methods, which are
9
 ;; implemented in the SKEL/CORE/OBJ package.
10
 
11
 ;; SK-PRINT is the 'external print' representation, which is structured, akin
12
 ;; to PPRINT - while PRINT-OBJECT is the 'internal print' and unstructured
13
 ;; representation.
14
 
15
 ;; All printer parameters are dynamic and dispatch occurs in the same manner
16
 ;; as the standard Lisp Printer. Additional parameters may be provided in the
17
 ;; future.
18
 
19
 ;;; Code:
20
 (in-package :skel/core/print)
21
 (declaim (optimize (speed 3)))
22
 ;; sb-pretty::*standard-pprint-dispatch-table*
23
 ;; *readtable*
24
 
25
 (declaim (inline sk-coerce-name sk-coerce-sequence))
26
 
27
 (defun sk-coerce-name (name &optional (case :downcase))
28
   (if (eql :downcase case) (string-downcase name) (string-upcase name)))
29
 
30
 (defun sk-coerce-sequence (seq &optional limit)
31
   (coerce
32
    (if limit
33
        (take limit seq)
34
        seq)
35
    'list))
36
 
37
 (defun sk-print-slot (slot self &key (stream *standard-output*) (limit 8) (case :downcase))
38
   (declare (stream stream) (skel self))
39
      (let ((name (sb-mop:slot-definition-name slot))
40
            (*print-case* case))
41
        (when (slot-boundp self name)
42
          (let ((val (slot-value self name))
43
                (name (sk-coerce-name name case)))
44
            (typecase val
45
              (string (format stream ":~A ~A~%" name val))
46
              (cons (unless (sequence:emptyp val) (format stream ":~A ~A~%" name val)))
47
              (vector (unless (sequence:emptyp val)
48
                        (format stream ":~A [" name)
49
                        (pprint-tabular stream (sk-coerce-sequence val limit) nil nil 2)
50
                        (force-output stream)
51
                        (if (and limit (> #2=(length val) #1=(the positive-fixnum limit)))
52
                            (format stream " ...~d]~%" (- #2# limit))
53
                            (format stream "]~%"))))
54
              (hash-table (unless (zerop (hash-table-count val))
55
                            (format stream ":~A {" name)
56
                            (pprint-tabular stream (sk-coerce-sequence (hash-table-alist val) limit)
57
                                            nil nil 2)
58
                            (if (and limit (> #4=(hash-table-count val) #3=(the positive-fixnum limit)))
59
                                (format stream " ...~d}~%" (- #4# limit))
60
                                (format stream "}~%"))))
61
              (t (format stream ":~A ~A~%" name val)))))))
62
 
63
 (defmethod sk-print ((self skel) &key (stream *standard-output*) (id t) exclude (case :downcase) direct (limit 8) &allow-other-keys)
64
   (declare (stream stream) (positive-fixnum limit))
65
   (let ((name (skel/core/obj::sk-slot-name self (when (eql :downcase case))))
66
         (*print-case* case))
67
     (if id
68
         (format stream "~S ~A~%" 
69
                 name 
70
                 (format-sxhash (obj/id:id self)))
71
         (format stream "~S~%" name)))
72
   (mapcar
73
    (lambda (slot) (sk-print-slot slot self :stream stream :limit limit :case case))
74
    (remove-if (lambda (x) (member (keywordicate (sb-mop:slot-definition-name x)) exclude))
75
               (if direct
76
                   (sb-mop:class-direct-slots (class-of self))
77
                   (sb-mop:class-slots (class-of self)))))
78
   self)