source: project/release/4/coops-utils/trunk/coops-extras.scm @ 34204

Last change on this file since 34204 was 34204, checked in by kon, 4 months ago

fix lib rqr

File size: 3.1 KB
Line 
1;;;; coops-extras.scm
2;;;; Kon Lovett, Jun '17
3;;;; Kon Lovett, Aug '10
4
5(module coops-extras
6
7(;export
8  slot@
9  make/copy
10  describe-object)
11
12(import scheme)
13
14(import chicken)
15
16(import (only extras fprintf))
17(require-library extras)
18
19(import (only srfi-1 fold remove))
20(require-library srfi-1)
21
22(import (only srfi-13 string-pad))
23(require-library srfi-13)
24
25(require-extension coops-introspection coops)
26
27;;; Helpers
28
29; memq is not specific enough
30(define-inline (initslot? slot initforms)
31  (let loop ((initforms initforms))
32    (and
33      (not (null? initforms))
34      (or
35        (eq? slot (car initforms))
36        (loop (cddr initforms)) ) ) ) )
37
38(define-inline (slot-values x slots #!optional (base '()))
39  (fold
40    (lambda (slot ls)
41      ;per Jun 19, '17 email from Sandra Snan
42      (if (slot-initialized? x slot)
43        (cons slot (cons (slot-value x slot) ls))
44        ls ) )
45    base
46    slots) )
47
48(define-inline (*class-slots class)
49  (slot-value class 'slots) )
50
51(define-inline (shadowed-initforms x initforms #!optional (class (class-of x)))
52  (slot-values x (remove (cut initslot? <> initforms) (*class-slots class)) initforms) )
53
54;;; Extras
55
56;;
57
58; sub-instance slot reference
59(define-syntax slot@
60  (syntax-rules (=)
61    ((_ ?o)
62      ?o )
63    ((_ ?o ?slot = ?v)
64      (set! (slot-value ?o '?slot) ?v) )
65    ((_ ?o ?slot . ?slots)
66      (slot@ (slot-value ?o '?slot) . ?slots)) ) )
67
68;;
69
70; use w/ <primitive-object> is very suspect
71(define (make/copy x . initforms)
72  (check-instance 'make/copy x)
73  (let ((class (class-of x)))
74    (apply make class (shadowed-initforms x initforms class)) ) )
75
76;;
77
78(define-generic (describe-object obj))
79
80(define-method (describe-object (obj #t) #!optional (out (current-output-port)))
81  (let ((class (class-of obj)))
82    (cond
83      ((eq? class #t)
84        ; specific in that obj used thru a coops interface
85        ; but might be misleading - (display obj out) perhaps?
86        (fprintf out "coops instance of class `#t': ~S~%" obj) )
87      (else
88        (fprintf out "coops instance of class `~A':~%" (class-name class))
89        (let* ((slots (*class-slots class))
90               (maxlen (apply max (map (o string-length symbol->string) slots))) )
91          (for-each
92            (lambda (slot)
93              (display (string-pad (symbol->string slot) maxlen) out)
94              (display " : " out)
95              (if (slot-initialized? obj slot)
96                (write (slot-value obj slot) out)
97                (display "#<uninitialized>" out) )
98              (newline out) )
99            slots) ) ) ) ) )
100
101(define-method (describe-object (prim <primitive-object>) #!optional (out (current-output-port)))
102  (fprintf out "coops instance of primitive class `~A': ~S~%" (class-name (class-of prim)) prim) )
103
104(define-method (describe-object (proc <procedure>) #!optional (out (current-output-port)))
105  (if (generic? proc) (fprintf out "coops instance of `<generic-procedure>'~%")
106    (fprintf out "coops instance of primitive class `<procedure>'~%") ) )
107
108(define-method (describe-object (class <standard-class>) #!optional (out (current-output-port)))
109  (fprintf out "coops standard-class `~A'~%" (class-name class)) )
110
111) ;coops-extras
Note: See TracBrowser for help on using the repository browser.