source: project/release/5/coops-utils/trunk/coops-describe.scm @ 36627

Last change on this file since 36627 was 36627, checked in by Kon Lovett, 11 months ago

move describe stuff to own module

File size: 3.3 KB
Line 
1;;;; coops-describe.scm  -*- Scheme -*-
2;;;; Kon Lovett, Sep '18
3
4(declare
5  (bound-to-procedure
6    ##sys#peek-unsigned-integer
7    ##sys#check-closure))
8
9(module coops-describe
10
11(;export
12  describe-object describe-object-slot
13  ;
14  print-closure)
15
16(import scheme
17  (chicken base)
18  (chicken fixnum)
19  (chicken type)
20  (only (chicken format) fprintf)
21  (only (srfi 13) string-pad)
22  coops)
23
24;;;symbol-utils
25
26(define (symbol-printname-length s)
27  (string-length (symbol->string s)) )
28
29;;;
30
31(define-type coops-class *)
32
33;;; Helpers
34
35(define-constant MAXIMUM-SLOTNAME-LENGTH 32)
36
37(: closure-C-address (procedure --> number))
38;
39(define (closure-C-address proc)
40  (##sys#peek-unsigned-integer proc 0) )
41
42(: check-closure (symbol * --> procedure))
43;
44(define (check-closure loc obj)
45  (##sys#check-closure obj loc)
46  obj )
47
48(: *class-slots (coops-class --> list))
49;
50(define (*class-slots class)
51  (slot-value class 'slots) )
52
53;;;
54
55;;
56
57(define-generic (describe-object obj))
58
59(define-method (describe-object (obj #t)
60                  #!optional (out (current-output-port)))
61  (let ((class (class-of obj)))
62    (if (eq? class #t)
63      ;then obj used thru a coops interface
64      (fprintf out "coops instance of class `#t': ~S~%" obj)
65      ;else an instance
66      (let* (
67        (slots (*class-slots class))
68        (name-maxlen (apply max (map symbol-printname-length slots))) )
69        ;
70        (define (slot-per-line slot)
71          (describe-object-slot obj slot name-maxlen out)
72          (newline out) )
73        ;
74        (fprintf out "coops instance of class `~A':~%" (class-name class))
75        (for-each (cut slot-per-line <>) slots) ) ) ) )
76
77(define-method (describe-object (prim <primitive-object>)
78                  #!optional (out (current-output-port)))
79  (fprintf out "coops instance of primitive class `~A': ~S~%"
80    (class-name (class-of prim)) prim) )
81
82(define-method (describe-object (proc <procedure>)
83                  #!optional (out (current-output-port)))
84  (fprintf out "~A~%"
85    (if (generic-procedure? proc)
86      "coops instance of `<generic-procedure>'"
87      "coops instance of primitive class `<procedure>'")) )
88
89(define-method (describe-object (class <standard-class>)
90                  #!optional (out (current-output-port)))
91  (fprintf out "coops standard-class `~A'~%" (class-name class)) )
92
93;;
94
95(: describe-object-slot (* symbol #!optional fixnum (or boolean output-port) -> *))
96;
97(define (describe-object-slot obj slot
98          #!optional
99          (name-maxlen MAXIMUM-SLOTNAME-LENGTH)
100          (out (current-output-port)))
101  (let* (
102    (intd? (slot-initialized? obj slot))
103    (nam (string-pad (symbol->string slot) name-maxlen))
104    (args-fmt (if intd? "~S" "#<uninitialized>"))
105    (args (if intd? `(,(slot-value obj slot)) '())) )
106    (fprintf out "~A: ~?" nam args-fmt args) ) )
107
108;;
109
110;(call-with-output-string (lambda (port) (print-closure proc port)))
111
112(: print-closure (procedure #!optional (or boolean output-port) -> *))
113;
114(define (print-closure proc #!optional (out (current-output-port)))
115  (let ((idx 0))
116    (fprintf out "~A: #x~X~%"
117      idx (closure-C-address (check-closure 'print-closure proc)))
118    (let ((size (##sys#size proc)))
119      (do ((i (fx+ idx 1) (fx+ i 1)))
120          ((fx= i size))
121        (fprintf out "~A: ~S~%" i (##sys#slot proc i)) ) ) ) )
122
123) ;coops-describe
Note: See TracBrowser for help on using the repository browser.