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

Change do-define-struct' to use make-struct-type' explicitly.

Browse Source 
This is to enable the contracts work that is to come.
This commit is contained in:
Mike Sperber 2010-06-08 14:20:07 +02:00
parent 97a04e9f9d
commit da88f22b0e
1 changed files with 101 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

150
collects/lang/private/teach.rkt
View File

@ -37,6 +37,7 @@
(require mzlib/etc (require mzlib/etc
mzlib/list mzlib/list
mzlib/math mzlib/math
mzlib/pconvert-prop
scheme/match scheme/match
"set-result.ss" "set-result.ss"
(only racket/base define-struct) (only racket/base define-struct)
@ -51,6 +52,7 @@
syntax/struct syntax/struct
syntax/context syntax/context
mzlib/include mzlib/include
scheme/list
stepper/private/shared) stepper/private/shared)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -103,6 +105,27 @@
(define-for-syntax (stepper-ignore-checker stx) (define-for-syntax (stepper-ignore-checker stx)
(stepper-syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e cdr car))) (stepper-syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e cdr car)))
(define-for-syntax (map-with-index proc list)
(let loop ([i 0] [list list] [rev-result '()])
(if (null? list)
(reverse rev-result)
(loop (+ 1 i)
(cdr list)
(cons (proc i (car list)) rev-result)))))
;; build-struct-names is hard to handle
(define-for-syntax (make-struct-names name fields stx)
(apply (lambda (struct: constructor predicate . rest)
(let loop ([rest rest]
[getters '()]
[setters '()])
(if (null? rest)
(values struct: constructor predicate (reverse getters) (reverse setters))
(loop (cddr rest)
(cons (car rest) getters)
(cons (cadr rest) setters)))))
(build-struct-names name fields #f #f stx)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; syntax implementations ;; syntax implementations
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -732,58 +755,87 @@
(if (null? (cdr rest)) (if (null? (cdr rest))
"one" "one"
"at least one")))) "at least one"))))
(let* ([to-define-names (let ([l (build-struct-names name fields #f (not setters?) stx)]) (let-values ([(struct: constructor-name predicate-name getter-names setter-names)
(if struct-info-is-useful? (make-struct-names name fields stx)]
;; All names: [(field-count) (length fields)])
l (let* ([struct-names (list* struct: constructor-name predicate-name
;; Skip `struct:' name: (if setters?
(cdr l)))] (append getter-names setter-names)
setter-names))]
[to-define-names (if struct-info-is-useful?
;; All names:
struct-names
;; Skip `struct:' name:
(cdr struct-names))]
[proc-names (if struct-info-is-useful? [proc-names (if struct-info-is-useful?
(cdr to-define-names) (cdr to-define-names)
to-define-names)]) to-define-names)])
(with-syntax ([compile-info (if struct-info-is-useful? (write (list 'getters getter-names 'setters setter-names) (current-error-port))
(build-struct-expand-info name fields #f (not setters?) #t null null) (newline (current-error-port))
(syntax (with-syntax ([compile-info (if struct-info-is-useful?
(lambda (stx) (build-struct-expand-info name fields #f (not setters?) #t null null)
(raise-syntax-error (syntax
#f (lambda (stx)
"expected an expression, but found a structure name" (raise-syntax-error
stx))))]) #f
(let-values ([(defn0 bind-names) "expected an expression, but found a structure name"
(wrap-func-definitions stx))))])
first-order? (let-values ([(defn0 bind-names)
(list* 'constructor (wrap-func-definitions
'predicate first-order?
(map (lambda (x) 'selector) (cddr proc-names))) (list* 'constructor
proc-names 'predicate
(list* (- (length proc-names) 2) (map (lambda (x) 'selector) (cddr proc-names)))
1 proc-names
(map (lambda (x) 1) (cddr proc-names))) (list* (- (length proc-names) 2)
(lambda (def-proc-names) 1
(with-syntax ([(def-proc-name ...) def-proc-names] (map (lambda (x) 1) (cddr proc-names)))
[(proc-name ...) proc-names]) (lambda (def-proc-names)
(stepper-syntax-property (with-syntax ([(def-proc-name ...) def-proc-names]
#`(define-values (def-proc-name ...) [(proc-name ...) proc-names])
(let () (stepper-syntax-property
(define-struct name_ (field_ ...) #`(define-values (def-proc-name ...)
#:transparent (let ()
#:mutable
#:constructor-name #,(car proc-names)) (define-values (type-descriptor
(values proc-name ...))) raw-constructor
'stepper-define-struct-hint raw-predicate
stx))))]) raw-generic-access
(let ([defn raw-generic-mutate)
(quasisyntax/loc stx (make-struct-type 'name_
(begin #f
#,(stepper-syntax-property #`(define-syntaxes (name_) compile-info) #,field-count 0
'stepper-skip-completely #f ; auto-v
#t) (list
#,defn0))]) (cons prop:print-convert-constructor-name
(check-definitions-new 'define-struct '#,(car proc-names)))
stx #f)) ; inspector
(cons #'name_ to-define-names) #,@(map-with-index (lambda (i name)
defn #`(define (#,name r)
(and setters? bind-names)))))))] (raw-generic-access r #,i)))
getter-names)
#,@(map-with-index (lambda (i name)
#`(define (#,name r v)
(raw-generic-mutate r #,i v)))
setter-names)
(define #,predicate-name raw-predicate)
(define #,constructor-name raw-constructor)
(values proc-name ...)))
'stepper-define-struct-hint
stx))))])
(let ([defn
(quasisyntax/loc stx
(begin
#,(stepper-syntax-property #`(define-syntaxes (name_) compile-info)
'stepper-skip-completely
#t)
#,defn0))])
(check-definitions-new 'define-struct
stx
(cons #'name_ to-define-names)
defn
(and setters? bind-names))))))))]
[(_ name_ something . rest) [(_ name_ something . rest)
(teach-syntax-error (teach-syntax-error
'define-struct 'define-struct