From b4f010c6d5283f7bbddafcdc638a520c9045dd16 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Thu, 20 May 2010 19:55:12 +0200 Subject: [PATCH] Fix breakage due to lazy contracts. - fix check for lazy-wrap property - supply hash procedures for records defined with `define-record-type' (needed by the stepper) --- collects/deinprogramm/contract/contract.rkt | 4 +-- collects/deinprogramm/convert-explicit.scm | 18 ++++++------- .../deinprogramm/define-record-procedures.scm | 27 ++++++++++++++++++- 3 files changed, 37 insertions(+), 12 deletions(-) diff --git a/collects/deinprogramm/contract/contract.rkt b/collects/deinprogramm/contract/contract.rkt index 767edc4b51..dd25aa4008 100644 --- a/collects/deinprogramm/contract/contract.rkt +++ b/collects/deinprogramm/contract/contract.rkt @@ -21,7 +21,7 @@ procedure-contract-info? procedure-contract-info-arg-contracts procedure-contract-info-return-contract 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 check-struct-wraps! contract=? contract<=?) @@ -393,7 +393,7 @@ ref-proc set!-proc)) ; 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)) (define (make-struct-wrap-contract name type-descriptor field-contracts syntax) diff --git a/collects/deinprogramm/convert-explicit.scm b/collects/deinprogramm/convert-explicit.scm index d4ffa47570..7bdfd14049 100644 --- a/collects/deinprogramm/convert-explicit.scm +++ b/collects/deinprogramm/convert-explicit.scm @@ -76,15 +76,15 @@ (or (hash-ref hash v #f) (let-values (((ty skipped?) (struct-info v))) (cond - ((and ty (lazy-wrap-ref ty)) - => (lambda (lazy-wrap-info) - (let ((constructor (lazy-wrap-info-constructor lazy-wrap-info)) - (raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info))) - (let ((val (apply constructor (map (lambda (raw-accessor) - (recur (raw-accessor v))) - raw-accessors)))) - (hash-set! hash v val) - val)))) + ((and ty (lazy-wrap? ty)) + (let ((lazy-wrap-info (lazy-wrap-ref ty))) + (let ((constructor (lazy-wrap-info-constructor lazy-wrap-info)) + (raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info))) + (let ((val (apply constructor (map (lambda (raw-accessor) + (recur (raw-accessor v))) + raw-accessors)))) + (hash-set! hash v val) + val)))) (else v))))) (else v))))) diff --git a/collects/deinprogramm/define-record-procedures.scm b/collects/deinprogramm/define-record-procedures.scm index b12624e796..a1be5caa54 100644 --- a/collects/deinprogramm/define-record-procedures.scm +++ b/collects/deinprogramm/define-record-procedures.scm @@ -137,7 +137,9 @@ (access-record-fields r raw-generic-access number-of-fields) port write?))) (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 (make-lazy-wrap-info constructor-proc (list raw-accessor-proc ...) @@ -231,6 +233,29 @@ (cons (acc rec i) (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)) (kons 1 (kons 2 (kons 3 (kons 5 (kons 6 (kons 7 (kons 8 "asdjkfdshfdsjkf")))))))