Converting to scheme/base
svn: r15274
This commit is contained in:
Jay McCarthy
parent
04600dfa28
commit
bf11194ee7
|
|
@ -1,268 +1,266 @@
|
|||
#lang scheme/base
|
||||
(require scheme/struct-info
|
||||
(for-syntax scheme/base)
|
||||
(for-template scheme/base))
|
||||
|
||||
(module struct mzscheme
|
||||
(require mzlib/etc
|
||||
syntax/stx
|
||||
scheme/struct-info)
|
||||
(require-for-template mzscheme)
|
||||
|
||||
(provide build-struct-names
|
||||
build-struct-generation
|
||||
build-struct-expand-info
|
||||
struct-declaration-info?
|
||||
extract-struct-info
|
||||
|
||||
generate-struct-declaration
|
||||
generate-delayed-struct-declaration)
|
||||
(provide build-struct-names
|
||||
build-struct-generation
|
||||
build-struct-expand-info
|
||||
struct-declaration-info?
|
||||
extract-struct-info
|
||||
|
||||
generate-struct-declaration
|
||||
generate-delayed-struct-declaration)
|
||||
|
||||
;; build-struct-names : id (list-of id) bool bool -> (list-of id)
|
||||
(define build-struct-names
|
||||
(opt-lambda (name-stx fields omit-sel? omit-set? [srcloc-stx #f])
|
||||
(let ([name (symbol->string (syntax-e name-stx))]
|
||||
[fields (map symbol->string (map syntax-e fields))]
|
||||
[+ string-append])
|
||||
(map (lambda (s)
|
||||
(datum->syntax-object name-stx (string->symbol s) srcloc-stx))
|
||||
(append
|
||||
(list
|
||||
(+ "struct:" name)
|
||||
(+ "make-" name)
|
||||
(+ name "?"))
|
||||
(let loop ([l fields])
|
||||
(if (null? l)
|
||||
null
|
||||
(append
|
||||
(if omit-sel?
|
||||
null
|
||||
(list (+ name "-" (car l))))
|
||||
(if omit-set?
|
||||
null
|
||||
(list (+ "set-" name "-" (car l) "!")))
|
||||
(loop (cdr l))))))))))
|
||||
;; build-struct-names : id (list-of id) bool bool -> (list-of id)
|
||||
(define build-struct-names
|
||||
(lambda (name-stx fields omit-sel? omit-set? [srcloc-stx #f])
|
||||
(let ([name (symbol->string (syntax-e name-stx))]
|
||||
[fields (map symbol->string (map syntax-e fields))]
|
||||
[+ string-append])
|
||||
(map (lambda (s)
|
||||
(datum->syntax name-stx (string->symbol s) srcloc-stx))
|
||||
(append
|
||||
(list
|
||||
(+ "struct:" name)
|
||||
(+ "make-" name)
|
||||
(+ name "?"))
|
||||
(let loop ([l fields])
|
||||
(if (null? l)
|
||||
null
|
||||
(append
|
||||
(if omit-sel?
|
||||
null
|
||||
(list (+ name "-" (car l))))
|
||||
(if omit-set?
|
||||
null
|
||||
(list (+ "set-" name "-" (car l) "!")))
|
||||
(loop (cdr l))))))))))
|
||||
|
||||
(define build-struct-generation
|
||||
(opt-lambda (name-stx fields omit-sel? omit-set? [super-type #f] [prop-value-list null]
|
||||
[immutable-positions null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) null)])
|
||||
(let ([names (build-struct-names name-stx fields omit-sel? omit-set?)])
|
||||
(build-struct-generation* names name-stx fields omit-sel? omit-set? super-type prop-value-list
|
||||
immutable-positions mk-rec-prop-list))))
|
||||
(define build-struct-generation
|
||||
(lambda (name-stx fields omit-sel? omit-set? [super-type #f] [prop-value-list #'null]
|
||||
[immutable-positions #'null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) #'null)])
|
||||
(let ([names (build-struct-names name-stx fields omit-sel? omit-set?)])
|
||||
(build-struct-generation* names name-stx fields omit-sel? omit-set? super-type prop-value-list
|
||||
immutable-positions mk-rec-prop-list))))
|
||||
|
||||
(define build-struct-generation*
|
||||
(opt-lambda (names name fields omit-sel? omit-set? [super-type #f] [prop-value-list null]
|
||||
[immutable-positions null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) null)])
|
||||
(let ([num-fields (length fields)]
|
||||
[acc/mut-makers (let loop ([l fields][n 0])
|
||||
(if (null? l)
|
||||
null
|
||||
(let ([mk-one
|
||||
(lambda (acc?)
|
||||
(list
|
||||
`(,(if acc?
|
||||
'frp:make-struct-field-accessor
|
||||
'frp:make-struct-field-mutator)
|
||||
,(if acc? 'acc 'mut)
|
||||
,n ',(car l))))])
|
||||
(append
|
||||
(if omit-sel?
|
||||
null
|
||||
(mk-one #t))
|
||||
(if omit-set?
|
||||
null
|
||||
(mk-one #f))
|
||||
(loop (cdr l) (add1 n))))))]
|
||||
[extra-props (mk-rec-prop-list 'struct: 'make- '? 'acc 'mut)])
|
||||
`(let-values ([(struct: make- ? acc mut)
|
||||
(frp:make-struct-type ',name ,super-type ,num-fields 0 #f ,prop-value-list #f #f ,immutable-positions)])
|
||||
(values struct:
|
||||
make-
|
||||
?
|
||||
,@acc/mut-makers)))))
|
||||
(define build-struct-generation*
|
||||
(lambda (names name fields omit-sel? omit-set? [super-type #f] [prop-value-list #'null]
|
||||
[immutable-positions #'null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) #'null)])
|
||||
(let ([num-fields (length fields)]
|
||||
[acc/mut-makers (let loop ([l fields][n 0])
|
||||
(if (null? l)
|
||||
null
|
||||
(let ([mk-one
|
||||
(lambda (acc?)
|
||||
(list
|
||||
`(,(if acc?
|
||||
'frp:make-struct-field-accessor
|
||||
'frp:make-struct-field-mutator)
|
||||
,(if acc? 'acc 'mut)
|
||||
,n ',(car l))))])
|
||||
(append
|
||||
(if omit-sel?
|
||||
null
|
||||
(mk-one #t))
|
||||
(if omit-set?
|
||||
null
|
||||
(mk-one #f))
|
||||
(loop (cdr l) (add1 n))))))]
|
||||
[extra-props (mk-rec-prop-list 'struct: 'make- '? 'acc 'mut)])
|
||||
`(let-values ([(struct: make- ? acc mut)
|
||||
(frp:make-struct-type ',name ,super-type ,num-fields 0 #f ,prop-value-list #f #f ,immutable-positions)])
|
||||
(values struct:
|
||||
make-
|
||||
?
|
||||
,@acc/mut-makers)))))
|
||||
|
||||
(define build-struct-expand-info
|
||||
(lambda (name-stx fields omit-sel? omit-set? base-name base-getters base-setters)
|
||||
(let* ([names (build-struct-names name-stx fields omit-sel? omit-set?)])
|
||||
(build-struct-expand-info* names name-stx fields omit-sel? omit-set? base-name base-getters base-setters))))
|
||||
(define build-struct-expand-info
|
||||
(lambda (name-stx fields omit-sel? omit-set? base-name base-getters base-setters)
|
||||
(let* ([names (build-struct-names name-stx fields omit-sel? omit-set?)])
|
||||
(build-struct-expand-info* names name-stx fields omit-sel? omit-set? base-name base-getters base-setters))))
|
||||
|
||||
(define build-struct-expand-info*
|
||||
(lambda (names name-stx fields omit-sel? omit-set? base-name base-getters base-setters)
|
||||
(let* ([flds (cdddr names)]
|
||||
[every-other (lambda (l)
|
||||
(let loop ([l l])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(null? (cdr l)) (list (car l))]
|
||||
[else (cons (car l) (loop (cddr l)))])))]
|
||||
[add-#f (lambda (omit? base)
|
||||
(if omit?
|
||||
(if (let loop ([l base])
|
||||
(cond
|
||||
[(null? l) #t]
|
||||
[(not (car l)) #f]
|
||||
[else (loop (cdr l))]))
|
||||
(append base '(#f)))
|
||||
base))]
|
||||
[cert-f (gensym)]
|
||||
[qs (lambda (x) (if (eq? x #t)
|
||||
x
|
||||
(and x `(,cert-f (quote-syntax ,x)))))])
|
||||
`(let ([,cert-f (syntax-local-certifier #t)])
|
||||
(list
|
||||
,(qs (car names))
|
||||
,(qs (cadr names))
|
||||
,(qs (caddr names))
|
||||
(list
|
||||
,@(reverse (if omit-sel?
|
||||
null
|
||||
(map qs (if omit-set? flds (every-other flds)))))
|
||||
,@(map qs (add-#f omit-sel? base-getters)))
|
||||
(list
|
||||
,@(reverse (if omit-set?
|
||||
null
|
||||
(map qs (if omit-sel?
|
||||
flds
|
||||
(every-other (if (null? flds)
|
||||
null
|
||||
(cdr flds)))))))
|
||||
,@(map qs (add-#f omit-set? base-setters)))
|
||||
,(qs base-name))))))
|
||||
|
||||
(define (struct-declaration-info? x)
|
||||
(struct-info? x))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define struct-info-type-id car)
|
||||
(define struct-info-constructor-id cadr)
|
||||
(define struct-info-predicate-id caddr)
|
||||
(define struct-info-accessor-ids cadddr)
|
||||
(define struct-info-mutator-ids (lambda (x) (list-ref x 4)))
|
||||
|
||||
(define (get-stx-info orig-stx super-id defined-names gen-expr?)
|
||||
;; Looks up super info, if needed, and builds compile-time info for the
|
||||
;; new struct; called by all three forms, but does only half the work
|
||||
;; if `defined-names' is #f.
|
||||
;; If `expr?' is #t, then generate an expression to build the info,
|
||||
;; otherwise build the info directly.
|
||||
(let* ([cert-f (gensym)]
|
||||
[qs (if gen-expr? (lambda (x) #`(#,cert-f (quote-syntax #,x))) values)]
|
||||
(define build-struct-expand-info*
|
||||
(lambda (names name-stx fields omit-sel? omit-set? base-name base-getters base-setters)
|
||||
(let* ([flds (cdddr names)]
|
||||
[every-other (lambda (l)
|
||||
(let loop ([l l][r null])
|
||||
(let loop ([l l])
|
||||
(cond
|
||||
[(null? l) r]
|
||||
[(null? (cdr l)) (cons (car l) r)]
|
||||
[else (loop (cddr l) (cons (car l) r))])))]
|
||||
[super-si (and super-id
|
||||
(syntax-local-value super-id (lambda () #f)))]
|
||||
[super-info (and super-si
|
||||
(struct-declaration-info? super-si)
|
||||
(extract-struct-info super-si))])
|
||||
(when super-id
|
||||
;; Did we get valid super-info ?
|
||||
(when (or (not (struct-declaration-info? super-si))
|
||||
(not (struct-info-type-id super-info)))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(if (struct-declaration-info? super-si)
|
||||
"parent struct information does not include a type for subtyping"
|
||||
(format "parent struct type not defined~a"
|
||||
(if super-info
|
||||
(format " (~a does not name struct type information)"
|
||||
(syntax-e super-id))
|
||||
"")))
|
||||
orig-stx
|
||||
super-id)))
|
||||
;; Generate the results:
|
||||
(values
|
||||
super-info
|
||||
(if defined-names
|
||||
(let-values ([(initial-gets initial-sets)
|
||||
(if super-info
|
||||
(values (map qs (struct-info-accessor-ids super-info))
|
||||
(map qs (struct-info-mutator-ids super-info)))
|
||||
(values null null))]
|
||||
[(fields) (cdddr defined-names)]
|
||||
[(wrap) (if gen-expr? (lambda (x) #`(list #,@x)) values)])
|
||||
#`(let ([#,cert-f (syntax-local-certifier #t)])
|
||||
(make-struct-info
|
||||
(lambda ()
|
||||
#,(wrap
|
||||
(list (qs (car defined-names))
|
||||
(qs (cadr defined-names))
|
||||
(qs (caddr defined-names))
|
||||
(wrap
|
||||
(apply
|
||||
list
|
||||
(append (map qs (every-other fields))
|
||||
initial-gets)))
|
||||
(wrap
|
||||
(apply
|
||||
list
|
||||
(append (map qs (if (null? fields)
|
||||
null
|
||||
(every-other (cdr fields))))
|
||||
initial-sets)))
|
||||
(if super-id
|
||||
(qs super-id)
|
||||
#t)))))))
|
||||
#f))))
|
||||
[(null? l) null]
|
||||
[(null? (cdr l)) (list (car l))]
|
||||
[else (cons (car l) (loop (cddr l)))])))]
|
||||
[add-#f (lambda (omit? base)
|
||||
(if omit?
|
||||
(when (let loop ([l base])
|
||||
(cond
|
||||
[(null? l) #t]
|
||||
[(not (car l)) #f]
|
||||
[else (loop (cdr l))]))
|
||||
(append base '(#f)))
|
||||
base))]
|
||||
[cert-f (gensym)]
|
||||
[qs (lambda (x) (if (eq? x #t)
|
||||
x
|
||||
(and x `(,cert-f (quote-syntax ,x)))))])
|
||||
`(let ([,cert-f (syntax-local-certifier #t)])
|
||||
(list
|
||||
,(qs (car names))
|
||||
,(qs (cadr names))
|
||||
,(qs (caddr names))
|
||||
(list
|
||||
,@(reverse (if omit-sel?
|
||||
null
|
||||
(map qs (if omit-set? flds (every-other flds)))))
|
||||
,@(map qs (add-#f omit-sel? base-getters)))
|
||||
(list
|
||||
,@(reverse (if omit-set?
|
||||
null
|
||||
(map qs (if omit-sel?
|
||||
flds
|
||||
(every-other (if (null? flds)
|
||||
null
|
||||
(cdr flds)))))))
|
||||
,@(map qs (add-#f omit-set? base-setters)))
|
||||
,(qs base-name))))))
|
||||
|
||||
(define (make-core make-make-struct-type orig-stx defined-names super-info name field-names)
|
||||
#`(let-values ([(type maker pred access mutate)
|
||||
#,(make-make-struct-type orig-stx name defined-names super-info)])
|
||||
(values type maker pred
|
||||
#,@(let loop ([field-names field-names][n 0])
|
||||
(if (null? field-names)
|
||||
null
|
||||
(list* #`(make-struct-field-accessor access #,n '#,(car field-names))
|
||||
#`(make-struct-field-mutator mutate #,n '#,(car field-names))
|
||||
(loop (cdr field-names) (add1 n))))))))
|
||||
(define (struct-declaration-info? x)
|
||||
(struct-info? x))
|
||||
|
||||
(define (generate-struct-declaration orig-stx
|
||||
name super-id field-names
|
||||
context
|
||||
make-make-struct-type
|
||||
continue-macro-id continue-data)
|
||||
(let ([defined-names (build-struct-names name field-names #f #f name)]
|
||||
[delay? (and (not (memq context '(module top-level expression)))
|
||||
super-id)])
|
||||
(let-values ([(super-info stx-info)
|
||||
(if delay?
|
||||
(values #f #f)
|
||||
(get-stx-info orig-stx super-id defined-names #t))])
|
||||
(let ([result
|
||||
#`(begin
|
||||
(define-values
|
||||
#,defined-names
|
||||
#,(if delay?
|
||||
#`(begin0 ;; the `begin0' guarantees that it's an expression
|
||||
(#,continue-macro-id #,orig-stx #,name #,super-id
|
||||
#,defined-names #,field-names
|
||||
#,continue-data))
|
||||
(make-core make-make-struct-type orig-stx defined-names super-info name field-names)))
|
||||
(define-syntaxes (#,name)
|
||||
#,(if delay?
|
||||
#`(let-values ([(super-info stx-info)
|
||||
(get-stx-info (quote-syntax ,orig-stx)
|
||||
(quote-syntax ,super-id)
|
||||
(list #,@(map (lambda (x)
|
||||
#`(quote-syntax #,x))
|
||||
defined-names))
|
||||
#f
|
||||
values)])
|
||||
stx-info)
|
||||
stx-info)))])
|
||||
(if super-id
|
||||
(syntax-property result
|
||||
'disappeared-use
|
||||
(syntax-local-introduce super-id))
|
||||
result)))))
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (generate-delayed-struct-declaration stx make-make-make-struct-type)
|
||||
(syntax-case stx ()
|
||||
[(_ orig-stx name super-id defined-names field-names continue-data)
|
||||
(let-values ([(super-info stx-info) (get-stx-info #'orig-stx #'super-id #f #f)])
|
||||
(make-core (make-make-make-struct-type #'continue-data)
|
||||
#'orig-stx
|
||||
(syntax->list #'defined-names)
|
||||
super-info
|
||||
#'name
|
||||
(syntax->list #'field-names)))])))
|
||||
(define struct-info-type-id car)
|
||||
(define struct-info-constructor-id cadr)
|
||||
(define struct-info-predicate-id caddr)
|
||||
(define struct-info-accessor-ids cadddr)
|
||||
(define struct-info-mutator-ids (lambda (x) (list-ref x 4)))
|
||||
|
||||
(define (get-stx-info orig-stx super-id defined-names gen-expr?)
|
||||
;; Looks up super info, if needed, and builds compile-time info for the
|
||||
;; new struct; called by all three forms, but does only half the work
|
||||
;; if `defined-names' is #f.
|
||||
;; If `expr?' is #t, then generate an expression to build the info,
|
||||
;; otherwise build the info directly.
|
||||
(let* ([cert-f (gensym)]
|
||||
[qs (if gen-expr? (lambda (x) #`(#,cert-f (quote-syntax #,x))) values)]
|
||||
[every-other (lambda (l)
|
||||
(let loop ([l l][r null])
|
||||
(cond
|
||||
[(null? l) r]
|
||||
[(null? (cdr l)) (cons (car l) r)]
|
||||
[else (loop (cddr l) (cons (car l) r))])))]
|
||||
[super-si (and super-id
|
||||
(syntax-local-value super-id (lambda () #f)))]
|
||||
[super-info (and super-si
|
||||
(struct-declaration-info? super-si)
|
||||
(extract-struct-info super-si))])
|
||||
(when super-id
|
||||
;; Did we get valid super-info ?
|
||||
(when (or (not (struct-declaration-info? super-si))
|
||||
(not (struct-info-type-id super-info)))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(if (struct-declaration-info? super-si)
|
||||
"parent struct information does not include a type for subtyping"
|
||||
(format "parent struct type not defined~a"
|
||||
(if super-info
|
||||
(format " (~a does not name struct type information)"
|
||||
(syntax-e super-id))
|
||||
"")))
|
||||
orig-stx
|
||||
super-id)))
|
||||
;; Generate the results:
|
||||
(values
|
||||
super-info
|
||||
(if defined-names
|
||||
(let-values ([(initial-gets initial-sets)
|
||||
(if super-info
|
||||
(values (map qs (struct-info-accessor-ids super-info))
|
||||
(map qs (struct-info-mutator-ids super-info)))
|
||||
(values null null))]
|
||||
[(fields) (cdddr defined-names)]
|
||||
[(wrap) (if gen-expr? (lambda (x) #`(list #,@x)) values)])
|
||||
#`(let ([#,cert-f (syntax-local-certifier #t)])
|
||||
(make-struct-info
|
||||
(lambda ()
|
||||
#,(wrap
|
||||
(list (qs (car defined-names))
|
||||
(qs (cadr defined-names))
|
||||
(qs (caddr defined-names))
|
||||
(wrap
|
||||
(apply
|
||||
list
|
||||
(append (map qs (every-other fields))
|
||||
initial-gets)))
|
||||
(wrap
|
||||
(apply
|
||||
list
|
||||
(append (map qs (if (null? fields)
|
||||
null
|
||||
(every-other (cdr fields))))
|
||||
initial-sets)))
|
||||
(if super-id
|
||||
(qs super-id)
|
||||
#t)))))))
|
||||
#f))))
|
||||
|
||||
(define (make-core make-make-struct-type orig-stx defined-names super-info name field-names)
|
||||
#`(let-values ([(type maker pred access mutate)
|
||||
#,(make-make-struct-type orig-stx name defined-names super-info)])
|
||||
(values type maker pred
|
||||
#,@(let loop ([field-names field-names][n 0])
|
||||
(if (null? field-names)
|
||||
null
|
||||
(list* #`(make-struct-field-accessor access #,n '#,(car field-names))
|
||||
#`(make-struct-field-mutator mutate #,n '#,(car field-names))
|
||||
(loop (cdr field-names) (add1 n))))))))
|
||||
|
||||
(define (generate-struct-declaration orig-stx
|
||||
name super-id field-names
|
||||
context
|
||||
make-make-struct-type
|
||||
continue-macro-id continue-data)
|
||||
(let ([defined-names (build-struct-names name field-names #f #f name)]
|
||||
[delay? (and (not (memq context '(module top-level expression)))
|
||||
super-id)])
|
||||
(let-values ([(super-info stx-info)
|
||||
(if delay?
|
||||
(values #f #f)
|
||||
(get-stx-info orig-stx super-id defined-names #t))])
|
||||
(let ([result
|
||||
#`(begin
|
||||
(define-values
|
||||
#,defined-names
|
||||
#,(if delay?
|
||||
#`(begin0 ;; the `begin0' guarantees that it's an expression
|
||||
(#,continue-macro-id #,orig-stx #,name #,super-id
|
||||
#,defined-names #,field-names
|
||||
#,continue-data))
|
||||
(make-core make-make-struct-type orig-stx defined-names super-info name field-names)))
|
||||
(define-syntaxes (#,name)
|
||||
#,(if delay?
|
||||
#`(let-values ([(super-info stx-info)
|
||||
(get-stx-info (quote-syntax ,orig-stx)
|
||||
(quote-syntax ,super-id)
|
||||
(list #,@(map (lambda (x)
|
||||
#`(quote-syntax #,x))
|
||||
defined-names))
|
||||
#f
|
||||
values)])
|
||||
stx-info)
|
||||
stx-info)))])
|
||||
(if super-id
|
||||
(syntax-property result
|
||||
'disappeared-use
|
||||
(syntax-local-introduce super-id))
|
||||
result)))))
|
||||
|
||||
(define (generate-delayed-struct-declaration stx make-make-make-struct-type)
|
||||
(syntax-case stx ()
|
||||
[(_ orig-stx name super-id defined-names field-names continue-data)
|
||||
(let-values ([(super-info stx-info) (get-stx-info #'orig-stx #'super-id #f #f)])
|
||||
(make-core (make-make-make-struct-type #'continue-data)
|
||||
#'orig-stx
|
||||
(syntax->list #'defined-names)
|
||||
super-info
|
||||
#'name
|
||||
(syntax->list #'field-names)))]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user