Ticket #1780: workaround.scm

File workaround.scm, 1.8 KB (added by Shawn Rutledge, 14 months ago)

But Felix tells me it breaks existing examples to make this change. So here's my workaround: the class _must_ be defined with keyword slots, and then the -> operator can be adjusted to convert plain symbols to keywords.

Line 
1(import coops (chicken format) (chicken keyword))
2
3(define-class <rect> () ((x: 0.0) (y: 0.0) (w: 10.0) (h: 10.0) (children: '())))
4
5(define-method (print-object (o <rect>) port)
6        (fprintf port "~ax~a~a~a~a~a"  (slot-value o w:) (slot-value o h:)
7                (if (>= (slot-value o x:) 0) "+" "") (slot-value o x:) (if (>= (slot-value o y:) 0) "+" "") (slot-value o y:) ))
8
9;; lifted from dscm; overkill for this example
10; (define-generic (->impl o . slots))
11(define-method (->impl (obj <standard-object>) . slots)
12        (let loop ([s slots][o obj])
13; (printf "loop ~s in ~s~%" s o)
14                (cond
15                        [(not o) #f]
16                        [(promise? o) (loop s (force o))]
17                        [(procedure? o)
18                                (loop s (o))]
19                        [(null? s)
20                                o]
21                        [else
22                                (loop
23                                        (cdr s)
24                                        (let ([ref (car s)])
25                                                (cond
26                                                        [(keyword? ref)
27                                                                (if (slot-initialized? o ref)
28                                                                        (slot-value o ref)
29                                                                        #f)]
30                                                        [(symbol? ref) ;; workaround
31                                                                (let ([kw (string->keyword (symbol->string ref))])
32                                                                        (if (slot-initialized? o kw)
33                                                                                (slot-value o kw)
34                                                                                #f))]
35                                                        [(integer? ref)
36; (printf "looking for ~s in ~s~%" ref o)
37                                                                (cond
38                                                                        [(vector? o) (vector-ref o ref)]
39                                                                        [(pair? o) (list-ref o ref)] )]
40                                                                        [else (printf "-> failed to reference ~a in ~a~%" ref o)])))])))
41
42(define-syntax -> (syntax-rules () [(_ ?obj ?slot ...) (->impl ?obj '?slot ...) ]))
43
44;; normal usage: colons look good in a constructor; so the class _must_ be defined with keyword slot names
45(define r (make <rect> w: 100 h: 200 children: '("whatever" "is" "wanted" "here")))
46
47;; colons don't look good in accessors: you can leave them out when using the -> syntax; otherwise, slot-value works as before
48(printf "here's my rectangle ~a; its width is ~a and height is ~a; third child is ~s~%"
49        r (-> r  w) (slot-value r h:) (-> r  children 3))