I struggled to find something similar last time I googled around, and had to unearthed this from a venerable, fragile hard drive (school project, 10/15 years ago). It doesn’t compile (racket) anymore as-is (something something “unholly macros usage”). I’ll eventually clean it up one day, but in the mean time, if it may help or be of curiosity to anyone.
Pygmalion adoring his statue, 1717, oil on canvas
by
Jean Raoux
Note: I wouldn’t personally recommend to architecture code around this, but it’s a fun toy project. It’s OOP in the Java/C++ sense, not Smalltalk, not JS.
(require mzlib/defmacro)
(define (mk-instance class)
(class))
(define (show . args)
(for-each (λ (x) (display x) (display " ")) args))
(define-macro (defclass name . options)
;; tools
(define (get-opt f opt lst)
(foldl (λ (x acc)
(cond
((null? x) acc)
((equal? (car x) opt) (f (cdr x) acc))
(else acc))) '() lst))
(define (symbol-append . args)
(string->symbol (apply string-append
(map symbol->string args))))
;; accessors
(define (mk-reader slot)
`((,(symbol-append 'get- slot))
,slot))
(define (mk-writer slot)
`((,(symbol-append 'set- slot '!))
(set! ,slot (car arg))))
;; printer
(define (mk-print name slots super)
`((show "#<" ',name)
,(unless (eq? super #f) '(super 'print))
,@(map (λ (x) `(show ',x "=" ,x)) slots)
(show ">")))
;; methods
(define (mk-method-def m)
(let ((name (car m))
(body (cdr m)))
`(define ,name ,@body)))
(define (mk-method-call m)
(let ((name (caar m)))
`((,name) (apply ,name arg))))
;; generated code
(let* ((inst-vars (get-opt append 'instance-vars options))
(class-vars (get-opt append 'class-vars options))
(slots (map car (append '((super #f) (self #f)) inst-vars class-vars)))
(methods (get-opt cons 'method options))
(parent (get-opt append 'super options))
(superclass (if (null? parent) #f parent)))
`(define ,name
(let ,class-vars
(λ ()
(let ,(cons `(super ,superclass) (cons '(self #f) inst-vars))
,@(map mk-method-def methods)
(let ((this (λ (msg . arg)
(case msg
,@(map mk-reader slots)
,@(map mk-writer slots)
((type) ',name)
((print) ,@(mk-print name slots superclass))
,@(map mk-method-call methods)
,(if (null? parent)
'(else (error "bad message" msg))
`(else (apply super msg arg)))))))
(and (set! self this) self))))))))
(defclass C1 (instance-vars (a 1) (b 2) (c 3))
(class-vars (f 6) (g 7))
(method (mult-all)
(* a b c))
(method (describe self)
(printf "type de self ~A\n" (self 'type))
(printf "valeur: ") (self 'print) (newline)))
(defclass C2
(super C1)
(instance-vars (d 4) (e 5)))
Comments
By email, at mathieu.bivert chez: