source: project/release/5/coops-utils/trunk/coops-extras.scm @ 37388

Last change on this file since 37388 was 36627, checked in by Kon Lovett, 2 years ago

move describe stuff to own module

File size: 2.1 KB
Line 
1;;;; coops-extras.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3;;;; Kon Lovett, Jun '17
4;;;; Kon Lovett, Aug '10
5
6(module coops-extras
7
8(;export
9  slot@
10  make-copy)
11
12(import scheme
13  (chicken base)
14  (chicken type)
15  (only (srfi 1) cons* remove)
16  (only coops-introspection check-instance)
17  coops)
18
19;;;
20
21(define-type coops-class *)
22(define-type coops-instance *)
23
24(define-type plist list)
25
26;;;coops-introspection
27
28(: *class-slots (coops-class --> list))
29;
30(define (*class-slots class)
31  (slot-value class 'slots) )
32
33;;; Helpers
34
35;;
36
37;memq is not specific enough
38(: plist-key? (symbol plist --> boolean))
39;
40(define (plist-key? key ls)
41  ;search plist for key name
42  (let loop ((ls ls))
43    (and
44      (not (null? ls))
45      (or
46        (eq? key (car ls))
47        (loop (cddr ls)) ) ) ) )
48
49(: plist-cons (symbol * plist --> plist))
50;
51(define (plist-cons key val ls) (cons* key val ls))
52
53;;
54
55;memq is not specific enough
56(: initslot? (symbol list --> boolean))
57;
58(define (initslot? slot initforms) (plist-key? slot initforms))
59
60(: slot-values (coops-instance (list-of symbol) #!optional list --> list))
61;
62(define (slot-values x slots #!optional (base '()))
63  (foldl
64    (lambda (ls slot)
65      (if (slot-initialized? x slot)  ;per Jun 19, '17 email from Sandra Snan
66        (plist-cons slot (slot-value x slot) ls)
67        ls ) )
68    base
69    slots) )
70
71(: shadowed-initforms (coops-instance list #!optional coops-class --> list))
72;
73(define (shadowed-initforms obj initforms #!optional (class (class-of obj)))
74  (slot-values
75    obj
76    (remove (cut initslot? <> initforms) (*class-slots class))
77    initforms) )
78
79;;; Extras
80
81;;
82
83;sub-instance slot reference
84(define-syntax slot@
85  (syntax-rules (=)
86    ;
87    ((slot@ ?obj)
88      ?obj )
89    ;
90    ((slot@ ?obj ?slot = ?valu)
91      (set! (slot-value ?obj '?slot) ?valu) )
92    ;
93    ((slot@ ?obj ?slot ?rest0 ...)
94      (slot@ (slot-value ?obj '?slot) ?rest0 ...) ) ) )
95
96;;
97
98;use w/ <primitive-object> is very suspect
99(: make-copy (coops-instance #!rest --> *))
100;
101(define (make-copy obj . initforms)
102  (let ((class (class-of (check-instance 'make-copy obj))))
103    (apply make class (shadowed-initforms obj initforms class)) ) )
104
105) ;coops-extras
Note: See TracBrowser for help on using the repository browser.