suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix breakage due to lazy contracts.

Browse Source 
- fix check for lazy-wrap property
- supply hash procedures for records defined with `define-record-type'
  (needed by the stepper)
This commit is contained in:
Mike Sperber 2010-05-20 19:55:12 +02:00
parent fb042df0c7
commit b4f010c6d5
3 changed files with 37 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/deinprogramm/contract/contract.rkt
View File

@ -21,7 +21,7 @@
procedure-contract-info? procedure-contract-info?
procedure-contract-info-arg-contracts procedure-contract-info-return-contract procedure-contract-info-arg-contracts procedure-contract-info-return-contract
make-lazy-wrap-info lazy-wrap-info-constructor lazy-wrap-info-raw-accessors make-lazy-wrap-info lazy-wrap-info-constructor lazy-wrap-info-raw-accessors
prop:lazy-wrap lazy-wrap-ref prop:lazy-wrap lazy-wrap? lazy-wrap-ref
make-struct-wrap-contract make-struct-wrap-contract
check-struct-wraps! check-struct-wraps!
contract=? contract<=?) contract=? contract<=?)
@ -393,7 +393,7 @@
ref-proc set!-proc)) ref-proc set!-proc))
; value should be a lazy-wrap-info ; value should be a lazy-wrap-info
(define-values (prop:lazy-wrap lazy-wrap lazy-wrap-ref) (define-values (prop:lazy-wrap lazy-wrap? lazy-wrap-ref)
(make-struct-type-property 'lazy-wrap)) (make-struct-type-property 'lazy-wrap))
(define (make-struct-wrap-contract name type-descriptor field-contracts syntax) (define (make-struct-wrap-contract name type-descriptor field-contracts syntax)

18
collects/deinprogramm/convert-explicit.scm
View File

@ -76,15 +76,15 @@
(or (hash-ref hash v #f) (or (hash-ref hash v #f)
(let-values (((ty skipped?) (struct-info v))) (let-values (((ty skipped?) (struct-info v)))
(cond (cond
((and ty (lazy-wrap-ref ty)) ((and ty (lazy-wrap? ty))
=> (lambda (lazy-wrap-info) (let ((lazy-wrap-info (lazy-wrap-ref ty)))
(let ((constructor (lazy-wrap-info-constructor lazy-wrap-info)) (let ((constructor (lazy-wrap-info-constructor lazy-wrap-info))
(raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info))) (raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info)))
(let ((val (apply constructor (map (lambda (raw-accessor) (let ((val (apply constructor (map (lambda (raw-accessor)
(recur (raw-accessor v))) (recur (raw-accessor v)))
raw-accessors)))) raw-accessors))))
(hash-set! hash v val) (hash-set! hash v val)
val)))) val))))
(else v))))) (else v)))))
(else (else
v))))) v)))))

27
collects/deinprogramm/define-record-procedures.scm
View File

@ -137,7 +137,9 @@
(access-record-fields r raw-generic-access number-of-fields) (access-record-fields r raw-generic-access number-of-fields)
port write?))) port write?)))
(cons prop:equal+hash (cons prop:equal+hash
(list record-equal? void void)) (list record-equal?
(make-equal-hash (lambda (r i) (raw-generic-access r i)) number-of-fields)
(make-equal2-hash (lambda (r i) (raw-generic-access r i)) number-of-fields)))
(cons prop:lazy-wrap (cons prop:lazy-wrap
(make-lazy-wrap-info constructor-proc (make-lazy-wrap-info constructor-proc
(list raw-accessor-proc ...) (list raw-accessor-proc ...)
@ -231,6 +233,29 @@
(cons (acc rec i) (cons (acc rec i)
(recur (+ i 1)))))) (recur (+ i 1))))))
(define (make-equal-hash generic-access field-count)
(lambda (r recur)
(let loop ((i 0)
(factor 1)
(hash 0))
(if (= i field-count)
hash
(loop (+ 1 i)
(* factor 33)
(+ hash (* factor (recur (generic-access r i)))))))))
(define (make-equal2-hash generic-access field-count)
(lambda (r recur)
(let loop ((i 0)
(factor 1)
(hash 0))
(if (= i field-count)
hash
(loop (+ 1 i)
(* factor 33)
(+ hash (* factor
(recur (generic-access r (- field-count i 1))))))))))
#| #|
(define-record-procedures :pare kons pare? (kar kdr)) (define-record-procedures :pare kons pare? (kar kdr))
(kons 1 (kons 2 (kons 3 (kons 5 (kons 6 (kons 7 (kons 8 "asdjkfdshfdsjkf"))))))) (kons 1 (kons 2 (kons 3 (kons 5 (kons 6 (kons 7 (kons 8 "asdjkfdshfdsjkf")))))))