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

Changes -> and -! to %-> and %-!, because of too many name clashes in racket for ->.

Browse Source
This commit is contained in:
Hans Dijkema
2025-08-18 09:18:58 +02:00
parent 6ce0a99f15
commit 7fc601d33c
4 changed files with 92 additions and 92 deletions
Download Patch File Download Diff File Expand all files Collapse all files

98
main.rkt
View File

@@ -7,10 +7,10 @@
(require finalizer)
(provide def-roos
-!
%-!
roos-new
->
->>
%->
%->>
roos-class?
roos-object?
@@ -37,7 +37,7 @@
(define (@@cache-get obj var default)
(let ((cl-hash (hash-ref @@storage@@ (roos-classname obj) (make-hasheq))))
(let ((id (-> obj roos-id)))
(let ((id (%-> obj roos-id)))
(let ((obj-hash (hash-ref cl-hash id (make-hasheq))))
(hash-ref obj-hash var default)))))
@@ -46,7 +46,7 @@
(unless cl-hash
(set! cl-hash (make-hasheq))
(hash-set! @@storage@@ (roos-classname obj) cl-hash))
(let ((id (-> obj roos-id)))
(let ((id (%-> obj roos-id)))
(let ((obj-hash (hash-ref cl-hash id #f)))
(unless obj-hash
(set! obj-hash (make-hasheq))
@@ -58,7 +58,7 @@
(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)))))
(hash-remove! cl-hash (%-> obj roos-id)))))
(define (@@cache-stop-deleting yn)
(set! @@stop-deleting@@ yn))
@@ -610,7 +610,7 @@
((_ cl . args)
(roos-class*-closure cl))))
(define-syntax -!
(define-syntax %-!
(syntax-rules ()
((_ cl)
(if (roos-class*? cl)
@@ -625,7 +625,7 @@
(define-syntax roos-new
(syntax-rules ()
((_ cl ...)
(-! cl ...))))
(%-! cl ...))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Calling methods / attributes
@@ -645,7 +645,7 @@
(@@is-supers*? objs))
#f))
(define-syntax ->>
(define-syntax %->>
(syntax-rules ()
((_ obj f)
(if (roos-object*? obj)
@@ -666,7 +666,7 @@
(define-syntax with-roos-obj
(syntax-rules ()
((_ obj (m1 ...) body ...)
(let* ((m1 (->> obj m1))
(let* ((m1 (%->> obj m1))
...)
body
...))))
@@ -704,7 +704,7 @@
(caller 'f a ...))
))
(define-syntax ->
(define-syntax %->
(syntax-rules ()
((_ obj f ...)
(if (roos-object*? obj)
@@ -722,10 +722,10 @@
(define roos-class? roos-class*?)
(define (roos-id obj)
(-> obj roos-id))
(%-> obj roos-id))
(define (roos-id! obj id)
(-> obj roos-id! id))
(%-> obj roos-id! id))
(define (roos-class cl-obj)
(if (roos-object*? cl-obj)
@@ -944,36 +944,36 @@
(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)))
(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))))
((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)
(%-> supers y)
(begin
(-> supers y! (car a))
(-> supers y))))
(%-> 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)))
(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
@@ -996,40 +996,40 @@
(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))
(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"))
(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")
(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))
(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))
(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)))
(%-> supers f y)) (map (lambda (x) (* x y)) d)))
)
(tst (let ((r (-> (-! t4 2 3 4 12 13) g 2))
(tst (let ((r (%-> (%-! t4 2 3 4 12 13) g 2))
(R '((6 8 10) 24 26)))
(equal? r R)))