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

Last change on this file since 38400 was 38400, checked in by Kon Lovett, 7 months ago

style, use memory module

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