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

Last change on this file since 38863 was 38863, checked in by Kon Lovett, 2 months ago

dup slot storage

File size: 2.3 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(import (chicken base))
14(import (chicken type))
15(import (only (srfi 1) list-copy cons* remove))
16(import (only coops-introspection check-instance))
17(import 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 adv ((ls ls))
43    (and
44      (not (null? ls))
45      (or
46        (eq? key (car ls))
47        (adv (cddr ls)) ) ) ) )
48
49(: plist-cons (symbol * plist -> plist))
50;
51(define (plist-cons key val ls)
52  (cons* key val ls) )
53
54;;
55
56;memq is not specific enough
57(: initslot? (symbol list -> boolean))
58;
59(define (initslot? slot initforms)
60  (plist-key? slot initforms) )
61
62(: slot-values (coops-instance (list-of symbol) #!optional list -> list))
63;
64(define (slot-values obj slots #!optional (base '()))
65  (foldl
66    (lambda (ls slot)
67      (if (slot-initialized? obj slot)  ;per Jun 19, '17 email from Sandra Snan
68        (plist-cons slot (slot-value obj slot) ls)
69        ls ) )
70    base
71    slots) )
72
73(: shadowed-initforms (coops-instance list #!optional coops-class -> list))
74;
75(define (shadowed-initforms obj initforms #!optional (class (class-of obj)))
76  ;shallow copy of the slots - share values but not storage
77  ;FIXME 1-pass, dup storage & replace new values
78  (slot-values
79    obj
80    (remove (cut initslot? <> initforms) (list-copy (*class-slots class)))
81    initforms) )
82
83;;; Extras
84
85;;
86
87;sub-instance slot reference
88(define-syntax slot@
89  (syntax-rules (=)
90    ;
91    ((slot@ ?obj)
92      ?obj )
93    ;
94    ((slot@ ?obj ?slot = ?valu)
95      (set! (slot-value ?obj '?slot) ?valu) )
96    ;
97    ((slot@ ?obj ?slot ?rest0 ...)
98      (slot@ (slot-value ?obj '?slot) ?rest0 ...) ) ) )
99
100;;
101
102;use w/ <primitive-object> is very suspect
103(: make-copy (coops-instance #!rest -> *))
104;
105(define (make-copy obj . initforms)
106  (let ((class (class-of (check-instance 'make-copy obj))))
107    (apply make class (shadowed-initforms obj initforms class)) ) )
108
109) ;coops-extras
Note: See TracBrowser for help on using the repository browser.