hans/roos
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Small problems with declaration on top level.

Browse Source
This commit is contained in:
Hans Dijkema
2025-07-08 17:23:49 +02:00
parent c568f621d2
commit 95e5e24094
2 changed files with 80 additions and 78 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
info.rkt
View File

@@ -1,7 +1,7 @@
#lang info #lang info
(define pkg-authors '(hnmdijkema)) (define pkg-authors '(hnmdijkema))
(define version "0.6") (define version "0.61")
(define license 'Apache-2.0) (define license 'Apache-2.0)
(define collection "roos") (define collection "roos")
(define pkg-desc "An OO Framework for Racket") (define pkg-desc "An OO Framework for Racket")

156
main.rkt
View File

@@ -103,13 +103,19 @@
(define-syntax @@mk-name (define-syntax @@mk-name
(syntax-rules () (syntax-rules ()
((_ (f . args))
'f)
((_ f . args) ((_ f . args)
'f))) 'f)
))
(define-syntax @@mk-proc (define-syntax @@mk-proc
(syntax-rules () (syntax-rules ()
((_ (f . args))
f)
((_ f . args) ((_ f . args)
f))) f)
))
(define-syntax @@mk-super-infos (define-syntax @@mk-super-infos
(syntax-rules () (syntax-rules ()
@@ -426,53 +432,88 @@
#'#t)) #'#t))
)) ))
(define-syntax def-roos
(define-syntax def-roos-body
(syntax-rules () (syntax-rules ()
((_ (cl ...) this (supers ...) ((_ cl-decl this (supers ...)
body body
...) ...)
(begin (begin
(define (cl ...) (@@check-keywords this supers ...)
(@@check-keywords this supers ...) (define this (make-hasheq))
(define this (make-hasheq))
(@@mk-body this (supers ...) (roos-id (@@new-id))) (@@mk-body this (supers ...) (roos-id (@@new-id)))
(@@mk-supers supers ...) (@@mk-supers supers ...)
(@@mk-bodies this (supers ...) (body ...)) (@@mk-bodies this (supers ...) (body ...))
(define (@set-caller@ c) (define (@set-caller@ c)
(set-roos-object*-caller! this c) (set-roos-object*-caller! this c)
(for-each (lambda (s) (for-each (lambda (s)
((roos-object*-set-caller s) c)) ((roos-object*-set-caller s) c))
(roos-object*-supers this))) (roos-object*-supers this)))
(define (@caller@ f . args) (define (@caller@ f . args)
(let ((ff (@@find-func f (list this)))) (let ((ff (@@find-func f (list this))))
(if ff (if ff
(apply ff args) (apply ff args)
(error "No such member")))) (error "No such member"))))
(set! this (roos-object* (set! this (roos-object*
this this
(@@mk-proc supers ...) (@@mk-proc supers ...)
(@@mk-name cl ...) (@@mk-name cl-decl)
(@@mk-proc cl ...) (@@mk-proc cl-decl)
@set-caller@ @set-caller@
@caller@)) @caller@))
(@set-caller@ @caller@) (@set-caller@ @caller@)
(@@finalize this body ...) (@@finalize this body ...)
this this
) )
(@@mk-result (cl ...) )
(roos-class* (@@mk-proc cl ...) ))
(@@mk-name cl ...)
(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-member-infos body ...)
(@@mk-super-infos supers ...) (@@mk-super-infos supers ...)))))
)) ((_ (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 ...) 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 ... . 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 ...)))))
)) ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -774,44 +815,6 @@
;; Testing ;; Testing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(def-roos (test x) this (supers)
; ("y contains initially the value x" (y x))
; ("f calculates a times y" ((f a) (* a (-> this y)))))
;(def-roos (test1 x) this (supers (-! test x))
; ((g a) (* a a)))
;(def-roos (a) this (supers)
; ((gg b) (+ b b b)))
;(def-roos (test2 x) this (supers (-! test x) (-! a))
; ("y redefines y of class test" (y x))
; ("Calculates some calculation" ((ff a) (+ a (-> this y) (-> this gg (-> this y))))))
;(define o (-* test 5))
;(define o1 (-* test1 6))
;(define o2 (-* test2 3))
;(def-roos (tst) this (supers)
; (count 0)
; ((g1 n)
; (-> this g n))
; ((g n)
; (set! count (+ count 1))
; (if (> n 0)
; (+ n (-> this g1 (- n 1)) (-> this g1 (- n 2)))
; n))
; ((t n)
; (set! count 0)
; (let ((v (-> this g n)))
; (values v count)))
; )
;(define ot (-* tst))
(module+ test (module+ test
(require rackunit) (require rackunit)
@@ -912,5 +915,4 @@
(tst (= (-> o a2) 2) "After collection of o1, o will be deleted from storage") (tst (= (-> o a2) 2) "After collection of o1, o will be deleted from storage")
) )
) )
) )