.
original commit: b90d5cb4e3a155b8b1945653234e77a2f99e78ac
This commit is contained in:
parent
93f48397ab
commit
e67b821adb
|
@ -34,30 +34,26 @@
|
|||
|
||||
(define real-time current-milliseconds)
|
||||
|
||||
(define getprop (void))
|
||||
(define putprop (void))
|
||||
(let ([table (make-hash-table)])
|
||||
(letrec ([gp
|
||||
(case-lambda
|
||||
[(k prop) (gp k prop #f)]
|
||||
[(k prop def)
|
||||
(let ([al (hash-table-get table k (lambda () #f))])
|
||||
(if al
|
||||
(let ([v (assq prop al)])
|
||||
(if v
|
||||
(cdr v)
|
||||
def))
|
||||
def))])]
|
||||
[pp
|
||||
(lambda (k prop nv)
|
||||
(let ([al (hash-table-get table k (lambda () '()))])
|
||||
(let ([v (assq prop al)])
|
||||
(if v
|
||||
(set-cdr! v nv)
|
||||
(hash-table-put! table k (cons (cons prop nv) al))))))])
|
||||
(set! getprop gp)
|
||||
(set! putprop pp)))
|
||||
|
||||
(define table (make-hash-table))
|
||||
(define getprop
|
||||
(case-lambda
|
||||
[(k prop) (getprop k prop #f)]
|
||||
[(k prop def)
|
||||
(let ([al (hash-table-get table k (lambda () #f))])
|
||||
(if al
|
||||
(let ([v (assq prop al)])
|
||||
(if v
|
||||
(cdr v)
|
||||
def))
|
||||
def))]))
|
||||
(define putprop
|
||||
(lambda (k prop nv)
|
||||
(let ([al (hash-table-get table k (lambda () '()))])
|
||||
(let ([v (assq prop al)])
|
||||
(if v
|
||||
(set-cdr! v nv)
|
||||
(hash-table-put! table k (cons (cons prop nv) al)))))))
|
||||
|
||||
;; Chez's new-cafe
|
||||
(define new-cafe
|
||||
(letrec ([nc
|
||||
|
|
24
collects/tests/mzscheme/compat.ss
Normal file
24
collects/tests/mzscheme/compat.ss
Normal file
|
@ -0,0 +1,24 @@
|
|||
|
||||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'compat)
|
||||
|
||||
(require (lib "compat.ss"))
|
||||
|
||||
(define-structure (add left right) ([sum (+ left right)]))
|
||||
(test 9 add-sum (make-add 3 6))
|
||||
|
||||
|
||||
(test #f getprop 'hello-world 'any)
|
||||
(test 'oops getprop 'hello-world 'any 'oops)
|
||||
(test #f getprop 'hello-world 'any)
|
||||
(test (void) putprop 'hello-world 'any 'aha)
|
||||
(test 'aha getprop 'hello-world 'any)
|
||||
(test 'aha getprop 'hello-world 'any 'oops)
|
||||
(test #f getprop 'hello-world 'many)
|
||||
(test 'oops getprop 'hello-world 'many 'oops)
|
||||
(test #f getprop 'bye-world 'any)
|
||||
(test 'oops getprop 'bye-world 'any 'oops)
|
||||
|
||||
(report-errs)
|
Loading…
Reference in New Issue
Block a user