From bf11194ee70ba393b2177bf05c21b99d986959f8 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 25 Jun 2009 19:30:07 +0000 Subject: [PATCH] Converting to scheme/base svn: r15274 --- collects/frtime/struct.ss | 512 +++++++++++++++++++------------------- 1 file changed, 255 insertions(+), 257 deletions(-) diff --git a/collects/frtime/struct.ss b/collects/frtime/struct.ss index 4d247f5973..fa5a442672 100644 --- a/collects/frtime/struct.ss +++ b/collects/frtime/struct.ss @@ -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)))]))