Ticket #1780: workaround.scm

(import coops (chicken format) (chicken keyword))

(define-class <rect> () ((x: 0.0) (y: 0.0) (w: 10.0) (h: 10.0) (children: '())))

(define-method (print-object (o <rect>) port)
        (fprintf port "~ax~a~a~a~a~a"  (slot-value o w:) (slot-value o h:)
                (if (>= (slot-value o x:) 0) "+" "") (slot-value o x:) (if (>= (slot-value o y:) 0) "+" "") (slot-value o y:) ))

;; lifted from dscm; overkill for this example
; (define-generic (->impl o . slots))
(define-method (->impl (obj <standard-object>) . slots)
        (let loop ([s slots][o obj])
; (printf "loop ~s in ~s~%" s o)
                (cond
                        [(not o) #f]
                        [(promise? o) (loop s (force o))]
                        [(procedure? o)
                                (loop s (o))]
                        [(null? s)
                                o]
                        [else
                                (loop
                                        (cdr s)
                                        (let ([ref (car s)])
                                                (cond
                                                        [(keyword? ref)
                                                                (if (slot-initialized? o ref)
                                                                        (slot-value o ref)
                                                                        #f)]
                                                        [(symbol? ref) ;; workaround
                                                                (let ([kw (string->keyword (symbol->string ref))])
                                                                        (if (slot-initialized? o kw)
                                                                                (slot-value o kw)
                                                                                #f))]
                                                        [(integer? ref)
; (printf "looking for ~s in ~s~%" ref o)
                                                                (cond
                                                                        [(vector? o) (vector-ref o ref)]
                                                                        [(pair? o) (list-ref o ref)] )]
                                                                        [else (printf "-> failed to reference ~a in ~a~%" ref o)])))])))

(define-syntax -> (syntax-rules () [(_ ?obj ?slot ...) (->impl ?obj '?slot ...) ]))

;; normal usage: colons look good in a constructor; so the class _must_ be defined with keyword slot names
(define r (make <rect> w: 100 h: 200 children: '("whatever" "is" "wanted" "here")))

;; colons don't look good in accessors: you can leave them out when using the -> syntax; otherwise, slot-value works as before
(printf "here's my rectangle ~a; its width is ~a and height is ~a; third child is ~s~%"
        r (-> r  w) (slot-value r h:) (-> r  children 3))