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

Fix various interaction breakage between the new DMdA records and the stepper.

Browse Source 
Namely, attach the `stepper-ignore-completely' property to each
individual definition, rather than just to the block of definitions as a whole.
This commit is contained in:
Mike Sperber 2010-06-01 20:08:00 +02:00
parent 61f6c2077d
commit 5f8924b1d2
1 changed files with 51 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -118,44 +118,43 @@
(with-syntax (with-syntax
((defs ((struct-type-defs
#'(begin #'(define-values (type-descriptor
(define-values (type-descriptor raw-constructor
raw-constructor raw-predicate
raw-predicate raw-generic-access
raw-generic-access raw-generic-mutate)
raw-generic-mutate) (make-struct-type
(make-struct-type '?type-name #f (+ 1 number-of-fields) 0
'?type-name #f (+ 1 number-of-fields) 0 #f
#f (list
(list (cons prop:print-convert-constructor-name
(cons prop:print-convert-constructor-name '?constructor)
'?constructor) (cons prop:custom-write
(cons prop:custom-write (lambda (r port write?)
(lambda (r port write?) (custom-write-record '?type-name
(custom-write-record '?type-name (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?
(list record-equal? (make-equal-hash (lambda (r i) (raw-generic-access r i)) number-of-fields)
(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)))
(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 ...) (list raw-mutator-proc ...)
(list raw-mutator-proc ...) (lambda (r)
(lambda (r) (raw-generic-access r number-of-fields))
(raw-generic-access r number-of-fields)) (lambda (r val)
(lambda (r val) (raw-generic-mutate r number-of-fields val)))))
(raw-generic-mutate r number-of-fields val))))) (make-inspector))))
(make-inspector))) (constructor-def #'(define ?constructor constructor-proc))
(define ?constructor constructor-proc) (predicate-def #'(define-values (?predicate real-predicate)
(define-values (?predicate real-predicate) (values predicate-proc predicate-proc)))
(values predicate-proc predicate-proc)) (accessor-defs #'(define-values (accessor ... our-accessor ...)
(define-values (accessor ... our-accessor ...) (values accessor-proc ... accessor-proc ...)))
(values accessor-proc ... accessor-proc ...)) (mutator-defs #'(define-values (mutator ...) (values mutator-proc ...)))
(define mutator mutator-proc) ...)) (contract-def
(contract
(with-syntax (((?param ...) (generate-temporaries #'(?field-spec ...)))) (with-syntax (((?param ...) (generate-temporaries #'(?field-spec ...))))
(with-syntax (((component-contract ...) (with-syntax (((component-contract ...)
(map (lambda (accessor param) (map (lambda (accessor param)
@ -188,15 +187,22 @@
;; for ?type-name using ?predicate is inadvertently defined ;; for ?type-name using ?predicate is inadvertently defined
base-contract base-contract
constructor-contract)))))) constructor-contract))))))
(with-syntax ((defs ;; again, with properties
(stepper-syntax-property (with-syntax ((struct-type-defs
(syntax/loc x defs) 'stepper-skip-completely #t))) (stepper-syntax-property
(syntax/loc x struct-type-defs) 'stepper-skip-completely #t))
(constructor-def
(stepper-syntax-property #'constructor-def 'stepper-skip-completely #t))
(predicate-def
(stepper-syntax-property #'predicate-def 'stepper-skip-completely #t))
(accessor-defs
(stepper-syntax-property #'accessor-defs 'stepper-skip-completely #t))
(mutator-defs
(stepper-syntax-property #'mutator-defs 'stepper-skip-completely #t)))
#'(begin #'(begin
contract contract-def
;; the contract might be used in the definitions, hence this ordering ;; the contract might be used in the definitions, hence this ordering
defs)))))) struct-type-defs constructor-def predicate-def accessor-defs mutator-defs))))))
((_ ?type-name ((_ ?type-name
?contract-constructor-name ?contract-constructor-name
?constructor ?constructor