From 65d3d3240b647685f446f89d86b907f2bcc73b64 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 11 Apr 2010 21:08:37 +0000 Subject: [PATCH] racket: keep old 'define-struct', include new form as 'struct' svn: r18789 --- collects/mzlib/scribblings/unit.scrbl | 9 + collects/mzlib/unit.ss | 216 ++++++++++++++++++++++- collects/racket/base.ss | 7 +- collects/racket/main.ss | 7 +- collects/racket/private/define-struct.ss | 23 --- collects/racket/private/struct.rkt | 38 ++++ collects/scheme/unit.ss | 208 +--------------------- 7 files changed, 268 insertions(+), 240 deletions(-) delete mode 100644 collects/racket/private/define-struct.ss create mode 100644 collects/racket/private/struct.rkt diff --git a/collects/mzlib/scribblings/unit.scrbl b/collects/mzlib/scribblings/unit.scrbl index 55075ccb04..2ff9e97ac9 100644 --- a/collects/mzlib/scribblings/unit.scrbl +++ b/collects/mzlib/scribblings/unit.scrbl @@ -37,3 +37,12 @@ but with a different syntax for the options that limit exports.} A signature form like @scheme-struct/ctc from @schememodname[scheme/unit], but with a different syntax for the options that limit exports.} + +@deftogether[( +@defidform[struct~] +@defidform[struct~/ctc] +)]{ + +The same as @|scheme-struct| and @|scheme-struct/ctc| from +@schememodname[scheme/unit].} + diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index fb654f68e1..b1ae2bfe81 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -21,7 +21,8 @@ "private/unit-contract.ss" "private/unit-keywords.ss" "private/unit-runtime.ss" - "private/unit-utils.ss") + "private/unit-utils.ss" + (rename-in racket/private/struct [struct struct~])) (provide define-signature-form struct struct/ctc open define-signature provide-signature-elements @@ -35,7 +36,8 @@ define-unit-binding unit/new-import-export define-unit/new-import-export unit/s define-unit/s - unit/c define-unit/contract) + unit/c define-unit/contract + struct~ struct~/ctc) (define-syntax/err-param (define-signature-form stx) (syntax-case stx () @@ -130,6 +132,99 @@ ((_) (raise-stx-err "missing name and fields"))))) +;; Replacement `struct' signature form for `scheme/unit': +(define-signature-form (struct~~ stx) + (syntax-case stx () + ((_ name (field ...) opt ...) + (begin + (unless (identifier? #'name) + (raise-syntax-error #f + "expected an identifier to name the structure type" + stx + #'name)) + (for-each (lambda (field) + (unless (identifier? field) + (syntax-case field () + [(id #:mutable) + (identifier? #'id) + 'ok] + [_ + (raise-syntax-error #f + "bad field specification" + stx + field)]))) + (syntax->list #'(field ...))) + (let-values ([(no-ctr? mutable? no-stx? no-rt?) + (let loop ([opts (syntax->list #'(opt ...))] + [no-ctr? #f] + [mutable? #f] + [no-stx? #f] + [no-rt? #f]) + (if (null? opts) + (values no-ctr? mutable? no-stx? no-rt?) + (let ([opt (car opts)]) + (case (syntax-e opt) + [(#:omit-constructor) + (if no-ctr? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) #t mutable? no-stx? no-rt?))] + [(#:mutable) + (if mutable? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? #t no-stx? no-rt?))] + [(#:omit-define-syntaxes) + (if no-stx? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? mutable? #t no-rt?))] + [(#:omit-define-values) + (if no-rt? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? mutable? no-stx? #t))] + [else + (raise-syntax-error #f + (string-append + "expected a keyword to specify option: " + "#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values") + stx + opt)]))))]) + (cons + #`(define-syntaxes (name) + #,(build-struct-expand-info + #'name (syntax->list #'(field ...)) + #f (not mutable?) + #f '(#f) '(#f) + #:omit-constructor? no-ctr?)) + (let ([names (build-struct-names #'name (syntax->list #'(field ...)) + #f (not mutable?))]) + (if no-ctr? + (cons (car names) (cddr names)) + names)))))) + ((_ name fields opt ...) + (raise-syntax-error #f + "bad syntax; expected a parenthesized sequence of fields" + stx + #'fields)) + ((_ name) + (raise-syntax-error #f + "bad syntax; missing fields" + stx)) + ((_) + (raise-syntax-error #f + "missing name and fields" + stx)))) + (define-signature-form (struct/ctc stx) (parameterize ((error-syntax stx)) (syntax-case stx () @@ -214,6 +309,118 @@ ((_) (raise-stx-err "missing name and fields"))))) +;; Replacement struct/ctc form for `scheme/unit': +(define-signature-form (struct~/ctc stx) + (syntax-case stx () + ((_ name ([field ctc] ...) opt ...) + (begin + (unless (identifier? #'name) + (raise-syntax-error #f + "expected an identifier to name the structure type" + stx + #'name)) + (for-each (lambda (field) + (unless (identifier? field) + (syntax-case field () + [(id #:mutable) + (identifier? #'id) + 'ok] + [_ + (raise-syntax-error #f + "bad field specification" + stx + field)]))) + (syntax->list #'(field ...))) + (let-values ([(no-ctr? mutable? no-stx? no-rt?) + (let loop ([opts (syntax->list #'(opt ...))] + [no-ctr? #f] + [mutable? #f] + [no-stx? #f] + [no-rt? #f]) + (if (null? opts) + (values no-ctr? mutable? no-stx? no-rt?) + (let ([opt (car opts)]) + (case (syntax-e opt) + [(#:omit-constructor) + (if no-ctr? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) #t mutable? no-stx? no-rt?))] + [(#:mutable) + (if mutable? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? #t no-stx? no-rt?))] + [(#:omit-define-syntaxes) + (if no-stx? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? mutable? #t no-rt?))] + [(#:omit-define-values) + (if no-rt? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? mutable? no-stx? #t))] + [else + (raise-syntax-error #f + (string-append + "expected a keyword to specify option: " + "#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values") + stx + opt)]))))]) + (define (add-contracts l) + (let* ([pred (caddr l)] + [ctor-ctc #`(-> ctc ... #,pred)] + [pred-ctc #'(-> any/c boolean?)] + [field-ctcs + (apply append + (map (λ (f c) + (cons #`(-> #,pred #,c) + (if (and (not mutable?) + (not (pair? (syntax-e f)))) + null + #`(-> #,pred #,c void?)))) + (syntax->list #'(field ...)) + (syntax->list #'(ctc ...))))]) + (list* (car l) + (list (cadr l) ctor-ctc) + (list pred pred-ctc) + (map list (cdddr l) field-ctcs)))) + (cons + #`(define-syntaxes (name) + #,(build-struct-expand-info + #'name (syntax->list #'(field ...)) + #f (not mutable?) + #f '(#f) '(#f) + #:omit-constructor? no-ctr?)) + (let* ([names (add-contracts + (build-struct-names #'name (syntax->list #'(field ...)) + #f (not mutable?)))] + [cpairs (cons 'contracted + (if no-ctr? (cddr names) (cdr names)))]) + (list (car names) cpairs)))))) + ((_ name fields opt ...) + (raise-syntax-error #f + "bad syntax; expected a parenthesized sequence of fields" + stx + #'fields)) + ((_ name) + (raise-syntax-error #f + "bad syntax; missing fields" + stx)) + ((_) + (raise-syntax-error #f + "missing name and fields" + stx)))) + ;; build-val+macro-defs : sig -> (list syntax-object^3) (define-for-syntax (build-val+macro-defs sig) @@ -395,7 +602,10 @@ (let ((trans (set!-trans-extract (syntax-local-value - (syntax-local-introduce #'x) + ;; redirect struct~ to struct~~ + (if (free-identifier=? #'x #'struct~) + #'struct~~ + (syntax-local-introduce #'x)) (lambda () (raise-stx-err "unknown signature form" #'x)))))) (unless (signature-form? trans) diff --git a/collects/racket/base.ss b/collects/racket/base.ss index 13ff62a321..ef8f53910c 100644 --- a/collects/racket/base.ss +++ b/collects/racket/base.ss @@ -1,6 +1,5 @@ #lang racket/private -(require "private/define-struct.ss") +(require "private/struct.rkt") -(provide (except-out (all-from-out scheme/base) - define-struct) - (rename-out [new-define-struct define-struct])) +(provide (all-from-out scheme/base) + struct) diff --git a/collects/racket/main.ss b/collects/racket/main.ss index 92cc0eb446..b21974f826 100644 --- a/collects/racket/main.ss +++ b/collects/racket/main.ss @@ -1,8 +1,7 @@ #lang racket/private (require scheme) -(require "private/define-struct.ss") +;; scheme includes `struct' via scheme/unit + +(provide (all-from-out scheme)) -(provide (except-out (all-from-out scheme) - define-struct) - (rename-out [new-define-struct define-struct])) diff --git a/collects/racket/private/define-struct.ss b/collects/racket/private/define-struct.ss deleted file mode 100644 index 0b93d1211f..0000000000 --- a/collects/racket/private/define-struct.ss +++ /dev/null @@ -1,23 +0,0 @@ -#lang scheme/base -(require (for-syntax scheme/base)) - -(provide new-define-struct) - -(define-syntax (new-define-struct stx) - (define (config-has-name? config) - (cond - [(syntax? config) (config-has-name? (syntax-e config))] - [(pair? config) (or (eq? (syntax-e (car config)) '#:constructor-name) - (config-has-name? (cdr config)))] - [else #f])) - (with-syntax ([orig stx]) - (syntax-case stx () - [(_ id+super fields . config) - (not (config-has-name? #'config)) - (with-syntax ([id (syntax-case #'id+super () - [(id super) #'id] - [else #'id+super])]) - (syntax/loc stx - (define-struct/derived orig id+super fields #:constructor-name id . config)))] - [_ (syntax/loc stx - (define-struct/derived orig id+super fields . config))]))) diff --git a/collects/racket/private/struct.rkt b/collects/racket/private/struct.rkt new file mode 100644 index 0000000000..15a061a5f6 --- /dev/null +++ b/collects/racket/private/struct.rkt @@ -0,0 +1,38 @@ +#lang scheme/base +(require (for-syntax scheme/base)) + +(provide struct) + +(define-syntax (struct stx) + (define (config-has-name? config) + (cond + [(syntax? config) (config-has-name? (syntax-e config))] + [(pair? config) (or (eq? (syntax-e (car config)) '#:constructor-name) + (config-has-name? (cdr config)))] + [else #f])) + (with-syntax ([orig stx]) + (syntax-case stx () + [(_ id super-id fields . config) + (and (identifier? #'id) + (identifier? #'super-id)) + (if (not (config-has-name? #'config)) + (syntax/loc stx + (define-struct/derived orig (id super-id) fields #:constructor-name id . config)) + (syntax/loc stx + (define-struct/derived orig (id super-id) fields . config)))] + [(_ id fields . config) + (identifier? #'id) + (if (not (config-has-name? #'config)) + (syntax/loc stx + (define-struct/derived orig id fields #:constructor-name id . config)) + (syntax/loc stx + (define-struct/derived orig id fields . config)))] + [(_ id . rest) + (identifier? #'id) + (syntax/loc stx + (define-struct/derived orig id . rest))] + [(_ thing . _) + (raise-syntax-error #f + "expected an identifier for the structure type name" + #'thing + stx)]))) diff --git a/collects/scheme/unit.ss b/collects/scheme/unit.ss index e0d706406b..d816a20624 100644 --- a/collects/scheme/unit.ss +++ b/collects/scheme/unit.ss @@ -6,210 +6,6 @@ syntax/struct)) (provide (except-out (all-from-out mzlib/unit) struct struct/ctc) - (rename-out [struct* struct] - [struct/ctc* struct/ctc])) + (rename-out [struct~ struct] + [struct~/ctc struct/ctc]))) - ;; Replacement `struct' signature form: - (define-signature-form (struct* stx) - (syntax-case stx () - ((_ name (field ...) opt ...) - (begin - (unless (identifier? #'name) - (raise-syntax-error #f - "expected an identifier to name the structure type" - stx - #'name)) - (for-each (lambda (field) - (unless (identifier? field) - (syntax-case field () - [(id #:mutable) - (identifier? #'id) - 'ok] - [_ - (raise-syntax-error #f - "bad field specification" - stx - field)]))) - (syntax->list #'(field ...))) - (let-values ([(no-ctr? mutable? no-stx? no-rt?) - (let loop ([opts (syntax->list #'(opt ...))] - [no-ctr? #f] - [mutable? #f] - [no-stx? #f] - [no-rt? #f]) - (if (null? opts) - (values no-ctr? mutable? no-stx? no-rt?) - (let ([opt (car opts)]) - (case (syntax-e opt) - [(#:omit-constructor) - (if no-ctr? - (raise-syntax-error #f - "redundant option" - stx - opt) - (loop (cdr opts) #t mutable? no-stx? no-rt?))] - [(#:mutable) - (if mutable? - (raise-syntax-error #f - "redundant option" - stx - opt) - (loop (cdr opts) no-ctr? #t no-stx? no-rt?))] - [(#:omit-define-syntaxes) - (if no-stx? - (raise-syntax-error #f - "redundant option" - stx - opt) - (loop (cdr opts) no-ctr? mutable? #t no-rt?))] - [(#:omit-define-values) - (if no-rt? - (raise-syntax-error #f - "redundant option" - stx - opt) - (loop (cdr opts) no-ctr? mutable? no-stx? #t))] - [else - (raise-syntax-error #f - (string-append - "expected a keyword to specify option: " - "#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values") - stx - opt)]))))]) - (cons - #`(define-syntaxes (name) - #,(build-struct-expand-info - #'name (syntax->list #'(field ...)) - #f (not mutable?) - #f '(#f) '(#f) - #:omit-constructor? no-ctr?)) - (let ([names (build-struct-names #'name (syntax->list #'(field ...)) - #f (not mutable?))]) - (if no-ctr? - (cons (car names) (cddr names)) - names)))))) - ((_ name fields opt ...) - (raise-syntax-error #f - "bad syntax; expected a parenthesized sequence of fields" - stx - #'fields)) - ((_ name) - (raise-syntax-error #f - "bad syntax; missing fields" - stx)) - ((_) - (raise-syntax-error #f - "missing name and fields" - stx)))) - - ;; Replacement struct/ctc form - (define-signature-form (struct/ctc* stx) - (syntax-case stx () - ((_ name ([field ctc] ...) opt ...) - (begin - (unless (identifier? #'name) - (raise-syntax-error #f - "expected an identifier to name the structure type" - stx - #'name)) - (for-each (lambda (field) - (unless (identifier? field) - (syntax-case field () - [(id #:mutable) - (identifier? #'id) - 'ok] - [_ - (raise-syntax-error #f - "bad field specification" - stx - field)]))) - (syntax->list #'(field ...))) - (let-values ([(no-ctr? mutable? no-stx? no-rt?) - (let loop ([opts (syntax->list #'(opt ...))] - [no-ctr? #f] - [mutable? #f] - [no-stx? #f] - [no-rt? #f]) - (if (null? opts) - (values no-ctr? mutable? no-stx? no-rt?) - (let ([opt (car opts)]) - (case (syntax-e opt) - [(#:omit-constructor) - (if no-ctr? - (raise-syntax-error #f - "redundant option" - stx - opt) - (loop (cdr opts) #t mutable? no-stx? no-rt?))] - [(#:mutable) - (if mutable? - (raise-syntax-error #f - "redundant option" - stx - opt) - (loop (cdr opts) no-ctr? #t no-stx? no-rt?))] - [(#:omit-define-syntaxes) - (if no-stx? - (raise-syntax-error #f - "redundant option" - stx - opt) - (loop (cdr opts) no-ctr? mutable? #t no-rt?))] - [(#:omit-define-values) - (if no-rt? - (raise-syntax-error #f - "redundant option" - stx - opt) - (loop (cdr opts) no-ctr? mutable? no-stx? #t))] - [else - (raise-syntax-error #f - (string-append - "expected a keyword to specify option: " - "#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values") - stx - opt)]))))]) - (define (add-contracts l) - (let* ([pred (caddr l)] - [ctor-ctc #`(-> ctc ... #,pred)] - [pred-ctc #'(-> any/c boolean?)] - [field-ctcs - (apply append - (map (λ (f c) - (cons #`(-> #,pred #,c) - (if (and (not mutable?) - (not (pair? (syntax-e f)))) - null - #`(-> #,pred #,c void?)))) - (syntax->list #'(field ...)) - (syntax->list #'(ctc ...))))]) - (list* (car l) - (list (cadr l) ctor-ctc) - (list pred pred-ctc) - (map list (cdddr l) field-ctcs)))) - (cons - #`(define-syntaxes (name) - #,(build-struct-expand-info - #'name (syntax->list #'(field ...)) - #f (not mutable?) - #f '(#f) '(#f) - #:omit-constructor? no-ctr?)) - (let* ([names (add-contracts - (build-struct-names #'name (syntax->list #'(field ...)) - #f (not mutable?)))] - [cpairs (cons 'contracted - (if no-ctr? (cddr names) (cdr names)))]) - (list (car names) cpairs)))))) - ((_ name fields opt ...) - (raise-syntax-error #f - "bad syntax; expected a parenthesized sequence of fields" - stx - #'fields)) - ((_ name) - (raise-syntax-error #f - "bad syntax; missing fields" - stx)) - ((_) - (raise-syntax-error #f - "missing name and fields" - stx)))))