original commit: b90d5cb4e3a155b8b1945653234e77a2f99e78ac
This commit is contained in:
Matthew Flatt 2002-06-12 14:48:19 +00:00
parent 93f48397ab
commit e67b821adb
2 changed files with 44 additions and 24 deletions

View File

@ -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

View 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)