1037 lines
33 KiB
Racket
1037 lines
33 KiB
Racket
#lang racket
|
|
|
|
(require racket/syntax)
|
|
(require racket/set)
|
|
(require uuid)
|
|
(require (for-syntax racket/base))
|
|
(require finalizer)
|
|
|
|
(provide def-roos
|
|
%-!
|
|
roos-new
|
|
%->
|
|
%->>
|
|
|
|
roos-class?
|
|
roos-object?
|
|
roos-obj?
|
|
|
|
roos-class
|
|
roos-classname
|
|
|
|
roos-help
|
|
|
|
with-roos-obj
|
|
|
|
roos-id
|
|
roos-id!
|
|
roos-storage!
|
|
roos-storage-stop-deleting!
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Persistence
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define @@storage@@ (make-hasheq))
|
|
|
|
(define (@@cache-get obj var default)
|
|
(let ((cl-hash (hash-ref @@storage@@ (roos-classname obj) (make-hasheq))))
|
|
(let ((id (%-> obj roos-id)))
|
|
(let ((obj-hash (hash-ref cl-hash id (make-hasheq))))
|
|
(hash-ref obj-hash var default)))))
|
|
|
|
(define (@@cache-set! obj var val)
|
|
(let ((cl-hash (hash-ref @@storage@@ (roos-classname obj) #f)))
|
|
(unless cl-hash
|
|
(set! cl-hash (make-hasheq))
|
|
(hash-set! @@storage@@ (roos-classname obj) cl-hash))
|
|
(let ((id (%-> obj roos-id)))
|
|
(let ((obj-hash (hash-ref cl-hash id #f)))
|
|
(unless obj-hash
|
|
(set! obj-hash (make-hasheq))
|
|
(hash-set! cl-hash id obj-hash))
|
|
(hash-set! obj-hash var val)))))
|
|
|
|
(define @@stop-deleting@@ #f)
|
|
|
|
(define (@@cache-delete! obj)
|
|
(unless @@stop-deleting@@
|
|
(let ((cl-hash (hash-ref @@storage@@ (roos-classname obj) (make-hasheq))))
|
|
(hash-remove! cl-hash (%-> obj roos-id)))))
|
|
|
|
(define (@@cache-stop-deleting yn)
|
|
(set! @@stop-deleting@@ yn))
|
|
|
|
(define (roos-storage! getter setter deleter stop-deleting)
|
|
(set! @@cache-get getter)
|
|
(set! @@cache-set! setter)
|
|
(set! @@cache-delete! deleter)
|
|
(set! @@cache-stop-deleting stop-deleting)
|
|
)
|
|
|
|
(define (roos-storage-stop-deleting! yn)
|
|
(@@cache-stop-deleting yn))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Class definition syntax
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(struct roos-class* (closure name members super-inits decl))
|
|
(struct roos-object* (this supers classname the-class
|
|
set-caller (caller #:mutable)))
|
|
|
|
(define (@@new-id)
|
|
(string->symbol (string-append "roos-" (uuid-string))))
|
|
|
|
(define-syntax @@mk-supers
|
|
(syntax-rules ()
|
|
((_ supers)
|
|
(define supers (list)))
|
|
((_ supers s1 ...)
|
|
(define supers (list s1 ...)))
|
|
))
|
|
|
|
(define-syntax @@mk-lit
|
|
(syntax-rules ()
|
|
((_ (f ...))
|
|
'(f ...))
|
|
((_ (f . a))
|
|
'(f . a))
|
|
))
|
|
|
|
|
|
(define-syntax @@mk-name
|
|
(syntax-rules ()
|
|
((_ (f . args))
|
|
'f)
|
|
((_ f . args)
|
|
'f)
|
|
))
|
|
|
|
(define-syntax @@mk-proc
|
|
(syntax-rules ()
|
|
((_ (f . args))
|
|
f)
|
|
((_ f . args)
|
|
f)
|
|
))
|
|
|
|
(define-syntax @@mk-super-infos
|
|
(syntax-rules ()
|
|
((_ supers)
|
|
'())
|
|
((_ supers s1 ...)
|
|
(list 's1 ...))
|
|
))
|
|
|
|
(define-syntax (@@mk-mem-info* stx)
|
|
(syntax-case stx ()
|
|
((@@mk-mem-info* persist doc a b)
|
|
#'(list 'a 'a (string-append "<persist> " doc)))
|
|
((@@mk-mem-info* doc a b)
|
|
(if (eq? (syntax->datum #'doc) 'persist)
|
|
#'(list 'a 'a "<persist>")
|
|
#'(list 'a 'a doc)
|
|
))
|
|
))
|
|
|
|
(define-syntax @@mk-member-info*
|
|
(syntax-rules ()
|
|
((_ ((f) expr ...))
|
|
(list (@@mk-name f) (@@mk-lit (f)) ""))
|
|
((_ ((f . b) expr ...))
|
|
(list (@@mk-name f . b) (@@mk-lit (f . b)) ""))
|
|
((_ ((f a ...) expr ...))
|
|
(list (@@mk-name f a ...) (@@mk-lit (f a ...)) ""))
|
|
((_ ((f a ... . b) expr ...))
|
|
(list (@@mk-name f a ... . b) (@@mk-lit (f a ... . b)) ""))
|
|
((_ (doc ((f) expr ...)))
|
|
(list (@@mk-name f) (@@mk-lit (f)) doc))
|
|
((_ (doc ((f . a) expr ...)))
|
|
(list (@@mk-name f . a) (@@mk-lit (f . a)) doc))
|
|
((_ (doc ((f a ...) expr ...)))
|
|
(list (@@mk-name f a ...) (@@mk-lit (f a ...)) doc))
|
|
((_ (doc ((f a ... . b) expr ...)))
|
|
(list (@@mk-name f a ... . b) (@@mk-lit (f a ... . b)) doc))
|
|
((_ (persist doc (a b)))
|
|
(@@mk-mem-info* persist doc a b))
|
|
((_ (doc (a b)))
|
|
(@@mk-mem-info* doc a b))
|
|
((_ (a b))
|
|
(list 'a 'a ""))
|
|
))
|
|
|
|
(define-syntax (@@mk-member-info stx)
|
|
(syntax-case stx ()
|
|
((_ (keyw))
|
|
(let ((kw (syntax->datum #'keyw)))
|
|
(if (or (eq? kw 'init)
|
|
(eq? kw 'finalize))
|
|
#'(list 'keyw 'keyw (format "has empty '~a'" 'keyw))
|
|
#'(@@mk-member-info* keyw))))
|
|
((_ (keyw b1 ...))
|
|
(let ((kw (syntax->datum #'keyw)))
|
|
(if (or (eq? kw 'init)
|
|
(eq? kw 'finalize))
|
|
#'(list 'keyw 'keyw (format "has defined '~a'" 'keyw))
|
|
#'(@@mk-member-info* (keyw b1 ...)))))
|
|
((_ x)
|
|
#'(@@mk-member-info* x))
|
|
))
|
|
|
|
(define-syntax @@mk-member-infos
|
|
(syntax-rules ()
|
|
((_ b1 ...)
|
|
(list (@@mk-member-info b1) ...))
|
|
))
|
|
|
|
(define-syntax @@mk-super-init
|
|
(syntax-rules ()
|
|
((_ (roos-new cl ...))
|
|
(if (roos-class? (@@mk-proc cl ...))
|
|
(@@mk-proc cl ...)
|
|
roos-new))
|
|
((_ (f ...))
|
|
(@@mk-proc f ...))
|
|
((_ f)
|
|
f)
|
|
))
|
|
|
|
(define-syntax @@mk-super-inits
|
|
(syntax-rules ()
|
|
((_ supers)
|
|
(list))
|
|
((_ supers s1 ...)
|
|
(list (@@mk-super-init s1) ...))
|
|
))
|
|
|
|
(define-syntax @@mk-persist-def
|
|
(syntax-rules ()
|
|
((_ this supers (persist doc (a b)))
|
|
(begin
|
|
(hash-set! this 'a (lambda () (@@cache-get this 'a b)))
|
|
(hash-set! this (string->symbol (format "~a!" 'a))
|
|
(lambda (v) (@@cache-set! this 'a v) v))))
|
|
((_ this supers (persist (a b)))
|
|
(begin
|
|
(hash-set! this 'a (lambda () (@@cache-get this 'a b)))
|
|
(hash-set! this (string->symbol (format "~a!" 'a))
|
|
(lambda (v) (@@cache-set! this 'a v) v))))
|
|
))
|
|
|
|
(define-syntax @@mk-var-def
|
|
(syntax-rules ()
|
|
((_ this supers (doc (a b)))
|
|
(begin
|
|
(define a b)
|
|
(hash-set! this 'a (lambda () a))
|
|
(hash-set! this (string->symbol (format "~a!" 'a))
|
|
(lambda (v) (set! a v) a))))
|
|
((_ this supers (a b))
|
|
(begin
|
|
(define a b)
|
|
(hash-set! this 'a (lambda () a))
|
|
(hash-set! this (string->symbol (format "~a!" 'a))
|
|
(lambda (v) (set! a v) a))))
|
|
))
|
|
|
|
(define-for-syntax (@@guard-persist-doc pd stx)
|
|
(unless (or (eq? pd 'persist) (string? pd))
|
|
(let ((ind (if (symbol? pd) pd (string->symbol (format "~a" pd)))))
|
|
(raise-syntax-error #f
|
|
"keyword 'persist' or documentation expected"
|
|
(cadddr (syntax->datum stx))))))
|
|
|
|
(define-for-syntax (@@guard-persist p stx)
|
|
(unless (eq? p 'persist)
|
|
(let ((ind (if (symbol? p) p (string->symbol (format "~a" p)))))
|
|
(raise-syntax-error #f "keyword 'persist' expected"
|
|
(cadddr (syntax->datum stx))))))
|
|
|
|
(define-for-syntax (@@guard-doc d stx)
|
|
(unless (string? d)
|
|
(raise-syntax-error #f "documentation expected"
|
|
(cadddr (syntax->datum stx)))))
|
|
|
|
(define-for-syntax (@@guard-identifier i stx)
|
|
(unless (and (identifier? i) (not (symbol? i)))
|
|
(raise-syntax-error #f "identifier expected"
|
|
(cadddr (syntax->datum stx)))))
|
|
|
|
(define-for-syntax (@@guard-func-identifier f-def stx)
|
|
(let ((i (car (syntax-e f-def))))
|
|
(unless (and (identifier? i) (not (symbol? i)))
|
|
(raise-syntax-error #f "identifier expected"
|
|
(cadddr (syntax->datum stx))))))
|
|
|
|
|
|
(define-syntax (@@mk-persist stx)
|
|
(syntax-case stx ()
|
|
[(@@mk-persist this supers (p doc (a b)))
|
|
(let ((pp (syntax->datum #'p))
|
|
(dd (syntax->datum #'doc)))
|
|
(@@guard-persist pp stx)
|
|
(@@guard-doc dd stx)
|
|
(if (eq? pp 'persist)
|
|
#'(begin
|
|
(hash-set! this 'a (lambda () (@@cache-get this 'a b)))
|
|
(hash-set! this (string->symbol (format "~a!" 'a))
|
|
(lambda (v) (@@cache-set! this 'a v) v)))
|
|
#'(begin
|
|
(define a b)
|
|
(hash-set! this 'a (lambda () a))
|
|
(hash-set! this (string->symbol (format "~a!" 'a))
|
|
(lambda (v) (set! a v) v)))
|
|
))]
|
|
[(@@mk-persist this supers (p (a b)))
|
|
(let ((pp (syntax->datum #'p)))
|
|
(@@guard-persist-doc pp stx)
|
|
(if (eq? pp 'persist)
|
|
#'(begin
|
|
(hash-set! this 'a (lambda () (@@cache-get this 'a b)))
|
|
(hash-set! this (string->symbol (format "~a!" 'a))
|
|
(lambda (v) (@@cache-set! this 'a v) v)))
|
|
#'(begin
|
|
(define a b)
|
|
(hash-set! this 'a (lambda () a))
|
|
(hash-set! this (string->symbol (format "~a!" 'a))
|
|
(lambda (v) (set! a v) v)))
|
|
))]
|
|
[(@@mk-persist this supers (a b))
|
|
(begin
|
|
(@@guard-identifier #'a stx)
|
|
#'(begin
|
|
(define a b)
|
|
(hash-set! this 'a (lambda () a))
|
|
(hash-set! this (string->symbol (format "~a!" 'a))
|
|
(lambda (v) (set! a v) v))))
|
|
]
|
|
))
|
|
|
|
(define-syntax (@@mk-doc-method stx)
|
|
(syntax-case stx ()
|
|
[(@@mk-method this supers (doc ((f ...) expr ...)))
|
|
(let ((dd (syntax->datum #'doc))
|
|
(ff #'(f ...)))
|
|
;(display "form1:")(display (syntax->datum ff))(newline)
|
|
(@@guard-doc dd stx)
|
|
(@@guard-func-identifier ff stx)
|
|
#'(begin
|
|
(define (f ...) expr ...)
|
|
(hash-set! this (@@mk-name f ...) (@@mk-proc f ...))
|
|
))]
|
|
[(@@mk-method this supers (doc ((f ... . b) expr ...)))
|
|
(let ((dd (syntax->datum #'doc)))
|
|
;(display "form4:")(display (syntax->datum #'(f ...)))(newline)
|
|
(@@guard-doc dd stx)
|
|
(@@guard-func-identifier #'(f ...) stx)
|
|
#'(begin
|
|
(define (f ... . b) expr ...)
|
|
(hash-set! this (@@mk-name f ...) (@@mk-proc f ...))
|
|
))]
|
|
))
|
|
|
|
(define-syntax (@@mk-method stx)
|
|
(syntax-case stx ()
|
|
[(@@mk-method this supers ((f ...) expr ...))
|
|
(begin
|
|
;(display "form2:")(display (syntax->datum #'(f ...)))(newline)
|
|
(@@guard-func-identifier #'(f ...) stx)
|
|
#'(begin
|
|
(define (f ...) expr ...)
|
|
(hash-set! this (@@mk-name f ...) (@@mk-proc f ...))
|
|
))]
|
|
[(@@mk-method this supers ((f ... . b) expr ...))
|
|
(begin
|
|
;(display "form3:")(display (syntax->datum #'(f ...)))(newline)
|
|
(@@guard-func-identifier #'(f ...) stx)
|
|
#'(begin
|
|
(define (f ... . b) expr ...)
|
|
(hash-set! this (@@mk-name f ...) (@@mk-proc f ...))
|
|
))]
|
|
))
|
|
|
|
(define-syntax @@mk-body*
|
|
(syntax-rules ()
|
|
((_ this supers (doc ((f) expr ...)))
|
|
(@@mk-doc-method this supers (doc ((f) expr ...))))
|
|
((_ this supers (doc ((f . b) expr ...)))
|
|
(@@mk-doc-method this supers (doc ((f . b) expr ...))))
|
|
((_ this supers (doc ((f a ... . b) expr ...)))
|
|
(@@mk-doc-method this supers (doc ((f a ... . b) expr ...))))
|
|
((_ this supers ((f) expr ...))
|
|
(@@mk-method this supers ((f) expr ...)))
|
|
((_ this supers ((f a ...) expr ...))
|
|
(@@mk-method this supers ((f a ...) expr ...)))
|
|
((_ this supers ((f a ... . b) expr ...))
|
|
(@@mk-method this supers ((f a ... . b) expr ...)))
|
|
((_ this supers ((f . b) expr ...))
|
|
(@@mk-method this supers ((f . b) expr ...)))
|
|
((_ this supers (doc ((f a ...) expr ...)))
|
|
(@@mk-doc-method this supers (doc ((f a ...) expr ...))))
|
|
((_ this supers (persist doc (a b)))
|
|
(@@mk-persist this supers (persist doc (a b))))
|
|
((_ this supers (doc (a b)))
|
|
(@@mk-persist this supers (doc (a b))))
|
|
((_ this supers (a b))
|
|
(@@mk-persist this supers (a b)))
|
|
))
|
|
|
|
(define-syntax (@@mk-keyw stx)
|
|
(syntax-case stx ()
|
|
((_ this keyw)
|
|
(begin
|
|
;(printf "mk-keyw: ~a" (syntax->datum #'keyw))
|
|
#'(hash-set! this 'keyw (lambda () #f))))
|
|
((_ this keyw body ...)
|
|
(begin
|
|
;(printf "mk-keyw: ~a" (syntax->datum #'keyw))
|
|
#'(hash-set! this 'keyw (lambda () body ...))))
|
|
))
|
|
|
|
(define-syntax (@@mk-body stx)
|
|
(syntax-case stx ()
|
|
((_ this supers (keyw))
|
|
(let ((kw (syntax->datum #'keyw)))
|
|
(if (or (eq? kw 'init)
|
|
(eq? kw 'finalize))
|
|
#'(@@mk-keyw this keyw)
|
|
#'(@@mk-body* this supers (keyw)))))
|
|
((_ this supers (keyw a ...))
|
|
(let ((kw (syntax->datum #'keyw)))
|
|
(if (or (eq? kw 'init)
|
|
(eq? kw 'finalize))
|
|
#'(@@mk-keyw this keyw a ...)
|
|
#'(@@mk-body* this supers (keyw a ...)))))
|
|
((_ this supers any)
|
|
#'(@@mk-body* this supers any))
|
|
))
|
|
|
|
(define-syntax @@mk-bodies
|
|
(syntax-rules ()
|
|
((_ this supers (b1 ...))
|
|
(begin
|
|
(@@mk-body this supers b1)
|
|
...))))
|
|
|
|
(define-syntax @@mk-result
|
|
(syntax-rules ()
|
|
((_ (cl . args) val)
|
|
(set! cl val))))
|
|
|
|
(define (@@find-func f objs)
|
|
(if (null? objs)
|
|
#f
|
|
(let ((h (roos-object*-this (car objs))))
|
|
(if (hash-ref h f #f)
|
|
(hash-ref h f)
|
|
(let ((ff (@@find-func f (roos-object*-supers (car objs)))))
|
|
(if ff
|
|
ff
|
|
(@@find-func f (cdr objs))))))))
|
|
|
|
|
|
(define-syntax (@@guard-this stx)
|
|
(syntax-case stx ()
|
|
((_ this)
|
|
(begin
|
|
(unless (eq? (syntax->datum #'this) 'this)
|
|
(raise-syntax-error #f "Keyword 'this' expected" (cadr (syntax->datum stx))))
|
|
#'#t
|
|
))))
|
|
|
|
(define-syntax (@@guard-supers stx)
|
|
(syntax-case stx ()
|
|
((_ supers)
|
|
(begin
|
|
(unless (eq? (syntax->datum #'supers) 'supers)
|
|
(raise-syntax-error #f "Keyword 'supers' expected" (cadr (syntax->datum stx))))
|
|
#'#t
|
|
))))
|
|
|
|
|
|
(define-syntax @@check-keywords
|
|
(syntax-rules ()
|
|
((_ this supers . args)
|
|
(begin
|
|
(@@guard-this this)
|
|
(@@guard-supers supers)))))
|
|
|
|
(define (@@has-persist syntax count)
|
|
;(display "has-persist ")(display count)(display " ")(display syntax)(newline)
|
|
(if (null? syntax)
|
|
#f
|
|
(let ((b (car syntax)))
|
|
(if (list? b)
|
|
(if (null? b)
|
|
(@@has-persist (cdr syntax) (+ count 1))
|
|
(if (eq? (car b) 'persist)
|
|
#t
|
|
(@@has-persist (cdr syntax) (+ count 1))))
|
|
(@@has-persist (cdr syntax) (+ count 1))))))
|
|
|
|
|
|
(define-syntax @@finalize
|
|
(syntax-rules ()
|
|
((_ this (body ...))
|
|
(let ((has-persist (@@has-persist '(body ...) 0)))
|
|
(if has-persist
|
|
(let ((our-finalizer (hash-ref (roos-object*-this this) 'finalize)))
|
|
(when (not our-finalizer)
|
|
(set! our-finalizer (lambda () #t)))
|
|
(hash-set! (roos-object*-this this) 'finalize 'finalizer-registered)
|
|
(register-finalizer this
|
|
(lambda (obj)
|
|
; First call our own finalizer
|
|
(our-finalizer)
|
|
; Next delete from storage
|
|
(@@cache-delete! obj))))
|
|
(let ((f (hash-ref (roos-object*-this this) 'finalize)))
|
|
(unless (eq? f #f)
|
|
(register-finalizer this (lambda (obj) (f)))))))
|
|
)
|
|
))
|
|
|
|
|
|
(define-syntax def-roos-body
|
|
(syntax-rules ()
|
|
((_ cl-decl this (supers ...)
|
|
body
|
|
...)
|
|
(begin
|
|
(@@check-keywords this supers ...)
|
|
(define this (make-hasheq))
|
|
|
|
(hash-set! this 'finalize #f)
|
|
|
|
(@@mk-body this (supers ...) (roos-id (@@new-id)))
|
|
|
|
(@@mk-supers supers ...)
|
|
(@@mk-bodies this (supers ...) (body ...))
|
|
|
|
(define (@set-caller@ c)
|
|
(set-roos-object*-caller! this c)
|
|
(for-each (lambda (s)
|
|
((roos-object*-set-caller s) c))
|
|
(roos-object*-supers this)))
|
|
|
|
(define (@caller@ f . args)
|
|
(let ((ff (@@find-func f (list this))))
|
|
(if ff
|
|
(apply ff args)
|
|
(error (format "~a: ~a - no such member." (roos-object*-classname this) f)))))
|
|
|
|
(set! this (roos-object*
|
|
this
|
|
(@@mk-proc supers ...)
|
|
(@@mk-name cl-decl)
|
|
(@@mk-proc cl-decl)
|
|
@set-caller@
|
|
@caller@))
|
|
(@set-caller@ @caller@)
|
|
|
|
(@@finalize this (body ...))
|
|
|
|
(unless (eq? (hash-ref (roos-object*-this this) 'init #f) #f)
|
|
((hash-ref (roos-object*-this this) 'init)))
|
|
|
|
this
|
|
)
|
|
)
|
|
))
|
|
|
|
(define-syntax def-roos
|
|
(syntax-rules ()
|
|
((_ (cl) this (supers ...) body ...)
|
|
(begin
|
|
(define (cl)
|
|
(def-roos-body cl this (supers ...) body ...))
|
|
(@@mk-result (cl)
|
|
(roos-class* (@@mk-proc cl)
|
|
(@@mk-name cl)
|
|
(@@mk-member-infos body ...)
|
|
(@@mk-super-infos supers ...)
|
|
'(cl)))))
|
|
((_ (cl . a) this (supers ...) body ...)
|
|
(begin
|
|
(define (cl . a)
|
|
(def-roos-body (cl . a) this (supers ...) body ...))
|
|
(@@mk-result (cl . a)
|
|
(roos-class* (@@mk-proc cl)
|
|
(@@mk-name cl)
|
|
(@@mk-member-infos body ...)
|
|
(@@mk-super-infos supers ...)
|
|
'(cl . a)))))
|
|
((_ (cl a ...) this (supers ...) body ...)
|
|
(begin
|
|
(define (cl a ...)
|
|
(def-roos-body (cl a ...) this (supers ...) body ...))
|
|
(@@mk-result (cl a ...)
|
|
(roos-class* (@@mk-proc cl)
|
|
(@@mk-name cl)
|
|
(@@mk-member-infos body ...)
|
|
(@@mk-super-infos supers ...)
|
|
'(cl a ...)))))
|
|
((_ (cl a ... . b) this (supers ...) body ...)
|
|
(begin
|
|
(define (cl a ... . b)
|
|
(def-roos-body (cl a ... . b) this (supers ...) body ...))
|
|
(@@mk-result (cl a ... . b)
|
|
(roos-class* (@@mk-proc cl)
|
|
(@@mk-name cl)
|
|
(@@mk-member-infos body ...)
|
|
(@@mk-super-infos supers ...)
|
|
'(cl a ... . b)))))
|
|
((_ cl this supers body ...)
|
|
(error (string-append
|
|
"Wrong roos definition\n"
|
|
"Define roos classes as follows:\n\n"
|
|
"(def-roos (cl ...) this (supers ...)\n"
|
|
" (attr value)\n"
|
|
" (persist (attr value))\n"
|
|
" (\"documentation\" (attr value))\n"
|
|
" (persist \"documentation\" (attr value))\n"
|
|
"\n"
|
|
" ((method ...) body ...)\n"
|
|
" (\"documentation\" ((method ...) body ...))\n"
|
|
"\n"
|
|
" (init expr ...) ; optional initializer\n"
|
|
" (finalize expr ...) ; optional finalizer\n"
|
|
")\n")))
|
|
))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Class Instantiation
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-syntax @-*
|
|
(syntax-rules ()
|
|
((_ cl . args)
|
|
(roos-class*-closure cl))))
|
|
|
|
(define-syntax %-!
|
|
(syntax-rules ()
|
|
((_ cl)
|
|
(if (roos-class*? cl)
|
|
((@-* cl))
|
|
(error "Not a roos class")))
|
|
((_ cl a ...)
|
|
(if (roos-class*? cl)
|
|
((@-* cl) a ...)
|
|
(error "Not a roos class")))
|
|
))
|
|
|
|
(define-syntax roos-new
|
|
(syntax-rules ()
|
|
((_ cl ...)
|
|
(%-! cl ...))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Calling methods / attributes
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (@@is-supers*? objs)
|
|
(if (null? objs)
|
|
#t
|
|
(if (roos-object*? (car objs))
|
|
(@@is-supers*? (cdr objs))
|
|
#f)))
|
|
|
|
(define (@@is-supers? objs)
|
|
(if (list? objs)
|
|
(if (null? objs)
|
|
#f
|
|
(@@is-supers*? objs))
|
|
#f))
|
|
|
|
(define-syntax %->>
|
|
(syntax-rules ()
|
|
((_ obj f)
|
|
(if (roos-object*? obj)
|
|
(let ((f (@@find-func 'f (list obj))))
|
|
(if f
|
|
f
|
|
(if (@@is-supers? obj)
|
|
(let ((f (@@find-func 'f obj)))
|
|
(if f
|
|
f
|
|
(error (format "~a: ~a - no such member"
|
|
(roos-object*-classname obj)
|
|
'f
|
|
))))
|
|
(error "Not a list of roos objects (supers)"))))
|
|
(error "Not a roos object")))))
|
|
|
|
(define-syntax with-roos-obj
|
|
(syntax-rules ()
|
|
((_ obj (m1 ...) body ...)
|
|
(let* ((m1 (%->> obj m1))
|
|
...)
|
|
body
|
|
...))))
|
|
|
|
(define-syntax @@mk-call
|
|
(syntax-rules ()
|
|
((_ g (f))
|
|
(g))
|
|
((_ g (f a ...))
|
|
(g a ...))
|
|
))
|
|
|
|
(define (@@find-> obj name)
|
|
(if (roos-object*? obj)
|
|
(let ((f (@@find-func name (list obj))))
|
|
(if f
|
|
f
|
|
(error (format "~a: ~a - no such member"
|
|
(roos-object*-classname obj)
|
|
name))))
|
|
(if (@@is-supers? obj)
|
|
(let ((f (@@find-func name obj)))
|
|
(if f
|
|
f
|
|
(error (format "~a: ~a - no such member"
|
|
(roos-object*-classname obj)
|
|
name))))
|
|
(error "Not a roos object of roos supers"))))
|
|
|
|
(define-syntax @->
|
|
(syntax-rules ()
|
|
((_ caller f)
|
|
(caller 'f))
|
|
((_ caller f a ...)
|
|
(caller 'f a ...))
|
|
))
|
|
|
|
(define-syntax %->
|
|
(syntax-rules ()
|
|
((_ obj f ...)
|
|
(if (roos-object*? obj)
|
|
(@-> (roos-object*-caller obj) f ...)
|
|
(let ((g (@@find-> obj (@@mk-name f ...))))
|
|
(@@mk-call g (f ...)))))
|
|
))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Introspection / Predicates
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define roos-obj? roos-object*?)
|
|
(define roos-object? roos-object*?)
|
|
(define roos-class? roos-class*?)
|
|
|
|
(define (roos-id obj)
|
|
(%-> obj roos-id))
|
|
|
|
(define (roos-id! obj id)
|
|
(%-> obj roos-id! id))
|
|
|
|
(define (roos-class cl-obj)
|
|
(if (roos-object*? cl-obj)
|
|
(roos-object*-the-class cl-obj)
|
|
(if (roos-class*? cl-obj)
|
|
cl-obj
|
|
(error "Not a roos object or class"))))
|
|
|
|
(define-syntax roos-classname
|
|
(syntax-rules ()
|
|
((_ cl-obj)
|
|
(if (roos-object*? cl-obj)
|
|
(roos-object*-classname cl-obj)
|
|
(if (roos-class*? cl-obj)
|
|
'cl-obj
|
|
(error "Not a roos object or class"))))
|
|
))
|
|
|
|
(define (@@get-members-cl cl funcs)
|
|
(let ((filter-f (if (null? funcs)
|
|
(lambda x #t)
|
|
(let ((s (list->seteq funcs)))
|
|
(lambda (e) (set-member? s (car e)))))))
|
|
(filter filter-f (roos-class*-members cl))))
|
|
|
|
(define (@@get-super-members-obj s-objs s)
|
|
(if (null? s-objs)
|
|
'()
|
|
(let ((s-obj (car s-objs)))
|
|
(let ((members (roos-class*-members (roos-object*-the-class s-obj))))
|
|
(let ((s-obj-members (filter (lambda (e)
|
|
(not (set-member? s (car e))))
|
|
members)))
|
|
(for-each (lambda (m)
|
|
(set-add! s (car m))) s-obj-members)
|
|
(append s-obj-members
|
|
(@@get-super-members-obj (roos-object*-supers s-obj) s)
|
|
(@@get-super-members-obj (cdr s-objs) s))
|
|
)))
|
|
))
|
|
|
|
(define (@@get-members-obj obj . funcs)
|
|
(let ((filter-f (if (null? funcs)
|
|
(lambda x #t)
|
|
(let ((s (list->seteq funcs)))
|
|
(lambda (e) (set-member? s (car e)))))))
|
|
(let ((cl (roos-object*-the-class obj)))
|
|
(let* ((m (roos-class*-members cl))
|
|
(s (list->mutable-seteq (map (lambda (e) (car e)) m))))
|
|
(let ((supers (@@get-super-members-obj (roos-object*-supers obj) s)))
|
|
(filter filter-f (append m supers)))))))
|
|
|
|
(define (@@travel-obj-hierarchy f obj)
|
|
(letrec ((g (lambda (depth obj)
|
|
(f depth obj)
|
|
(for-each (lambda (o)
|
|
(g (+ depth 1) o))
|
|
(roos-object*-supers obj)))))
|
|
(g 0 obj)))
|
|
|
|
(define-syntax @@mk-hlp-mems
|
|
(syntax-rules ()
|
|
((_ cl-obj)
|
|
'())
|
|
((_ cl-obj f ...)
|
|
(list 'f ...))))
|
|
|
|
(define (roos-help* cl-obj . symbols)
|
|
(let* ((is-class (roos-class*? cl-obj))
|
|
(is-obj (roos-object*? cl-obj))
|
|
(funcs symbols)
|
|
(no-funcs (null? funcs)))
|
|
(let ((cln (if is-class
|
|
(roos-class*-name cl-obj)
|
|
(roos-object*-classname cl-obj)))
|
|
(cl (if is-class
|
|
cl-obj
|
|
(roos-object*-the-class cl-obj)))
|
|
)
|
|
(when no-funcs
|
|
(begin
|
|
(printf "Roos class: ~a\n" cln)
|
|
|
|
(let ((re #px"^[(](.*)[)]$"))
|
|
(printf " Instantiation: (-! ~a)\n"
|
|
(cadr (regexp-match re
|
|
(format "~a" (roos-class*-decl cl))))))
|
|
|
|
(let ((inits (roos-class*-super-inits cl)))
|
|
(unless (null? inits)
|
|
(printf " Supers initializators:~a\n" (apply string-append
|
|
(map (lambda (x) (format " ~a" x))
|
|
inits)))))
|
|
(when is-obj
|
|
(begin
|
|
(printf " Object class hierarchy:\n")
|
|
(@@travel-obj-hierarchy
|
|
(lambda (depth obj)
|
|
(printf " ~a~a~a~a\n"
|
|
(make-string depth #\space)
|
|
(if (= depth 0) "" #\|)
|
|
(make-string (* depth 3) #\-)
|
|
(roos-object*-classname obj)))
|
|
cl-obj)))
|
|
|
|
(printf " ~a members:\n" (if is-class "Class" "Object"))))
|
|
|
|
(if is-class
|
|
(let ((ind (if no-funcs " " "")))
|
|
(for-each (lambda (m)
|
|
(printf "~a~a~a\n"
|
|
ind
|
|
(cadr m)
|
|
(if (string=? (caddr m) "")
|
|
""
|
|
(format ": ~a" (caddr m)))))
|
|
(@@get-members-cl cl-obj funcs)))
|
|
(let ((s (mutable-seteq)))
|
|
(@@travel-obj-hierarchy
|
|
(lambda (_depth obj)
|
|
(let ((cl (roos-object*-the-class obj))
|
|
(cln (roos-object*-classname obj))
|
|
(ind (if no-funcs " " ""))
|
|
(depth (if no-funcs _depth 0)))
|
|
(let ((members
|
|
(filter (lambda (m)
|
|
(not (set-member? s (car m))))
|
|
(@@get-members-cl cl funcs))))
|
|
(for-each (lambda (m)
|
|
(set-add! s (car m))) members)
|
|
(unless (null? members)
|
|
(let ((starter (format "~a~a~a~a"
|
|
(make-string depth #\space)
|
|
(if (= depth 0) "" "|")
|
|
(make-string (* depth 3) #\-)
|
|
cln)))
|
|
(printf "~a~a - ~a~a\n"
|
|
ind
|
|
starter
|
|
(cadr (car members))
|
|
(if (string=? (caddr (car members)) "")
|
|
""
|
|
(format ": ~a" (caddr (car members)))))
|
|
(let ((indent (make-string ( * depth 3) #\space))
|
|
(line (make-string
|
|
(string-length (symbol->string cln))
|
|
#\-)))
|
|
(for-each (lambda (m)
|
|
(if no-funcs
|
|
(printf "~a~a |~a ~a~a\n"
|
|
ind
|
|
indent
|
|
line
|
|
(cadr m)
|
|
(if (string=? (caddr m) "")
|
|
""
|
|
(format ": ~a" (caddr m))))
|
|
(printf "~a~a - ~a~a\n"
|
|
ind
|
|
starter
|
|
(cadr m)
|
|
(if (string=? (caddr m) "")
|
|
""
|
|
(format ": ~a" (caddr m))))
|
|
))
|
|
(cdr members))))))))
|
|
cl-obj)
|
|
|
|
(let ((cr ""))
|
|
(for-each (lambda (func)
|
|
(unless (set-member? s func)
|
|
(begin
|
|
(printf "~a~a is not a member\n" cr func)
|
|
(set! cr ""))))
|
|
funcs)
|
|
)
|
|
)) ; let s
|
|
)))
|
|
|
|
|
|
(define-syntax roos-help
|
|
(syntax-rules ()
|
|
((_ cl-obj)
|
|
(roos-help* cl-obj))
|
|
((_ cl-obj a ...)
|
|
(roos-help* cl-obj 'a ...))
|
|
))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Testing
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(module+ test
|
|
(require rackunit)
|
|
|
|
(define test-nr 0)
|
|
|
|
(define-syntax tst
|
|
(syntax-rules ()
|
|
((_ tst)
|
|
(begin
|
|
(set! test-nr (+ test-nr 1))
|
|
(printf "test ~a. ~a: " test-nr 'tst)
|
|
(let ((chk (check-true tst "failed")))
|
|
(printf "~a\n" (if chk "OK" "not oke"))
|
|
chk)))
|
|
((_ tst msg)
|
|
(begin
|
|
(set! test-nr (+ test-nr 1))
|
|
(printf "test ~a. ~a: " test-nr msg)
|
|
(let ((chk (check-true tst "failed")))
|
|
(printf "~a\n" (if chk "OK" "not oke"))
|
|
chk)))
|
|
))
|
|
|
|
(test-case
|
|
"Simple ROOS declaration and usage"
|
|
(def-roos (t1) this (supers) (a 10))
|
|
(let ((obj (%-! t1)))
|
|
(check-true (= (%-> obj a) 10))
|
|
(%-> obj a! 12)
|
|
(check-true (= (%-> obj a) 12)))
|
|
)
|
|
|
|
(test-case
|
|
"ROOS declaration with supers"
|
|
(def-roos (a x) this (supers)
|
|
(y (+ x 4))
|
|
((g a) (* a (%-> this y))))
|
|
(def-roos (b) this (supers (roos-new a 2))
|
|
(y 55)
|
|
;("The v function gets and sets the y member of the super object of class a"
|
|
((v . a)
|
|
(if (null? a)
|
|
(%-> supers y)
|
|
(begin
|
|
(%-> supers y! (car a))
|
|
(%-> supers y))))
|
|
;)
|
|
)
|
|
(let ((bb (roos-new b)))
|
|
(tst (= (%-> bb y) 55))
|
|
(tst (= (%-> bb g 2) 110))
|
|
(tst (= (%-> bb v) 6))
|
|
(tst (= (%-> bb v 10) 10))
|
|
(tst (= (%-> bb g 3) 165))
|
|
(tst (= (%-> bb y! 10) 10))
|
|
(tst (= (%-> bb g 2) 20)))
|
|
)
|
|
|
|
(test-case
|
|
"ROOS al declaration variants"
|
|
(def-roos (decl) this (supers)
|
|
(a1 1)
|
|
(persist (a2 2))
|
|
("a3 doc" (a3 3))
|
|
(persist "a4 doc" (a4 4))
|
|
((f1) (+ 2 3) (* 3 3))
|
|
("f2-doc" ((f2) (* 3 3) (+ 2 2)))
|
|
((f3 a b) (* a b))
|
|
((f4 a . b) (cons a b))
|
|
("f5-doc" ((f5 a b) (* a b)))
|
|
("f6-doc" ((f6 a) (* a a a)))
|
|
("f7-doc" ((f7 a . b) (cons a (cons (length b) (cons a b)))))
|
|
("f8-doc" ((f8 . b) (append b b)))
|
|
((f9 . c) (append c c))
|
|
((f10 a b . d)
|
|
(cons (list a b) d))
|
|
("f11-doc" ((f11 a b c d e . h) (cons (* a b c d e) h)))
|
|
)
|
|
(let ((o (%-! decl)))
|
|
(tst (= (%-> o a1) 1))
|
|
(tst (begin (%-> o a1! 33) (= (%-> o a1) 33)))
|
|
(tst (symbol? (%-> o roos-id)))
|
|
(tst (begin (printf "roos-id: ~a " (%-> o roos-id)) #t) "Displaying roos id of object")
|
|
(tst (eq? (%-> o roos-id! 'my-id) 'my-id))
|
|
(tst (begin (printf "roos-id: ~a " (%-> o roos-id)) #t) "Displaying roos id of object after set")
|
|
(%-> o a2! 99)
|
|
(tst (= (%-> o a2) 99))
|
|
(tst (begin (printf "storage: ~a " @@storage@@) #t))
|
|
(tst (= (hash-ref (hash-ref (hash-ref @@storage@@ 'decl) 'my-id ) 'a2) 99))
|
|
(let ((o1 (%-! decl)))
|
|
(tst (eq? (%-> o1 roos-id! 'my-id) 'my-id) "Don't do this at home: giving new object same id as existing object")
|
|
(tst (begin (printf "o1 %-> a2: ~a " (%-> o1 a2)) #t) "a2 = o1 %-> a2")
|
|
(tst (= (%-> o1 a2) (%-> o a2)))
|
|
(tst (equal? (%-> o1 a2! "hoi") "hoi"))
|
|
(tst (string=? (%-> o a2) "hoi"))
|
|
)
|
|
(collect-garbage)
|
|
(tst (= (%-> o a2) 2) "After collection of o1, o will be deleted from storage")
|
|
)
|
|
(def-roos (t1) this (supers)
|
|
(x 8))
|
|
(def-roos (t2 a) this (supers)
|
|
(x a))
|
|
(tst (= (%-> (%-! t2 5) x) 5))
|
|
(def-roos (t3 . a) this (supers)
|
|
((f y) (map (lambda (x) (* x y)) a)))
|
|
(tst (equal? (%-> (%-! t3 4 5 6) f 2) '(8 10 12)))
|
|
(def-roos (t4 a b c . d) this (supers (%-! t3 a b c))
|
|
((g y) (cons (map (lambda (x) (+ x y))
|
|
(%-> supers f y)) (map (lambda (x) (* x y)) d)))
|
|
)
|
|
(tst (let ((r (%-> (%-! t4 2 3 4 12 13) g 2))
|
|
(R '((6 8 10) 24 26)))
|
|
(equal? r R)))
|
|
|
|
)
|
|
) |