diff --git a/collects/lang/private/teach.ss b/collects/lang/private/teach.ss index 38d29cddf4..a28073cc50 100644 --- a/collects/lang/private/teach.ss +++ b/collects/lang/private/teach.ss @@ -38,7 +38,8 @@ mzlib/list mzlib/math scheme/match - "set-result.ss") + "set-result.ss" + (only racket/base define-struct)) (require-for-syntax "teachhelp.ss" "teach-shared.ss" syntax/kerncase @@ -753,12 +754,13 @@ (lambda (def-proc-names) (with-syntax ([(def-proc-name ...) def-proc-names] [(proc-name ...) proc-names]) - (stepper-syntax-property #`(define-values (def-proc-name ...) - (let () - (define-struct name_ (field_ ...) (make-inspector)) - (values proc-name ...))) - 'stepper-define-struct-hint - stx))))]) + (stepper-syntax-property + #`(define-values (def-proc-name ...) + (let () + (define-struct name_ (field_ ...) #:transparent #:constructor-name #,(car proc-names)) + (values proc-name ...))) + 'stepper-define-struct-hint + stx))))]) (let ([defn (quasisyntax/loc stx (begin diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 3c03679eeb..119774aa30 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -142,19 +142,22 @@ (syntax-case stx () [(_ arg ...) (datum->syntax stx - (cons (self-name-struct-info-id me) + (cons ((self-name-struct-info-id me)) #'(arg ...)) stx stx)] - [_ (let ([id (self-name-struct-info-id me)]) + [_ (let ([id ((self-name-struct-info-id me))]) (datum->syntax id (syntax-e id) stx stx))])) #:omit-define-syntaxes)) +(define-for-syntax option-keywords + "#:mutable, #:constructor-name, #:extra-constructor-name, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values") + ;; Replacement `struct' signature form for `scheme/unit': -(define-for-syntax (do-struct~ stx type-as-ctr?) +(define-for-syntax (do-struct~ stx extra-make?) (syntax-case stx () ((_ name (field ...) opt ...) (begin @@ -175,53 +178,85 @@ 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)]))))] - [(tmp-name) (and type-as-ctr? - (car (generate-temporaries #'(name))))]) + (let*-values ([(no-ctr? mutable? no-stx? no-rt? opt-cname) + (let loop ([opts (syntax->list #'(opt ...))] + [no-ctr? #f] + [mutable? #f] + [no-stx? #f] + [no-rt? #f] + [cname #f]) + (if (null? opts) + (values no-ctr? mutable? no-stx? no-rt? cname) + (let ([opt (car opts)]) + (case (syntax-e opt) + [(#:constructor-name #:extra-constructor-name) + (if cname + (raise-syntax-error #f + "redundant option" + stx + opt) + (if (null? (cdr opts)) + (raise-syntax-error #f + "missing identifier after option" + stx + opt) + (if (identifier? (cadr opts)) + (loop (cddr opts) #f mutable? no-stx? no-rt? + (if (eq? (syntax-e opt) '#:extra-constructor-name) + (list (cadr opts)) + (cadr opts))) + (raise-syntax-error #f + "not an identifier for a constructor name" + stx + (cadr opts)))))] + [(#:omit-constructor) + (if no-ctr? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) #t mutable? no-stx? no-rt? cname))] + [(#:mutable) + (if mutable? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? #t no-stx? no-rt? cname))] + [(#:omit-define-syntaxes) + (if no-stx? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? mutable? #t no-rt? cname))] + [(#:omit-define-values) + (if no-rt? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? mutable? no-stx? #t cname))] + [else + (raise-syntax-error #f + (string-append + "expected a keyword to specify option: " + option-keywords) + stx + opt)]))))] + [(def-cname) (cond + [opt-cname (if (pair? opt-cname) + (car opt-cname) + opt-cname)] + [extra-make? #f] + [else (car (generate-temporaries #'(name)))])] + [(cname) (cond + [opt-cname (if (pair? opt-cname) + (cons def-cname #'name) + (cons opt-cname opt-cname))] + [extra-make? #f] + [else (cons def-cname #'name)])] + [(self-ctr?) (and cname (bound-identifier=? #'name (cdr cname)))]) (cons #`(define-syntaxes (name) #,(let ([e (build-struct-expand-info @@ -229,19 +264,19 @@ #f (not mutable?) #f '(#f) '(#f) #:omit-constructor? no-ctr? - #:constructor-name (and type-as-ctr? (cons #'name tmp-name)))]) - (if type-as-ctr? + #:constructor-name def-cname)]) + (if self-ctr? #`(make-self-name-struct-info (lambda () #,e) - (quote-syntax #,tmp-name)) + (lambda () (quote-syntax #,def-cname))) e))) (let ([names (build-struct-names #'name (syntax->list #'(field ...)) #f (not mutable?) - #:constructor-name (and type-as-ctr? - (cons #'name tmp-name)))]) + #:constructor-name def-cname)]) (cond [no-ctr? (cons (car names) (cddr names))] - [tmp-name (cons #`(define-values-for-export (#,tmp-name) name) names)] + [self-ctr? (cons #`(define-values-for-export (#,def-cname) name) + names)] [else names])))))) ((_ name fields opt ...) (raise-syntax-error #f @@ -258,9 +293,9 @@ stx)))) (define-signature-form (struct~s stx) - (do-struct~ stx #f)) -(define-signature-form (struct~r stx) (do-struct~ stx #t)) +(define-signature-form (struct~r stx) + (do-struct~ stx #f)) (define-signature-form (struct/ctc stx) (parameterize ((error-syntax stx)) @@ -347,7 +382,7 @@ (raise-stx-err "missing name and fields"))))) ;; Replacement struct/ctc form for `scheme/unit': -(define-for-syntax (do-struct~/ctc stx type-as-ctr?) +(define-for-syntax (do-struct~/ctc stx extra-make?) (syntax-case stx () ((_ name ([field ctc] ...) opt ...) (begin @@ -368,53 +403,85 @@ 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)]))))] - [(tmp-name) (and type-as-ctr? - (car (generate-temporaries #'(name))))]) + (let*-values ([(no-ctr? mutable? no-stx? no-rt? opt-cname) + (let loop ([opts (syntax->list #'(opt ...))] + [no-ctr? #f] + [mutable? #f] + [no-stx? #f] + [no-rt? #f] + [cname #f]) + (if (null? opts) + (values no-ctr? mutable? no-stx? no-rt? cname) + (let ([opt (car opts)]) + (case (syntax-e opt) + [(#:constructor-name #:extra-constructor-name) + (if cname + (raise-syntax-error #f + "redundant option" + stx + opt) + (if (null? (cdr opts)) + (raise-syntax-error #f + "missing identifier after option" + stx + opt) + (if (identifier? (cadr opts)) + (loop (cddr opts) #f mutable? no-stx? no-rt? + (if (eq? (syntax-e opt) '#:extra-constructor-name) + (list (cadr opts)) + (cadr opts))) + (raise-syntax-error #f + "not an identifier for a constructor name" + stx + (cadr opts)))))] + [(#:omit-constructor) + (if no-ctr? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) #t mutable? no-stx? no-rt? cname))] + [(#:mutable) + (if mutable? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? #t no-stx? no-rt? cname))] + [(#:omit-define-syntaxes) + (if no-stx? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? mutable? #t no-rt? cname))] + [(#:omit-define-values) + (if no-rt? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? mutable? no-stx? #t cname))] + [else + (raise-syntax-error #f + (string-append + "expected a keyword to specify option: " + option-keywords) + stx + opt)]))))] + [(def-cname) (cond + [opt-cname (if (pair? opt-cname) + (car opt-cname) + opt-cname)] + [extra-make? #f] + [else (car (generate-temporaries #'(name)))])] + [(cname) (cond + [opt-cname (if (pair? opt-cname) + (cons def-cname #'name) + (cons def-cname def-cname))] + [extra-make? #f] + [else (cons def-cname #'name)])] + [(self-ctr?) (and cname (bound-identifier=? #'name (cdr cname)))]) (define (add-contracts l) (let* ([pred (caddr l)] [ctor-ctc #`(-> ctc ... #,pred)] @@ -435,20 +502,29 @@ (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? - #:constructor-name (and type-as-ctr? (cons #'name tmp-name)))) + #,(let ([e (build-struct-expand-info + #'name (syntax->list #'(field ...)) + #f (not mutable?) + #f '(#f) '(#f) + #:omit-constructor? no-ctr? + #:constructor-name def-cname)]) + (if self-ctr? + #`(make-self-name-struct-info + (lambda () #,e) + (lambda () (quote-syntax #,def-cname))) + e))) (let* ([names (add-contracts (build-struct-names #'name (syntax->list #'(field ...)) #f (not mutable?) - #:constructor-name (and type-as-ctr? - (cons #'name tmp-name))))] + #:constructor-name def-cname))] [cpairs (cons 'contracted - (if no-ctr? (cddr names) (cdr names)))]) - (list (car names) cpairs)))))) + (cond + [no-ctr? (cddr names)] + [else (cdr names)]))] + [l (list (car names) cpairs)]) + (if self-ctr? + (cons #`(define-values-for-export (#,def-cname) name) l) + l)))))) ((_ name fields opt ...) (raise-syntax-error #f "bad syntax; expected a parenthesized sequence of fields" @@ -464,9 +540,9 @@ stx)))) (define-signature-form (struct~s/ctc stx) - (do-struct~/ctc stx #f)) -(define-signature-form (struct~r/ctc stx) (do-struct~/ctc stx #t)) +(define-signature-form (struct~r/ctc stx) + (do-struct~/ctc stx #f)) ;; build-val+macro-defs : sig -> (list syntax-object^3) (define-for-syntax (build-val+macro-defs sig) diff --git a/collects/racket/contract/private/provide.ss b/collects/racket/contract/private/provide.ss index 76acf4dd06..80bea582a7 100644 --- a/collects/racket/contract/private/provide.ss +++ b/collects/racket/contract/private/provide.ss @@ -533,7 +533,7 @@ (loop (cdr l1) (+ i 1)))]))) - ;; get-field-counts/struct-names : syntax syntax -> (listof (cons symbol number)) + ;; get-field-counts/struct-names : syntax syntax -> (listof (cons number symbol)) ;; returns a list of numbers corresponding to the numbers of fields for each of the parent structs (define (get-field-counts/struct-names struct-name provide-stx) (let loop ([parent-info-id struct-name]) @@ -544,7 +544,7 @@ [(boolean? parent-info) null] [else (let ([fields (list-ref parent-info 3)] - [constructor (list-ref parent-info 1)]) + [predicate (list-ref parent-info 2)]) (cond [(and (not (null? fields)) (not (last fields))) @@ -554,16 +554,16 @@ provide-stx struct-name)] [else - (cons (cons (length fields) (constructor->struct-name provide-stx constructor)) + (cons (cons (length fields) (predicate->struct-name provide-stx predicate)) (loop (list-ref parent-info 5)))]))])))) - (define (constructor->struct-name orig-stx stx) + (define (predicate->struct-name orig-stx stx) (and stx - (let ([m (regexp-match #rx"^make-(.*)$" (format "~a" (syntax-e stx)))]) + (let ([m (regexp-match #rx"^(.*)[?]$" (format "~a" (syntax-e stx)))]) (cond [m (cadr m)] [else (raise-syntax-error 'contract-base.ss - "unable to cope with a struct maker whose name doesn't begin with `make-'" + "unable to cope with a struct supertype whose predicate doesn't end with `?'" orig-stx)])))) ;; build-constructor-contract : syntax (listof syntax) syntax -> syntax diff --git a/collects/racket/private/define-struct.rkt b/collects/racket/private/define-struct.rkt index 5b6046da32..65ac93e413 100644 --- a/collects/racket/private/define-struct.rkt +++ b/collects/racket/private/define-struct.rkt @@ -54,7 +54,7 @@ 1 0 #f (list (cons prop:procedure (lambda (v stx) - (self-ctor-transformer (ref v 0) stx)))) + (self-ctor-transformer ((ref v 0)) stx)))) (current-inspector) #f '(0))]) make-)) (define-values-for-syntax (make-self-ctor-checked-struct-info) @@ -63,7 +63,7 @@ 1 0 #f (list (cons prop:procedure (lambda (v stx) - (self-ctor-transformer (ref v 0) stx)))) + (self-ctor-transformer ((ref v 0)) stx)))) (current-inspector) #f '(0))]) make-)) @@ -203,6 +203,7 @@ (#:mutable . #f) (#:guard . #f) (#:constructor-name . #f) + (#:only-constructor? . #f) (#:omit-define-values . #f) (#:omit-define-syntaxes . #f))] [nongen? #f]) @@ -259,14 +260,17 @@ (loop (cdr p) (extend-config config '#:inspector #'#f) nongen?)] - [(eq? '#:constructor-name (syntax-e (car p))) + [(or (eq? '#:constructor-name (syntax-e (car p))) + (eq? '#:extra-constructor-name (syntax-e (car p)))) (check-exprs 1 p "identifier") (when (lookup config '#:constructor-name) - (bad "multiple #:constructor-name keys" (car p))) + (bad "multiple #:constructor-name or #:extra-constructor-name keys" (car p))) (unless (identifier? (cadr p)) (bad "need an identifier after #:constructor-name" (cadr p))) (loop (cddr p) - (extend-config config '#:constructor-name (cadr p)) + (extend-config (extend-config config '#:constructor-name (cadr p)) + '#:only-constructor? + (eq? '#:constructor-name (syntax-e (car p)))) nongen?)] [(eq? '#:prefab (syntax-e (car p))) (when (lookup config '#:inspector) @@ -360,7 +364,7 @@ (car field-stxes))] [else (loop (cdr fields) (cdr field-stxes) #f)]))]) - (let*-values ([(inspector super-expr props auto-val guard ctor-name mutable? + (let*-values ([(inspector super-expr props auto-val guard ctor-name ctor-only? mutable? omit-define-values? omit-define-syntaxes?) (let ([config (parse-props #'fm (syntax->list #'(prop ...)) super-id)]) (values (lookup config '#:inspector) @@ -369,11 +373,13 @@ (lookup config '#:auto-value) (lookup config '#:guard) (lookup config '#:constructor-name) + (lookup config '#:only-constructor?) (lookup config '#:mutable) (lookup config '#:omit-define-values) (lookup config '#:omit-define-syntaxes)))] [(self-ctor?) - (and ctor-name (bound-identifier=? id ctor-name))]) + (and ctor-name (bound-identifier=? id ctor-name))] + [(name-as-ctor?) (or self-ctor? (not ctor-only?))]) (when mutable? (for-each (lambda (f f-stx) (when (field-mutable? f) @@ -454,7 +460,7 @@ (cons i (loop (add1 i) (cdr fields)))] [else (loop (add1 i) (cdr fields))])) #,guard - '#,ctor-name))]) + '#,(if ctor-only? ctor-name id)))]) (values struct: make- ? #,@(let loop ([i 0][fields fields]) (if (null? fields) @@ -476,10 +482,10 @@ #`(quote-syntax #,(prune sel)) sel)))] [mk-info (if super-info-checked? - (if self-ctor? + (if name-as-ctor? #'make-self-ctor-checked-struct-info #'make-checked-struct-info) - (if self-ctor? + (if name-as-ctor? #'make-self-ctor-struct-info #'make-struct-info))]) (quasisyntax/loc stx @@ -488,7 +494,9 @@ (lambda () (list (quote-syntax #,(prune struct:)) - (quote-syntax #,(prune make-)) + (quote-syntax #,(prune (if (and ctor-name self-ctor?) + id + make-))) (quote-syntax #,(prune ?)) (list #,@(map protect (reverse sels)) @@ -517,8 +525,8 @@ (if super-expr #f #t)))) - #,@(if self-ctor? - (list #`(quote-syntax #,make-)) + #,@(if name-as-ctor? + (list #`(lambda () (quote-syntax #,make-))) null))))))]) (let ([result (cond diff --git a/collects/racket/private/for.rkt b/collects/racket/private/for.rkt index 3a252a81dd..b496e1b63b 100644 --- a/collects/racket/private/for.rkt +++ b/collects/racket/private/for.rkt @@ -329,7 +329,7 @@ [(hash? v) (:hash-key+val-gen v)] [(:sequence? v) (make-sequence who ((:sequence-ref v) v))] [else (raise - (make-exn:fail:contract + (exn:fail:contract (format "for: expected a sequence for ~a, got something else: ~v" (if (= 1 (length who)) (car who) diff --git a/collects/racket/private/kernstruct.rkt b/collects/racket/private/kernstruct.rkt index da6e9a620b..d4d7b7bbef 100644 --- a/collects/racket/private/kernstruct.rkt +++ b/collects/racket/private/kernstruct.rkt @@ -6,266 +6,438 @@ (#%require "define.rkt") (#%require (for-syntax "struct-info.rkt")) (#%provide (all-defined)) - (define-syntax exn - (make-struct-info - (λ () - (list - (quote-syntax struct:exn) - (quote-syntax make-exn) - (quote-syntax exn?) - (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) - '(#f #f) - #t)))) - (define-syntax exn:fail - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail) - (quote-syntax make-exn:fail) - (quote-syntax exn:fail?) - (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) - '(#f #f) - (quote-syntax exn))))) - (define-syntax exn:fail:contract - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail:contract) - (quote-syntax make-exn:fail:contract) - (quote-syntax exn:fail:contract?) - (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) - '(#f #f) - (quote-syntax exn:fail))))) - (define-syntax exn:fail:contract:arity - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail:contract:arity) - (quote-syntax make-exn:fail:contract:arity) - (quote-syntax exn:fail:contract:arity?) - (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) - '(#f #f) - (quote-syntax exn:fail:contract))))) - (define-syntax exn:fail:contract:divide-by-zero - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail:contract:divide-by-zero) - (quote-syntax make-exn:fail:contract:divide-by-zero) - (quote-syntax exn:fail:contract:divide-by-zero?) - (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) - '(#f #f) - (quote-syntax exn:fail:contract))))) - (define-syntax exn:fail:contract:non-fixnum-result - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail:contract:non-fixnum-result) - (quote-syntax make-exn:fail:contract:non-fixnum-result) - (quote-syntax exn:fail:contract:non-fixnum-result?) - (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) - '(#f #f) - (quote-syntax exn:fail:contract))))) - (define-syntax exn:fail:contract:continuation - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail:contract:continuation) - (quote-syntax make-exn:fail:contract:continuation) - (quote-syntax exn:fail:contract:continuation?) - (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) - '(#f #f) - (quote-syntax exn:fail:contract))))) - (define-syntax exn:fail:contract:variable - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail:contract:variable) - (quote-syntax make-exn:fail:contract:variable) - (quote-syntax exn:fail:contract:variable?) - (list - (quote-syntax exn:fail:contract:variable-id) - (quote-syntax exn-continuation-marks) - (quote-syntax exn-message)) - '(#f #f #f) - (quote-syntax exn:fail:contract))))) - (define-syntax exn:fail:syntax - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail:syntax) - (quote-syntax make-exn:fail:syntax) - (quote-syntax exn:fail:syntax?) - (list - (quote-syntax exn:fail:syntax-exprs) - (quote-syntax exn-continuation-marks) - (quote-syntax exn-message)) - '(#f #f #f) - (quote-syntax exn:fail))))) - (define-syntax exn:fail:read - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail:read) - (quote-syntax make-exn:fail:read) - (quote-syntax exn:fail:read?) - (list - (quote-syntax exn:fail:read-srclocs) - (quote-syntax exn-continuation-marks) - (quote-syntax exn-message)) - '(#f #f #f) - (quote-syntax exn:fail))))) - (define-syntax exn:fail:read:eof - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail:read:eof) - (quote-syntax make-exn:fail:read:eof) - (quote-syntax exn:fail:read:eof?) - (list - (quote-syntax exn:fail:read-srclocs) - (quote-syntax exn-continuation-marks) - (quote-syntax exn-message)) - '(#f #f #f) - (quote-syntax exn:fail:read))))) - (define-syntax exn:fail:read:non-char - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail:read:non-char) - (quote-syntax make-exn:fail:read:non-char) - (quote-syntax exn:fail:read:non-char?) - (list - (quote-syntax exn:fail:read-srclocs) - (quote-syntax exn-continuation-marks) - (quote-syntax exn-message)) - '(#f #f #f) - (quote-syntax exn:fail:read))))) - (define-syntax exn:fail:filesystem - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail:filesystem) - (quote-syntax make-exn:fail:filesystem) - (quote-syntax exn:fail:filesystem?) - (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) - '(#f #f) - (quote-syntax exn:fail))))) - (define-syntax exn:fail:filesystem:exists - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail:filesystem:exists) - (quote-syntax make-exn:fail:filesystem:exists) - (quote-syntax exn:fail:filesystem:exists?) - (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) - '(#f #f) - (quote-syntax exn:fail:filesystem))))) - (define-syntax exn:fail:filesystem:version - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail:filesystem:version) - (quote-syntax make-exn:fail:filesystem:version) - (quote-syntax exn:fail:filesystem:version?) - (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) - '(#f #f) - (quote-syntax exn:fail:filesystem))))) - (define-syntax exn:fail:network - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail:network) - (quote-syntax make-exn:fail:network) - (quote-syntax exn:fail:network?) - (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) - '(#f #f) - (quote-syntax exn:fail))))) - (define-syntax exn:fail:out-of-memory - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail:out-of-memory) - (quote-syntax make-exn:fail:out-of-memory) - (quote-syntax exn:fail:out-of-memory?) - (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) - '(#f #f) - (quote-syntax exn:fail))))) - (define-syntax exn:fail:unsupported - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail:unsupported) - (quote-syntax make-exn:fail:unsupported) - (quote-syntax exn:fail:unsupported?) - (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) - '(#f #f) - (quote-syntax exn:fail))))) - (define-syntax exn:fail:user - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:fail:user) - (quote-syntax make-exn:fail:user) - (quote-syntax exn:fail:user?) - (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) - '(#f #f) - (quote-syntax exn:fail))))) - (define-syntax exn:break - (make-struct-info - (λ () - (list - (quote-syntax struct:exn:break) - (quote-syntax make-exn:break) - (quote-syntax exn:break?) - (list - (quote-syntax exn:break-continuation) - (quote-syntax exn-continuation-marks) - (quote-syntax exn-message)) - '(#f #f #f) - (quote-syntax exn))))) - (define-syntax arity-at-least - (make-struct-info - (λ () - (list - (quote-syntax struct:arity-at-least) - (quote-syntax make-arity-at-least) - (quote-syntax arity-at-least?) - (list (quote-syntax arity-at-least-value)) - '(#f) - #t)))) - (define-syntax date - (make-struct-info - (λ () - (list - (quote-syntax struct:date) - (quote-syntax make-date) - (quote-syntax date?) - (list - (quote-syntax date-time-zone-offset) - (quote-syntax date-dst?) - (quote-syntax date-year-day) - (quote-syntax date-week-day) - (quote-syntax date-year) - (quote-syntax date-month) - (quote-syntax date-day) - (quote-syntax date-hour) - (quote-syntax date-minute) - (quote-syntax date-second)) - '(#f #f #f #f #f #f #f #f #f #f) - #t)))) - (define-syntax srcloc - (make-struct-info - (λ () - (list - (quote-syntax struct:srcloc) - (quote-syntax make-srcloc) - (quote-syntax srcloc?) - (list - (quote-syntax srcloc-span) - (quote-syntax srcloc-position) - (quote-syntax srcloc-column) - (quote-syntax srcloc-line) - (quote-syntax srcloc-source)) - '(#f #f #f #f #f) - #t))))) + (define-values-for-syntax + (make-self-ctr-struct-info) + (letrec-values (((struct: make- ? ref set!) + (make-struct-type + 'self-ctor-struct-info + struct:struct-info + 1 + 0 + #f + (list + (cons + prop:procedure + (lambda (v stx) + (let-values (((id) ((ref v 0)))) + (if (symbol? (syntax-e stx)) + id + (datum->syntax + stx + (cons id (cdr (syntax-e stx))) + stx + stx)))))) + (current-inspector) + #f + '(0)))) + make-)) + (begin + (#%require (rename '#%kernel kernel:exn exn)) + (define make-exn kernel:exn) + (define-syntax exn + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn) + (quote-syntax make-exn) + (quote-syntax exn?) + (list + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f) + #t)) + (λ () (quote-syntax kernel:exn))))) + (begin + (#%require (rename '#%kernel kernel:exn:fail exn:fail)) + (define make-exn:fail kernel:exn:fail) + (define-syntax exn:fail + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail) + (quote-syntax make-exn:fail) + (quote-syntax exn:fail?) + (list + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f) + (quote-syntax exn))) + (λ () (quote-syntax kernel:exn:fail))))) + (begin + (#%require (rename '#%kernel kernel:exn:fail:contract exn:fail:contract)) + (define make-exn:fail:contract kernel:exn:fail:contract) + (define-syntax exn:fail:contract + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail:contract) + (quote-syntax make-exn:fail:contract) + (quote-syntax exn:fail:contract?) + (list + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f) + (quote-syntax exn:fail))) + (λ () (quote-syntax kernel:exn:fail:contract))))) + (begin + (#%require + (rename '#%kernel kernel:exn:fail:contract:arity exn:fail:contract:arity)) + (define make-exn:fail:contract:arity kernel:exn:fail:contract:arity) + (define-syntax exn:fail:contract:arity + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail:contract:arity) + (quote-syntax make-exn:fail:contract:arity) + (quote-syntax exn:fail:contract:arity?) + (list + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f) + (quote-syntax exn:fail:contract))) + (λ () (quote-syntax kernel:exn:fail:contract:arity))))) + (begin + (#%require + (rename '#%kernel + kernel:exn:fail:contract:divide-by-zero + exn:fail:contract:divide-by-zero)) + (define make-exn:fail:contract:divide-by-zero + kernel:exn:fail:contract:divide-by-zero) + (define-syntax exn:fail:contract:divide-by-zero + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail:contract:divide-by-zero) + (quote-syntax make-exn:fail:contract:divide-by-zero) + (quote-syntax exn:fail:contract:divide-by-zero?) + (list + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f) + (quote-syntax exn:fail:contract))) + (λ () (quote-syntax kernel:exn:fail:contract:divide-by-zero))))) + (begin + (#%require + (rename '#%kernel + kernel:exn:fail:contract:non-fixnum-result + exn:fail:contract:non-fixnum-result)) + (define make-exn:fail:contract:non-fixnum-result + kernel:exn:fail:contract:non-fixnum-result) + (define-syntax exn:fail:contract:non-fixnum-result + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail:contract:non-fixnum-result) + (quote-syntax make-exn:fail:contract:non-fixnum-result) + (quote-syntax exn:fail:contract:non-fixnum-result?) + (list + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f) + (quote-syntax exn:fail:contract))) + (λ () (quote-syntax kernel:exn:fail:contract:non-fixnum-result))))) + (begin + (#%require + (rename '#%kernel + kernel:exn:fail:contract:continuation + exn:fail:contract:continuation)) + (define make-exn:fail:contract:continuation + kernel:exn:fail:contract:continuation) + (define-syntax exn:fail:contract:continuation + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail:contract:continuation) + (quote-syntax make-exn:fail:contract:continuation) + (quote-syntax exn:fail:contract:continuation?) + (list + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f) + (quote-syntax exn:fail:contract))) + (λ () (quote-syntax kernel:exn:fail:contract:continuation))))) + (begin + (#%require + (rename '#%kernel + kernel:exn:fail:contract:variable + exn:fail:contract:variable)) + (define make-exn:fail:contract:variable kernel:exn:fail:contract:variable) + (define-syntax exn:fail:contract:variable + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail:contract:variable) + (quote-syntax make-exn:fail:contract:variable) + (quote-syntax exn:fail:contract:variable?) + (list + (quote-syntax exn:fail:contract:variable-id) + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f #f) + (quote-syntax exn:fail:contract))) + (λ () (quote-syntax kernel:exn:fail:contract:variable))))) + (begin + (#%require (rename '#%kernel kernel:exn:fail:syntax exn:fail:syntax)) + (define make-exn:fail:syntax kernel:exn:fail:syntax) + (define-syntax exn:fail:syntax + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail:syntax) + (quote-syntax make-exn:fail:syntax) + (quote-syntax exn:fail:syntax?) + (list + (quote-syntax exn:fail:syntax-exprs) + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f #f) + (quote-syntax exn:fail))) + (λ () (quote-syntax kernel:exn:fail:syntax))))) + (begin + (#%require (rename '#%kernel kernel:exn:fail:read exn:fail:read)) + (define make-exn:fail:read kernel:exn:fail:read) + (define-syntax exn:fail:read + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail:read) + (quote-syntax make-exn:fail:read) + (quote-syntax exn:fail:read?) + (list + (quote-syntax exn:fail:read-srclocs) + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f #f) + (quote-syntax exn:fail))) + (λ () (quote-syntax kernel:exn:fail:read))))) + (begin + (#%require (rename '#%kernel kernel:exn:fail:read:eof exn:fail:read:eof)) + (define make-exn:fail:read:eof kernel:exn:fail:read:eof) + (define-syntax exn:fail:read:eof + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail:read:eof) + (quote-syntax make-exn:fail:read:eof) + (quote-syntax exn:fail:read:eof?) + (list + (quote-syntax exn:fail:read-srclocs) + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f #f) + (quote-syntax exn:fail:read))) + (λ () (quote-syntax kernel:exn:fail:read:eof))))) + (begin + (#%require + (rename '#%kernel kernel:exn:fail:read:non-char exn:fail:read:non-char)) + (define make-exn:fail:read:non-char kernel:exn:fail:read:non-char) + (define-syntax exn:fail:read:non-char + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail:read:non-char) + (quote-syntax make-exn:fail:read:non-char) + (quote-syntax exn:fail:read:non-char?) + (list + (quote-syntax exn:fail:read-srclocs) + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f #f) + (quote-syntax exn:fail:read))) + (λ () (quote-syntax kernel:exn:fail:read:non-char))))) + (begin + (#%require + (rename '#%kernel kernel:exn:fail:filesystem exn:fail:filesystem)) + (define make-exn:fail:filesystem kernel:exn:fail:filesystem) + (define-syntax exn:fail:filesystem + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail:filesystem) + (quote-syntax make-exn:fail:filesystem) + (quote-syntax exn:fail:filesystem?) + (list + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f) + (quote-syntax exn:fail))) + (λ () (quote-syntax kernel:exn:fail:filesystem))))) + (begin + (#%require + (rename '#%kernel + kernel:exn:fail:filesystem:exists + exn:fail:filesystem:exists)) + (define make-exn:fail:filesystem:exists kernel:exn:fail:filesystem:exists) + (define-syntax exn:fail:filesystem:exists + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail:filesystem:exists) + (quote-syntax make-exn:fail:filesystem:exists) + (quote-syntax exn:fail:filesystem:exists?) + (list + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f) + (quote-syntax exn:fail:filesystem))) + (λ () (quote-syntax kernel:exn:fail:filesystem:exists))))) + (begin + (#%require + (rename '#%kernel + kernel:exn:fail:filesystem:version + exn:fail:filesystem:version)) + (define make-exn:fail:filesystem:version + kernel:exn:fail:filesystem:version) + (define-syntax exn:fail:filesystem:version + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail:filesystem:version) + (quote-syntax make-exn:fail:filesystem:version) + (quote-syntax exn:fail:filesystem:version?) + (list + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f) + (quote-syntax exn:fail:filesystem))) + (λ () (quote-syntax kernel:exn:fail:filesystem:version))))) + (begin + (#%require (rename '#%kernel kernel:exn:fail:network exn:fail:network)) + (define make-exn:fail:network kernel:exn:fail:network) + (define-syntax exn:fail:network + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail:network) + (quote-syntax make-exn:fail:network) + (quote-syntax exn:fail:network?) + (list + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f) + (quote-syntax exn:fail))) + (λ () (quote-syntax kernel:exn:fail:network))))) + (begin + (#%require + (rename '#%kernel kernel:exn:fail:out-of-memory exn:fail:out-of-memory)) + (define make-exn:fail:out-of-memory kernel:exn:fail:out-of-memory) + (define-syntax exn:fail:out-of-memory + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail:out-of-memory) + (quote-syntax make-exn:fail:out-of-memory) + (quote-syntax exn:fail:out-of-memory?) + (list + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f) + (quote-syntax exn:fail))) + (λ () (quote-syntax kernel:exn:fail:out-of-memory))))) + (begin + (#%require + (rename '#%kernel kernel:exn:fail:unsupported exn:fail:unsupported)) + (define make-exn:fail:unsupported kernel:exn:fail:unsupported) + (define-syntax exn:fail:unsupported + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail:unsupported) + (quote-syntax make-exn:fail:unsupported) + (quote-syntax exn:fail:unsupported?) + (list + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f) + (quote-syntax exn:fail))) + (λ () (quote-syntax kernel:exn:fail:unsupported))))) + (begin + (#%require (rename '#%kernel kernel:exn:fail:user exn:fail:user)) + (define make-exn:fail:user kernel:exn:fail:user) + (define-syntax exn:fail:user + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:fail:user) + (quote-syntax make-exn:fail:user) + (quote-syntax exn:fail:user?) + (list + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f) + (quote-syntax exn:fail))) + (λ () (quote-syntax kernel:exn:fail:user))))) + (begin + (#%require (rename '#%kernel kernel:exn:break exn:break)) + (define make-exn:break kernel:exn:break) + (define-syntax exn:break + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:exn:break) + (quote-syntax make-exn:break) + (quote-syntax exn:break?) + (list + (quote-syntax exn:break-continuation) + (quote-syntax exn-continuation-marks) + (quote-syntax exn-message)) + '(#f #f #f) + (quote-syntax exn))) + (λ () (quote-syntax kernel:exn:break))))) + (begin + (#%require (rename '#%kernel kernel:arity-at-least arity-at-least)) + (define make-arity-at-least kernel:arity-at-least) + (define-syntax arity-at-least + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:arity-at-least) + (quote-syntax make-arity-at-least) + (quote-syntax arity-at-least?) + (list (quote-syntax arity-at-least-value)) + '(#f) + #t)) + (λ () (quote-syntax kernel:arity-at-least))))) + (begin + (#%require (rename '#%kernel kernel:date date)) + (define make-date kernel:date) + (define-syntax date + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:date) + (quote-syntax make-date) + (quote-syntax date?) + (list + (quote-syntax date-time-zone-offset) + (quote-syntax date-dst?) + (quote-syntax date-year-day) + (quote-syntax date-week-day) + (quote-syntax date-year) + (quote-syntax date-month) + (quote-syntax date-day) + (quote-syntax date-hour) + (quote-syntax date-minute) + (quote-syntax date-second)) + '(#f #f #f #f #f #f #f #f #f #f) + #t)) + (λ () (quote-syntax kernel:date))))) + (begin + (#%require (rename '#%kernel kernel:srcloc srcloc)) + (define make-srcloc kernel:srcloc) + (define-syntax srcloc + (make-self-ctr-struct-info + (λ () + (list + (quote-syntax struct:srcloc) + (quote-syntax make-srcloc) + (quote-syntax srcloc?) + (list + (quote-syntax srcloc-span) + (quote-syntax srcloc-position) + (quote-syntax srcloc-column) + (quote-syntax srcloc-line) + (quote-syntax srcloc-source)) + '(#f #f #f #f #f) + #t)) + (λ () (quote-syntax kernel:srcloc)))))) diff --git a/collects/racket/private/kw.rkt b/collects/racket/private/kw.rkt index 8febbdb1e9..14c8319042 100644 --- a/collects/racket/private/kw.rkt +++ b/collects/racket/private/kw.rkt @@ -948,7 +948,7 @@ (object-name p) p))]) (raise - (make-exn:fail:contract + (exn:fail:contract (if extra-kw (if (keyword-procedure? p) (format @@ -1028,7 +1028,7 @@ (cond [(integer? a) (+ a delta)] [(arity-at-least? a) - (make-arity-at-least (+ (arity-at-least-value a) delta))] + (arity-at-least (+ (arity-at-least-value a) delta))] [else (map loop a)])))] [new-arity (inc-arity arity 2)] diff --git a/collects/racket/private/misc.rkt b/collects/racket/private/misc.rkt index 90c2f99542..d4aa4e5b6e 100644 --- a/collects/racket/private/misc.rkt +++ b/collects/racket/private/misc.rkt @@ -99,7 +99,7 @@ (let-values ([(base name dir?) (split-path n)]) (if dir? (raise - (make-exn:fail:filesystem + (exn:fail:filesystem (string->immutable-string (format "load/cd: cannot open a directory: ~s" n)) (current-continuation-marks))) @@ -108,7 +108,7 @@ (begin (if (not (directory-exists? base)) (raise - (make-exn:fail:filesystem + (exn:fail:filesystem (string->immutable-string (format "load/cd: directory of ~s does not exist (current directory is ~s)" diff --git a/collects/racket/private/more-scheme.rkt b/collects/racket/private/more-scheme.rkt index 0c32ee0fe0..482dec13f5 100644 --- a/collects/racket/private/more-scheme.rkt +++ b/collects/racket/private/more-scheme.rkt @@ -367,9 +367,10 @@ (let* ([not-there (gensym)] [up (lambda (who mut? set ht key xform default) (unless (and (hash? ht) - (or (not mut?) - (not (immutable? ht)))) - (raise-type-error who (if mut? "mutable hash" "hash") ht)) + (if mut? + (not (immutable? ht)) + (immutable? ht))) + (raise-type-error who (if mut? "mutable hash table" "immutable hash table") ht)) (unless (and (procedure? xform) (procedure-arity-includes? xform 1)) (raise-type-error who "procedure (arity 1)" xform)) @@ -391,9 +392,14 @@ (hash-update! ht key xform not-there)])] [hash-has-key? (lambda (ht key) + (unless (hash? ht) + (raise-type-error 'hash-has-key? "hash table" 0 ht key)) (not (eq? not-there (hash-ref ht key not-there))))] [hash-ref! (lambda (ht key new) + (unless (and (hash? ht) + (not (immutable? ht))) + (raise-type-error 'hash-ref! "mutable hash table" 0 ht key new)) (let ([v (hash-ref ht key not-there)]) (if (eq? not-there v) (let ([n (if (procedure? new) (new) new)]) diff --git a/collects/racket/private/struct.rkt b/collects/racket/private/struct.rkt index ccb78bb65f..77e2fc07bc 100644 --- a/collects/racket/private/struct.rkt +++ b/collects/racket/private/struct.rkt @@ -14,6 +14,7 @@ (cond [(syntax? config) (config-has-name? (syntax-e config))] [(pair? config) (or (eq? (syntax-e (car config)) '#:constructor-name) + (eq? (syntax-e (car config)) '#:extra-constructor-name) (config-has-name? (cdr config)))] [else #f])) (with-syntax ([orig stx]) diff --git a/collects/racket/unit.rkt b/collects/racket/unit.rkt index 3b465e3037..b7da3f2478 100644 --- a/collects/racket/unit.rkt +++ b/collects/racket/unit.rkt @@ -5,6 +5,7 @@ (for-syntax racket/base syntax/struct)) (provide (except-out (all-from-out mzlib/unit) - struct struct/ctc - struct~r struct~r/ctc - struct~s struct~s/ctc))) + struct struct/ctc + struct~r struct~r/ctc + struct~s struct~s/ctc) + (rename-out [struct~r/ctc struct/ctc]))) diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss index 960b4cd89a..d84a5bf71d 100644 --- a/collects/scribble/manual.ss +++ b/collects/scribble/manual.ss @@ -23,8 +23,9 @@ "private/manual-bib.ss" "private/manual-form.ss" "private/manual-class.ss" - "private/manual-unit.ss" - "private/manual-vars.ss") + "private/manual-unit.ss") + (except-out (all-from-out "private/manual-vars.ss") + *deftogether) (except-out (all-from-out "private/manual-proc.ss") *defthing)) diff --git a/collects/scribble/private/manual-form.ss b/collects/scribble/private/manual-form.ss index f73671fd6f..31d023deb6 100644 --- a/collects/scribble/private/manual-form.ss +++ b/collects/scribble/private/manual-form.ss @@ -25,7 +25,9 @@ specsubform specsubform/subs specspecsubform specspecsubform/subs specsubform/inline defsubform defsubform* - schemegrammar schemegrammar* + racketgrammar racketgrammar* + (rename-out [racketgrammar schemegrammar] + [racketgrammar* schemegrammar*]) var svar) (define-syntax (defform*/subs stx) @@ -269,32 +271,32 @@ ([form/maybe (#f spec)]) (*specsubform 'spec null #f null null null (lambda () (list desc ...))))) -(define-syntax schemegrammar +(define-syntax racketgrammar (syntax-rules () [(_ #:literals (lit ...) id clause ...) (with-scheme-variables (lit ...) ([non-term (id clause ...)]) - (*schemegrammar '(lit ...) + (*racketgrammar '(lit ...) '(id clause ...) (lambda () (list (list (scheme id) (schemeblock0/form clause) ...)))))] - [(_ id clause ...) (schemegrammar #:literals () id clause ...)])) + [(_ id clause ...) (racketgrammar #:literals () id clause ...)])) -(define-syntax schemegrammar* +(define-syntax racketgrammar* (syntax-rules () [(_ #:literals (lit ...) [id clause ...] ...) (with-scheme-variables (lit ...) ([non-term (id clause ...)] ...) - (*schemegrammar '(lit ...) + (*racketgrammar '(lit ...) '(id ... clause ... ...) (lambda () (list (list (scheme id) (schemeblock0/form clause) ...) ...))))] [(_ [id clause ...] ...) - (schemegrammar* #:literals () [id clause ...] ...)])) + (racketgrammar* #:literals () [id clause ...] ...)])) (define-syntax-rule (var id) (*var 'id)) @@ -409,7 +411,7 @@ (define (*schemerawgrammar style nonterm clause1 . clauses) (*schemerawgrammars style (list nonterm) (list (cons clause1 clauses)))) -(define (*schemegrammar lits s-expr clauseses-thunk) +(define (*racketgrammar lits s-expr clauseses-thunk) (let ([l (clauseses-thunk)]) (*schemerawgrammars #f (map (lambda (x) diff --git a/collects/scribble/private/manual-proc.ss b/collects/scribble/private/manual-proc.ss index 0f582a5e6a..076a30d953 100644 --- a/collects/scribble/private/manual-proc.ss +++ b/collects/scribble/private/manual-proc.ss @@ -20,7 +20,7 @@ (for-label racket/base racket/class)) -(provide defproc defproc* defstruct +(provide defproc defproc* defstruct defstruct* defparam defparam* defboolparam defthing defthing* defthing/proc ; XXX unknown contract @@ -485,42 +485,90 @@ ;; ---------------------------------------- -(define-syntax defstruct - (syntax-rules () - [(_ name fields #:mutable #:inspector #f desc ...) - (**defstruct name fields #f #t #f desc ...)] - [(_ name fields #:mutable #:transparent desc ...) - (**defstruct name fields #f #t #f desc ...)] - [(_ name fields #:mutable #:prefab desc ...) - (**defstruct name fields #f #t #t desc ...)] - [(_ name fields #:mutable desc ...) - (**defstruct name fields #f #f #f desc ...)] - [(_ name fields #:inspector #f desc ...) - (**defstruct name fields #t #t #f desc ...)] - [(_ name fields #:transparent desc ...) - (**defstruct name fields #t #t #f desc ...)] - [(_ name fields #:prefab desc ...) - (**defstruct name fields #t #t #t desc ...)] - [(_ name fields desc ...) - (**defstruct name fields #t #f #f desc ...)])) +(define-syntax-rule (define-defstruct defstruct default-cname) + (... + (define-syntax defstruct + (syntax-rules () + [(_ name fields #:constructor-name cname #:mutable #:inspector #f desc ...) + (**defstruct name fields #f #t #f cname #f desc ...)] + [(_ name fields #:extra-constructor-name cname #:mutable #:inspector #f desc ...) + (**defstruct name fields #f #t #f cname #t desc ...)] + [(_ name fields #:mutable #:inspector #f desc ...) + (**defstruct name fields #f #t #f default-cname #t desc ...)] + [(_ name fields #:constructor-name cname #:mutable #:transparent desc ...) + (**defstruct name fields #f #t #f cname #f desc ...)] + [(_ name fields #:extra-constructor-name cname #:mutable #:transparent desc ...) + (**defstruct name fields #f #t #f cname #t desc ...)] + [(_ name fields #:mutable #:transparent desc ...) + (**defstruct name fields #f #t #f default-cname #t desc ...)] + [(_ name fields #:constructor-name cname #:mutable #:prefab desc ...) + (**defstruct name fields #f #t #t cname #f desc ...)] + [(_ name fields #:extra-constructor-name cname #:mutable #:prefab desc ...) + (**defstruct name fields #f #t #t cname #t desc ...)] + [(_ name fields #:mutable #:prefab desc ...) + (**defstruct name fields #f #t #t default-cname #t desc ...)] + [(_ name fields #:constructor-name cname #:mutable desc ...) + (**defstruct name fields #f #f #f cname #f desc ...)] + [(_ name fields #:extra-constructor-name cname #:mutable desc ...) + (**defstruct name fields #f #f #f cname #t desc ...)] + [(_ name fields #:mutable desc ...) + (**defstruct name fields #f #f #f default-cname #f desc ...)] + [(_ name fields #:constructor-name cname #:inspector #f desc ...) + (**defstruct name fields #t #t #f cname #f desc ...)] + [(_ name fields #:extra-constructor-name cname #:inspector #f desc ...) + (**defstruct name fields #t #t #f cname #t desc ...)] + [(_ name fields #:inspector #f desc ...) + (**defstruct name fields #t #t #f default-cname #t desc ...)] + [(_ name fields #:constructor-name cname #:transparent desc ...) + (**defstruct name fields #t #t #f cname #f desc ...)] + [(_ name fields #:extra-constructor-name cname #:transparent desc ...) + (**defstruct name fields #t #t #f cname #t desc ...)] + [(_ name fields #:transparent desc ...) + (**defstruct name fields #t #t #f default-cname #t desc ...)] + [(_ name fields #:constructor-name cname #:prefab desc ...) + (**defstruct name fields #t #t #t cname #f desc ...)] + [(_ name fields #:extra-constructor-name cname #:prefab desc ...) + (**defstruct name fields #t #t #t cname #t desc ...)] + [(_ name fields #:prefab desc ...) + (**defstruct name fields #t #t #t default-cname #t desc ...)] + [(_ name fields #:constructor-name cname desc ...) + (**defstruct name fields #t #f #f cname #f desc ...)] + [(_ name fields #:extra-constructor-name cname desc ...) + (**defstruct name fields #t #f #f cname #t desc ...)] + [(_ name fields desc ...) + (**defstruct name fields #t #f #f default-cname #t desc ...)])))) + +(define-defstruct defstruct #t) +(define-defstruct defstruct* #f) (define-syntax-rule (**defstruct name ([field field-contract] ...) immutable? - transparent? prefab? desc ...) + transparent? prefab? cname extra-cname? desc ...) (with-togetherable-scheme-variables () () - (*defstruct (quote-syntax/loc name) 'name + (*defstruct (quote-syntax/loc name) 'name (quote-syntax/loc cname) extra-cname? '([field field-contract] ...) (list (lambda () (schemeblock0 field-contract)) ...) immutable? transparent? prefab? (lambda () (list desc ...))))) -(define (*defstruct stx-id name fields field-contracts immutable? transparent? prefab? +(define (*defstruct stx-id name alt-cname-id extra-cname? + fields field-contracts immutable? transparent? prefab? content-thunk) (define (field-name f) ((if (pair? (car f)) caar car) f)) (define (field-view f) (if (pair? (car f)) (make-shaped-parens (car f) #\[) (car f))) - (make-box-splice - (cons + (define cname-id + (cond + [(identifier? alt-cname-id) alt-cname-id] + [(not (syntax-e alt-cname-id)) #f] + [else (let ([name-id (if (identifier? stx-id) + stx-id + (car (syntax-e stx-id)))]) + (datum->syntax name-id + (string->symbol (format "make-~a" (syntax-e name-id))) + name-id + name-id))])) + (define main-table (make-table 'boxed (cons @@ -543,8 +591,10 @@ (list* (list 'info name) (list 'type 'struct: name) (list 'predicate name '?) - (list 'constructor 'make- name) (append + (if cname-id + (list (list 'constructor (syntax-e cname-id))) + null) (map (lambda (f) (list 'accessor name '- (field-name f))) @@ -584,96 +634,111 @@ fields)))]) (if (and (short-width . < . max-proto-width) immutable? - (not transparent?)) + (not transparent?) + (not cname-id)) (make-omitable-paragraph (list (to-element `(,(scheme struct) ,the-name ,(map field-view fields))))) - (make-table - #f - (append - (list - (list (to-flow (make-element #f - (list - (schemeparenfont "(") - (scheme struct)))) - flow-spacer - (to-flow the-name) - (if (or (null? fields) - (short-width . < . max-proto-width)) - flow-spacer - (to-flow (make-element - #f (list spacer (schemeparenfont "("))))) - (to-flow (if (or (null? fields) - (short-width . < . max-proto-width)) - (make-element - #f (cons (to-element (map field-view - fields)) - (if (and immutable? - (not transparent?)) - (list (schemeparenfont ")")) - null))) - (to-element (field-view (car fields))))))) - (if (short-width . < . max-proto-width) - null - (let loop ([fields (if (null? fields) - fields (cdr fields))]) - (if (null? fields) + (let* ([one-right-column? + (or (null? fields) + (short-width . < . max-proto-width))] + [a-right-column + (lambda (c) + (if one-right-column? + (list flow-spacer flow-spacer c) + (list flow-spacer flow-spacer c 'cont 'cont)))]) + (make-table + #f + (append + (list + (append + (list (to-flow (make-element #f + (list + (schemeparenfont "(") + (scheme struct)))) + flow-spacer) + (if one-right-column? + (list (to-flow (make-element + #f + (list* the-name + spacer + (to-element (map field-view + fields)) + (if (and immutable? + (not transparent?) + (not cname-id)) + (list (schemeparenfont ")")) + null))))) + (list (to-flow the-name) + (to-flow (make-element + #f (list spacer (schemeparenfont "(")))) + (to-flow (to-element (field-view (car fields)))))))) + (if (short-width . < . max-proto-width) null - (cons - (let ([fld (car fields)]) - (list flow-spacer flow-spacer - flow-spacer flow-spacer - (to-flow - (let ([e (to-element (field-view fld))]) - (if (null? (cdr fields)) - (make-element - #f - (list e (schemeparenfont - (if (and immutable? - (not transparent?)) - "))" ")")))) - e))))) - (loop (cdr fields)))))) - (cond - [(and (not immutable?) transparent?) - (list - (list flow-spacer flow-spacer - (to-flow (to-element '#:mutable)) - 'cont - 'cont) - (list flow-spacer flow-spacer - (to-flow (make-element - #f - (list (if prefab? - (to-element '#:prefab) - (to-element '#:transparent)) - (schemeparenfont ")")))) - 'cont - 'cont))] - [(not immutable?) - (list - (list flow-spacer flow-spacer - (to-flow (make-element - #f - (list (to-element '#:mutable) - (schemeparenfont ")")))) - 'cont - 'cont))] - [transparent? - (list - (list flow-spacer flow-spacer - (to-flow (make-element - #f - (list (if prefab? - (to-element '#:prefab) - (to-element '#:transparent)) - (schemeparenfont ")")))) - 'cont - 'cont))] - [else null])))))))) + (let loop ([fields (if (null? fields) + fields (cdr fields))]) + (if (null? fields) + null + (cons + (let ([fld (car fields)]) + (list flow-spacer flow-spacer + flow-spacer flow-spacer + (to-flow + (let ([e (to-element (field-view fld))]) + (if (null? (cdr fields)) + (make-element + #f + (list e (schemeparenfont + (if (and immutable? + (not transparent?) + (not cname-id)) + "))" + ")")))) + e))))) + (loop (cdr fields)))))) + (if cname-id + (list (a-right-column + (to-flow (make-element + #f + (append + (list (to-element (if extra-cname? + '#:extra-constructor-name + '#:constructor-name)) + (hspace 1) + (to-element cname-id)) + (if (and immutable? + (not transparent?)) + (list (schemeparenfont ")")) + null)))))) + null) + (cond + [(and (not immutable?) transparent?) + (list + (a-right-column (to-flow (to-element '#:mutable))) + (a-right-column (to-flow (make-element + #f + (list (if prefab? + (to-element '#:prefab) + (to-element '#:transparent)) + (schemeparenfont ")"))))))] + [(not immutable?) + (list + (a-right-column (to-flow (make-element + #f + (list (to-element '#:mutable) + (schemeparenfont ")"))))))] + [transparent? + (list + (a-right-column (to-flow (make-element + #f + (list (if prefab? + (to-element '#:prefab) + (to-element '#:transparent)) + (schemeparenfont ")"))))))] + [else null]))))))))) (map (lambda (v field-contract) (cond [(pair? v) @@ -688,7 +753,10 @@ flow-spacer (make-flow (list (field-contract))))))))] [else null])) - fields field-contracts))) + fields field-contracts)))) + (make-box-splice + (cons + main-table (content-thunk)))) ;; ---------------------------------------- @@ -709,49 +777,87 @@ (list (schemeblock0 result) ...) (lambda () (list desc ...))))) -(define (*defthing stx-ids names form? result-contracts content-thunk) +(define (*defthing stx-ids names form? result-contracts content-thunk + [result-values (map (lambda (x) #f) result-contracts)]) (make-box-splice (cons (make-table 'boxed (map - (lambda (stx-id name result-contract) + (lambda (stx-id name result-contract result-value) (list (make-flow (make-table-if-necessary "argcontract" - (list + (let* ([result-block + (and result-value + (if (block? result-value) + result-value + (make-omitable-paragraph (list result-value))))] + [contract-block + (if (block? result-contract) + result-contract + (make-omitable-paragraph (list result-contract)))] + [total-width (+ (string-length (format "~a" name)) + 3 + (block-width contract-block) + (if result-block + (+ (block-width result-block) 3) + 0))]) + (append (list - (make-flow + (append (list - (make-omitable-paragraph + (make-flow (list - (let ([target-maker - ((if form? id-to-form-target-maker id-to-target-maker) - stx-id #t)] - [content (list (definition-site name stx-id form?))]) - (if target-maker - (target-maker - content - (lambda (tag) - (make-toc-target-element - #f - (list - (make-index-element - #f - content - tag - (list (symbol->string name)) - content - (with-exporting-libraries - (lambda (libs) (make-thing-index-desc name libs))))) - tag))) - (car content))) - spacer ":" spacer)))) - (make-flow (list (if (block? result-contract) - result-contract - (make-omitable-paragraph (list result-contract))))))))))) - stx-ids names result-contracts)) + (make-omitable-paragraph + (list + (let ([target-maker + ((if form? id-to-form-target-maker id-to-target-maker) + stx-id #t)] + [content (list (definition-site name stx-id form?))]) + (if target-maker + (target-maker + content + (lambda (tag) + (make-toc-target-element + #f + (list + (make-index-element + #f + content + tag + (list (symbol->string name)) + content + (with-exporting-libraries + (lambda (libs) (make-thing-index-desc name libs))))) + tag))) + (car content))))))) + (make-flow + (list + (make-omitable-paragraph + (list + spacer ":" spacer)))) + (make-flow (list contract-block))) + (if (and result-value + (total-width . < . 60)) + (list + (to-flow (make-element #f (list spacer "=" spacer))) + (make-flow (list result-block))) + null))) + (if (and result-value + (total-width . >= . 60)) + (list + (list + (make-table-if-necessary + "argcontract" + (list + (list flow-spacer + (to-flow (make-element #f (list spacer "=" spacer))) + (make-flow (list result-block))))) + 'cont)) + null))))))) + stx-ids names result-contracts result-values)) (content-thunk)))) (define (defthing/proc id contract descs) diff --git a/collects/scribble/private/manual-vars.ss b/collects/scribble/private/manual-vars.ss index 40e429366b..8ab617b8a3 100644 --- a/collects/scribble/private/manual-vars.ss +++ b/collects/scribble/private/manual-vars.ss @@ -14,7 +14,7 @@ (provide/contract [struct (box-splice splice) ([run list?])]) ; XXX ugly copying -(provide deftogether +(provide deftogether *deftogether with-scheme-variables with-togetherable-scheme-variables) @@ -109,7 +109,7 @@ (define (*deftogether boxes body-thunk) - (make-splice + (make-box-splice (cons (make-table 'boxed diff --git a/collects/scribble/run.ss b/collects/scribble/run.ss index e5d35d32a4..828cffaf52 100644 --- a/collects/scribble/run.ss +++ b/collects/scribble/run.ss @@ -34,12 +34,14 @@ (let ([v (read i)]) (and (eof-object? (read i)) v))))) +(current-render-mixin html:render-mixin) + (define (run) (command-line #:program (short-program+command-name) #:once-any [("--text") "generate text-format output (the default)" - (void)] + (current-render-mixin text:render-mixin)] [("--html") "generate HTML-format output file" (current-render-mixin html:render-mixin)] [("--htmls") "generate HTML-format output directory" diff --git a/collects/scribblings/reference/define-struct.scrbl b/collects/scribblings/reference/define-struct.scrbl index 408b26aa13..54e54c03e7 100644 --- a/collects/scribblings/reference/define-struct.scrbl +++ b/collects/scribblings/reference/define-struct.scrbl @@ -6,9 +6,9 @@ @(define posn-eval (make-base-eval)) @(interaction-eval #:eval posn-eval (require (for-syntax racket/base))) -@title[#:tag "define-struct"]{Defining Structure Types: @scheme[struct]} +@title[#:tag "define-struct"]{Defining Structure Types: @racket[struct]} -@guideintro["define-struct"]{@scheme[define-struct]} +@guideintro["define-struct"]{@racket[define-struct]} @defform/subs[(struct id maybe-super (field ...) struct-option ...) @@ -25,124 +25,138 @@ (code:line #:transparent) (code:line #:prefab) (code:line #:constructor-name constructor-id) + (code:line #:extra-constructor-name constructor-id) #:omit-define-syntaxes #:omit-define-values] [field-option #:mutable #:auto])]{ Creates a new @techlink{structure type} (or uses a pre-existing -structure type if @scheme[#:prefab] is specified), and binds +structure type if @racket[#:prefab] is specified), and binds transformers and variables related to the @tech{structure type}. -A @scheme[struct] form with @math{n} @scheme[field]s defines up +A @racket[struct] form with @math{n} @racket[field]s defines up to @math{4+2n} names: @itemize[ - @item{@schemeidfont{struct:}@scheme[id], a @deftech{structure type + @item{@racketidfont{struct:}@racket[id], a @deftech{structure type descriptor} value that represents the @tech{structure type}.} - @item{@scheme[constructor-id] (which defaults to @scheme[id]), a + @item{@racket[constructor-id] (which defaults to @racket[id]), a @deftech{constructor} procedure that takes @math{m} arguments and returns a new instance of the @tech{structure type}, where - @math{m} is the number of @scheme[field]s that do not include - an @scheme[#:auto] option.} + @math{m} is the number of @racket[field]s that do not include + an @racket[#:auto] option.} - @item{@scheme[id]@schemeidfont{?}, a @deftech{predicate} procedure - that returns @scheme[#t] for instances of the @tech{structure - type} (constructed by @scheme[constructor-id] or the - @tech{constructor} for a subtype) and @scheme[#f] for any other + @item{@racket[id]@racketidfont{?}, a @deftech{predicate} procedure + that returns @racket[#t] for instances of the @tech{structure + type} (constructed by @racket[constructor-id] or the + @tech{constructor} for a subtype) and @racket[#f] for any other value.} - @item{@scheme[id]@schemeidfont{-}@scheme[field-id], for each - @scheme[field]; an @deftech{accessor} procedure that takes an + @item{@racket[id]@racketidfont{-}@racket[field-id], for each + @racket[field]; an @deftech{accessor} procedure that takes an instance of the @tech{structure type} and extracts the value for the corresponding field.} - @item{@schemeidfont{set-}@scheme[id]@schemeidfont{-}@scheme[field-id]@schemeidfont{!}, - for each @scheme[field] that includes a - @scheme[#:mutable] option, or when the - @scheme[#:mutable] option is specified as a - @scheme[struct-option]; a @deftech{mutator} procedure that + @item{@racketidfont{set-}@racket[id]@racketidfont{-}@racket[field-id]@racketidfont{!}, + for each @racket[field] that includes a + @racket[#:mutable] option, or when the + @racket[#:mutable] option is specified as a + @racket[struct-option]; a @deftech{mutator} procedure that takes an instance of the @tech{structure type} and a new field value. The structure is destructively updated with the new value, and @|void-const| is returned.} - @item{@scheme[id], a @tech{transformer binding} that encapsulates + @item{@racket[id], a @tech{transformer binding} that encapsulates information about the structure type declaration. This binding is used to define subtypes, and it also works with the - @scheme[shared] and @scheme[match] forms. For detailed - information about the binding of @scheme[id], see + @racket[shared] and @racket[match] forms. For detailed + information about the binding of @racket[id], see @secref["structinfo"]. - The @scheme[constructor-id] and @scheme[id] can be the same, in - which case @scheme[id] performs both roles.} + The @racket[constructor-id] and @racket[id] can be the same, in + which case @racket[id] performs both roles.} ] -If @scheme[super-id] is provided, it must have a transformer binding -of the same sort bound to @scheme[id] (see @secref["structinfo"]), +If @racket[super-id] is provided, it must have a transformer binding +of the same sort bound to @racket[id] (see @secref["structinfo"]), and it specifies a supertype for the structure type. Alternately, -the @scheme[#:super] option can be used to specify an expression that +the @racket[#:super] option can be used to specify an expression that must produce a @tech{structure type descriptor}. See @secref["structures"] for more information on structure subtypes -and supertypes. If both @scheme[super-id] and @scheme[#:super] are +and supertypes. If both @racket[super-id] and @racket[#:super] are provided, a syntax error is reported. -If the @scheme[#:mutable] option is specified for an individual +If the @racket[#:mutable] option is specified for an individual field, then the field can be mutated in instances of the structure type, and a @tech{mutator} procedure is bound. Supplying -@scheme[#:mutable] as a @scheme[struct-option] is the same as -supplying it for all @scheme[field]s. If @scheme[#:mutable] is -specified as both a @scheme[field-option] and @scheme[struct-option], +@racket[#:mutable] as a @racket[struct-option] is the same as +supplying it for all @racket[field]s. If @racket[#:mutable] is +specified as both a @racket[field-option] and @racket[struct-option], a syntax error is reported. -The @scheme[#:inspector], @scheme[#:auto-value], and @scheme[#:guard] +The @racket[#:inspector], @racket[#:auto-value], and @racket[#:guard] options specify an inspector, value for automatic fields, and guard -procedure, respectively. See @scheme[make-struct-type] for more +procedure, respectively. See @racket[make-struct-type] for more information on these attributes of a structure type. The -@scheme[#:property] option, which is the only one that can be supplied +@racket[#:property] option, which is the only one that can be supplied multiple times, attaches a property value to the structure type; see @secref["structprops"] for more information on properties. The -@scheme[#:transparent] option is a shorthand for @scheme[#:inspector +@racket[#:transparent] option is a shorthand for @racket[#:inspector #f]. -@margin-note{Use the @scheme[prop:procedure] to property implement an -@as-index{applicable structure}, use @scheme[prop:evt] to create a +@margin-note{Use the @racket[prop:procedure] to property implement an +@as-index{applicable structure}, use @racket[prop:evt] to create a structure type whose instances are @tech{synchronizable events}, and -so on. By convention, property names start with @schemeidfont{prop:}.} +so on. By convention, property names start with @racketidfont{prop:}.} -The @scheme[#:prefab] option obtains a @techlink{prefab} (pre-defined, +The @racket[#:prefab] option obtains a @techlink{prefab} (pre-defined, globally shared) structure type, as opposed to creating a new structure type. Such a structure type is inherently transparent and -cannot have a guard or properties, so using @scheme[#:prefab] with -@scheme[#:transparent], @scheme[#:inspector], @scheme[#:guard], or -@scheme[#:property] is a syntax error. If a supertype is specified, it +cannot have a guard or properties, so using @racket[#:prefab] with +@racket[#:transparent], @racket[#:inspector], @racket[#:guard], or +@racket[#:property] is a syntax error. If a supertype is specified, it must also be a @tech{prefab} structure type. -If the @scheme[#:omit-define-syntaxes] option is supplied, then -@scheme[id] is not bound as a transformer. If the -@scheme[#:omit-define-values] option is supplied, then none of the -usual variables are bound, but @scheme[id] is bound. If both are -supplied, then the @scheme[struct] form is equivalent to -@scheme[(begin)]. +If @racket[constructor-id] is supplied then the @tech{transformer +binding} of @scheme[id] records @scheme[constructor-id] as the +constructor binding; as a result, for example, @scheme[struct-out] +includes @racket[constructor-id] as an export. If +@racket[constructor-id] is supplied via +@racket[#:extra-constructor-name] and it is not @racket[id], Applying +@racket[object-name] on the constructor produces the symbolic form of +@racket[id] rather than @racket[constructor-id]. If +@racket[constructor-id] is supplied via @racket[#:constructor-name] +and it is not the same as @racket[id], then @racket[id] does not serve +as a constructor, and @racket[object-name] on the constructor produces +the symbolic form of @racket[constructor-id]. -If @scheme[#:auto] is supplied as a @scheme[field-option], then the +If the @racket[#:omit-define-syntaxes] option is supplied, then +@racket[id] is not bound as a transformer. If the +@racket[#:omit-define-values] option is supplied, then none of the +usual variables are bound, but @racket[id] is bound. If both are +supplied, then the @racket[struct] form is equivalent to +@racket[(begin)]. + +If @racket[#:auto] is supplied as a @racket[field-option], then the @tech{constructor} procedure for the structure type does not accept an argument corresponding to the field. Instead, the structure type's automatic value is used for the field, as specified by the -@scheme[#:auto-value] option, or as defaults to @scheme[#f] when -@scheme[#:auto-value] is not supplied. The field is mutable (e.g., +@racket[#:auto-value] option, or as defaults to @racket[#f] when +@racket[#:auto-value] is not supplied. The field is mutable (e.g., through reflective operations), but a mutator procedure is bound only -if @scheme[#:mutable] is specified. +if @racket[#:mutable] is specified. -If a @scheme[field] includes the @scheme[#:auto] option, then all -fields after it must also include @scheme[#:auto], otherwise a syntax -error is reported. If any @scheme[field-option] or -@scheme[struct-option] keyword is repeated, other than -@scheme[#:property], a syntax error is reported. +If a @racket[field] includes the @racket[#:auto] option, then all +fields after it must also include @racket[#:auto], otherwise a syntax +error is reported. If any @racket[field-option] or +@racket[struct-option] keyword is repeated, other than +@racket[#:property], a syntax error is reported. -For serialization, see @scheme[define-serializable-struct]. +For serialization, see @racket[define-serializable-struct]. @defexamples[ #:eval posn-eval @@ -167,12 +181,12 @@ cp @defform[(struct-field-index field-id)]{ This form can only appear as an expression within a -@scheme[struct] form; normally, it is used with -@scheme[#:property], especially for a property like -@scheme[prop:procedure]. The result of a @scheme[struct-field-index] +@racket[struct] form; normally, it is used with +@racket[#:property], especially for a property like +@racket[prop:procedure]. The result of a @racket[struct-field-index] expression is an exact, non-negative integer that corresponds to the position within the structure declaration of the field named by -@scheme[field-id]. +@racket[field-id]. @defexamples[ #:eval posn-eval @@ -189,11 +203,12 @@ position within the structure declaration of the field named by ([id-maybe-super id (id super-id)])]{ -Like @scheme[struct], except that the syntax for supplying a -@scheme[super-id] is different, and the default constructor name -use a @schemeidfont{make-} prefix on @scheme[id]. +Like @racket[struct], except that the syntax for supplying a +@racket[super-id] is different, and a @racket[_constructor-id] that is +a @racketidfont{make-} prefix on @racket[id] is implicitly supplied +via @racket[#:extra-constructor-name]. -This form is provided for backward compatibility; @scheme[struct] is +This form is provided for backward compatibility; @racket[struct] is preferred. @defexamples[ @@ -210,11 +225,11 @@ preferred. @defform[(define-struct/derived (id . rest-form) id-maybe-super (field ...) struct-option ...)]{ -Like @scheme[define-struct], but intended for use by macros that -expand to @scheme[define-struct]. The form immediately after -@scheme[define-struct/derived] is used for all syntax-error reporting, +Like @racket[define-struct], but intended for use by macros that +expand to @racket[define-struct]. The form immediately after +@racket[define-struct/derived] is used for all syntax-error reporting, and the only constraint on the form is that it starts with some -@scheme[id]. +@racket[id]. @defexamples[ #:eval posn-eval diff --git a/collects/scribblings/reference/units.scrbl b/collects/scribblings/reference/units.scrbl index c20c0ac3c9..1d2ae8d39f 100644 --- a/collects/scribblings/reference/units.scrbl +++ b/collects/scribblings/reference/units.scrbl @@ -172,7 +172,9 @@ the corresponding import. Each @scheme[tagged-sig-id] in an [field id [id #:mutable]] - [srtuct-option #:mutable + [struct-option #:mutable + (code:line #:constructor-name constructor-id) + (code:line #:extra-constructor-name constructor-id) #:omit-constructor #:omit-define-syntaxes #:omit-define-values])]{ @@ -222,7 +224,7 @@ of bindings for import or export: @item{Each @scheme[(struct id (field ...) struct-option ...)] adds all of the identifiers that would be bound by @scheme[(struct id (field ...) field-option ...)], where the extra option - @scheme[#:omit-constructor] omits the @scheme[id] identifier.} + @scheme[#:omit-constructor] omits the constructor identifier.} @item{Each @scheme[(sig-form-id . datum)] extends the signature in a way that is defined by @scheme[sig-form-id], which must be bound by diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl index 8736312ca5..3aac8d62e9 100644 --- a/collects/scribblings/scribble/manual.scrbl +++ b/collects/scribblings/scribble/manual.scrbl @@ -617,19 +617,28 @@ Like @scheme[defparam], but the contract on a parameter argument is Like @scheme[defproc], but for a non-procedure binding.} - -@defform/subs[(defstruct struct-name ([field-name contract-expr-datum] ...) - flag-keywords - pre-flow ...) - ([struct-name id - (id super-id)] - [flag-keywords code:blank - #:mutable - (code:line #:inspector #f) - (code:line #:mutable #:inspector #f)])]{ +@deftogether[( +@defform[ (defstruct* struct-name ([field-name contract-expr-datum] ...) + maybe-mutable maybe-non-opaque maybe-constructor + pre-flow ...)] +@defform/subs[ (defstruct struct-name ([field-name contract-expr-datum] ...) + maybe-mutable maybe-non-opaque maybe-constructor + pre-flow ...) + ([struct-name id + (id super-id)] + [maybe-mutable code:blank + #:mutable] + [maybe-non-opaque code:blank + #:prefab + #:transparent] + [maybe-constructor code:blank + (code:line #:constructor-name constructor-id) + (code:line #:extra-constructor-name constructor-id)])] +)]{ Similar to @scheme[defform] or @scheme[defproc], but for a structure -definition.} +definition. The @scheme[defstruct*] form corresponds to @scheme[struct], +while @scheme[defstruct] corresponds to @scheme[define-struct].} @defform[(deftogether [def-expr ...] pre-flow ...)]{ diff --git a/collects/scribblings/scribble/utils.ss b/collects/scribblings/scribble/utils.ss index 02d7857958..c0c9ac31a1 100644 --- a/collects/scribblings/scribble/utils.ss +++ b/collects/scribblings/scribble/utils.ss @@ -1,9 +1,9 @@ -#lang scheme/base +#lang racket/base (require scribble/core scribble/html-properties scribble/manual - (prefix-in scheme: scribble/scheme) + (prefix-in racket: scribble/racket) (prefix-in scribble: scribble/reader)) (define-syntax bounce-for-label @@ -15,12 +15,12 @@ (provide (for-label (all-from-out mod))))] [(_ mod ...) (begin (bounce-for-label mod) ...)])) -(bounce-for-label (all-except scheme (link) ()) +(bounce-for-label (all-except racket (link) ()) scribble/core scribble/base-render scribble/decode scribble/manual - scribble/scheme + scribble/racket scribble/html-properties scribble/latex-properties scribble/eval @@ -94,7 +94,7 @@ (map (lambda (x) (let ([@expr (if x (litchar/lines (car x)) "")] [sexpr (if x - (scheme:to-paragraph + (racket:to-paragraph ((norm-spacing 0) (cadr x))) "")] [reads-as (if x reads-as "")]) @@ -103,7 +103,7 @@ ;; stuff for the preprocessor examples -(require scheme/list (for-syntax scheme/base scheme/list)) +(require racket/list (for-syntax racket/base racket/list)) (define max-textsample-width 45) diff --git a/collects/syntax/struct.ss b/collects/syntax/struct.ss index 10d8875764..440da1bcfd 100644 --- a/collects/syntax/struct.ss +++ b/collects/syntax/struct.ss @@ -106,9 +106,7 @@ (list (+ "struct:" name) (if ctr-name - (if (pair? ctr-name) - (cdr ctr-name) - ctr-name) + ctr-name (+ "make-" name)) (+ name "?")) (let loop ([l fields]) @@ -341,5 +339,5 @@ [build-struct-names (->* (identifier? (listof identifier?) boolean? boolean?) ((or/c #f syntax?) - #:constructor-name (or/c #f identifier? (cons/c identifier? identifier?))) + #:constructor-name (or/c #f identifier?)) (listof identifier?))])) diff --git a/collects/tests/mzscheme/name.ss b/collects/tests/mzscheme/name.ss index 343022ac83..20b333199b 100644 --- a/collects/tests/mzscheme/name.ss +++ b/collects/tests/mzscheme/name.ss @@ -100,7 +100,7 @@ (test (string->symbol "Capital") object-name (eval (read (open-input-string "(let ([Capital (lambda () 10)]) Capital)")))) - (test (string->symbol "make-CP") + (test (string->symbol "CP") object-name (eval (read (open-input-string "(let () (define-struct CP (a)) make-CP)"))))) diff --git a/collects/tests/mzscheme/namespac.ss b/collects/tests/mzscheme/namespac.ss index 595773621c..e75ead5866 100644 --- a/collects/tests/mzscheme/namespac.ss +++ b/collects/tests/mzscheme/namespac.ss @@ -32,9 +32,34 @@ (cons s (with-handlers ([exn:fail? (lambda (x) #f)]) (namespace-variable-value s)))) (namespace-mapped-symbols)))] - [aliases (list (cons "call/cc" "call-with-current-continuation") - (cons "call/ec" "call-with-escape-continuation") - (cons "interaction-environment" "current-namespace"))]) + [aliases (let ([mkp (lambda (s) + (cons (string-append "make-" s) s))]) + (list (cons "call/cc" "call-with-current-continuation") + (cons "call/ec" "call-with-escape-continuation") + (cons "interaction-environment" "current-namespace") + (mkp "arity-at-least") + (mkp "srcloc") + (mkp "date") + (mkp "exn") + (mkp "exn:fail") + (mkp "exn:fail:contract") + (mkp "exn:fail:contract:arity") + (mkp "exn:fail:contract:divide-by-zero") + (mkp "exn:fail:contract:non-fixnum-result") + (mkp "exn:fail:contract:continuation") + (mkp "exn:fail:contract:variable") + (mkp "exn:fail:syntax") + (mkp "exn:fail:read") + (mkp "exn:fail:read:eof") + (mkp "exn:fail:read:non-char") + (mkp "exn:fail:filesystem") + (mkp "exn:fail:filesystem:exists") + (mkp "exn:fail:filesystem:version") + (mkp "exn:fail:network") + (mkp "exn:fail:out-of-memory") + (mkp "exn:fail:unsupported") + (mkp "exn:fail:user") + (mkp "exn:break")))]) (test #t 'names (andmap (lambda (nv-pair) diff --git a/collects/tests/mzscheme/unit.ss b/collects/tests/mzscheme/unit.ss index 27693082fd..fce48778fd 100644 --- a/collects/tests/mzscheme/unit.ss +++ b/collects/tests/mzscheme/unit.ss @@ -231,7 +231,7 @@ (export))) (test (string-append "(5 # # (proc: y)" - " (proc: make-x) (proc: x?)" + " (proc: x) (proc: x?)" " (proc: x-z) (proc: both))" "(5 #t # #t #f # #t #t #f #t)") get-output-string p)) diff --git a/collects/tests/mzscheme/unitsig.ss b/collects/tests/mzscheme/unitsig.ss index 57b35390db..faf879e34a 100644 --- a/collects/tests/mzscheme/unitsig.ss +++ b/collects/tests/mzscheme/unitsig.ss @@ -334,7 +334,7 @@ M@)]) (export))) (test (string-append "(5 #(struct:a 5 6) # (proc: y)" - " (proc: make-x) (proc: x?)" + " (proc: x) (proc: x?)" " (proc: x-z) (proc: both) (proc: a?))" "(5 #t #(struct:a 5 6) #t #f #(struct:x 1 2 ...) #t #t #f #t)") get-output-string p))) diff --git a/src/racket/src/cstartup.inc b/src/racket/src/cstartup.inc index 8907f6b94c..8a029f775d 100644 --- a/src/racket/src/cstartup.inc +++ b/src/racket/src/cstartup.inc @@ -1,44 +1,44 @@ { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,52,46,50,46,53,46,49,49,51,0,0,0,1,0,0,10,0,13, -0,22,0,29,0,42,0,46,0,53,0,57,0,62,0,65,0,70,0,75,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,52,46,50,46,53,46,49,50,51,0,0,0,1,0,0,10,0,13, +0,22,0,29,0,33,0,46,0,53,0,57,0,62,0,65,0,70,0,75,0, 82,0,88,0,102,0,116,0,119,0,125,0,129,0,131,0,142,0,144,0,158, 0,165,0,187,0,189,0,203,0,14,1,43,1,54,1,65,1,75,1,111,1, 144,1,177,1,236,1,46,2,124,2,190,2,195,2,215,2,106,3,126,3,177, 3,243,3,128,4,14,5,66,5,89,5,168,5,0,0,109,7,0,0,69,35, 37,109,105,110,45,115,116,120,29,11,11,68,104,101,114,101,45,115,116,120,66, -108,101,116,114,101,99,72,112,97,114,97,109,101,116,101,114,105,122,101,63,108, -101,116,66,100,101,102,105,110,101,63,97,110,100,64,108,101,116,42,62,111,114, +108,101,116,114,101,99,63,108,101,116,72,112,97,114,97,109,101,116,101,114,105, +122,101,66,100,101,102,105,110,101,63,97,110,100,64,108,101,116,42,62,111,114, 64,119,104,101,110,64,99,111,110,100,66,117,110,108,101,115,115,65,113,117,111, 116,101,29,94,2,14,68,35,37,107,101,114,110,101,108,11,29,94,2,14,68, 35,37,112,97,114,97,109,122,11,62,105,102,65,98,101,103,105,110,63,115,116, 120,61,115,70,108,101,116,45,118,97,108,117,101,115,61,120,73,108,101,116,114, 101,99,45,118,97,108,117,101,115,66,108,97,109,98,100,97,1,20,112,97,114, 97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,61,118,73,100, -101,102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,240,155,78,0,0, +101,102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,240,225,78,0,0, 95,159,2,16,36,36,159,2,15,36,36,159,2,15,36,36,16,20,2,5,2, 2,2,6,2,2,2,7,2,2,2,8,2,2,2,10,2,2,2,9,2,2, 2,4,2,2,2,11,2,2,2,12,2,2,2,13,2,2,97,37,11,8,240, -155,78,0,0,93,159,2,15,36,37,16,2,2,3,161,2,2,37,2,3,2, -2,2,3,96,11,11,8,240,155,78,0,0,16,0,96,38,11,8,240,155,78, +225,78,0,0,93,159,2,15,36,37,16,2,2,3,161,2,2,37,2,3,2, +2,2,3,96,11,11,8,240,225,78,0,0,16,0,96,38,11,8,240,225,78, 0,0,16,0,13,16,4,36,29,11,11,2,2,11,18,16,2,99,64,104,101, -114,101,8,32,8,31,8,30,8,29,8,28,93,8,224,162,78,0,0,95,9, -8,224,162,78,0,0,2,2,27,248,22,147,4,195,249,22,140,4,80,158,39, +114,101,8,32,8,31,8,30,8,29,8,28,93,8,224,232,78,0,0,95,9, +8,224,232,78,0,0,2,2,27,248,22,147,4,195,249,22,140,4,80,158,39, 36,251,22,81,2,17,248,22,96,199,12,249,22,71,2,18,248,22,98,201,27, 248,22,147,4,195,249,22,140,4,80,158,39,36,251,22,81,2,17,248,22,96, 199,249,22,71,2,18,248,22,98,201,12,27,248,22,73,248,22,147,4,196,28, 248,22,79,193,20,15,159,37,36,37,28,248,22,79,248,22,73,194,248,22,72, 193,249,22,140,4,80,158,39,36,251,22,81,2,17,248,22,72,199,249,22,71, 2,8,248,22,73,201,11,18,16,2,101,10,8,32,8,31,8,30,8,29,8, -28,16,4,11,11,2,19,3,1,8,101,110,118,49,50,54,48,50,16,4,11, -11,2,20,3,1,8,101,110,118,49,50,54,48,51,93,8,224,163,78,0,0, -95,9,8,224,163,78,0,0,2,2,27,248,22,73,248,22,147,4,196,28,248, +28,16,4,11,11,2,19,3,1,8,101,110,118,49,50,54,53,50,16,4,11, +11,2,20,3,1,8,101,110,118,49,50,54,53,51,93,8,224,233,78,0,0, +95,9,8,224,233,78,0,0,2,2,27,248,22,73,248,22,147,4,196,28,248, 22,79,193,20,15,159,37,36,37,28,248,22,79,248,22,73,194,248,22,72,193, 249,22,140,4,80,158,39,36,250,22,81,2,21,248,22,81,249,22,81,248,22, 81,2,22,248,22,72,201,251,22,81,2,17,2,22,2,22,249,22,71,2,10, 248,22,73,204,18,16,2,101,11,8,32,8,31,8,30,8,29,8,28,16,4, -11,11,2,19,3,1,8,101,110,118,49,50,54,48,53,16,4,11,11,2,20, -3,1,8,101,110,118,49,50,54,48,54,93,8,224,164,78,0,0,95,9,8, -224,164,78,0,0,2,2,248,22,147,4,193,27,248,22,147,4,194,249,22,71, +11,11,2,19,3,1,8,101,110,118,49,50,54,53,53,16,4,11,11,2,20, +3,1,8,101,110,118,49,50,54,53,54,93,8,224,234,78,0,0,95,9,8, +224,234,78,0,0,2,2,248,22,147,4,193,27,248,22,147,4,194,249,22,71, 248,22,81,248,22,72,196,248,22,73,195,27,248,22,73,248,22,147,4,23,197, 1,249,22,140,4,80,158,39,36,28,248,22,56,248,22,141,4,248,22,72,23, 198,2,27,249,22,2,32,0,89,162,8,44,37,43,9,222,33,40,248,22,147, @@ -52,7 +52,7 @@ 44,37,47,9,222,33,43,248,22,147,4,248,22,72,201,248,22,73,198,27,248, 22,73,248,22,147,4,196,27,248,22,147,4,248,22,72,195,249,22,140,4,80, 158,40,36,28,248,22,79,195,250,22,82,2,21,9,248,22,73,199,250,22,81, -2,6,248,22,81,248,22,72,199,250,22,82,2,9,248,22,73,201,248,22,73, +2,5,248,22,81,248,22,72,199,250,22,82,2,9,248,22,73,201,248,22,73, 202,27,248,22,73,248,22,147,4,23,197,1,27,249,22,1,22,85,249,22,2, 22,147,4,248,22,147,4,248,22,72,199,249,22,140,4,80,158,40,36,251,22, 81,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,105,111,110,45, @@ -67,9 +67,9 @@ 2,26,248,22,73,202,251,22,81,2,17,28,249,22,181,8,248,22,141,4,248, 22,72,200,64,101,108,115,101,10,248,22,72,197,250,22,82,2,21,9,248,22, 73,200,249,22,71,2,12,248,22,73,202,100,8,32,8,31,8,30,8,29,8, -28,16,4,11,11,2,19,3,1,8,101,110,118,49,50,54,50,56,16,4,11, -11,2,20,3,1,8,101,110,118,49,50,54,50,57,93,8,224,165,78,0,0, -18,16,2,158,94,10,64,118,111,105,100,8,48,95,9,8,224,165,78,0,0, +28,16,4,11,11,2,19,3,1,8,101,110,118,49,50,54,55,56,16,4,11, +11,2,20,3,1,8,101,110,118,49,50,54,55,57,93,8,224,235,78,0,0, +18,16,2,158,94,10,64,118,111,105,100,8,48,95,9,8,224,235,78,0,0, 2,2,27,248,22,73,248,22,147,4,196,249,22,140,4,80,158,39,36,28,248, 22,56,248,22,141,4,248,22,72,197,250,22,81,2,27,248,22,81,248,22,72, 199,248,22,96,198,27,248,22,141,4,248,22,72,197,250,22,81,2,27,248,22, @@ -87,11 +87,11 @@ 2,3,16,0,11,16,5,2,8,89,162,8,44,37,53,9,223,0,33,36,36, 20,105,159,36,16,1,2,3,16,1,33,37,11,16,5,2,10,89,162,8,44, 37,56,9,223,0,33,38,36,20,105,159,36,16,1,2,3,16,1,33,39,11, -16,5,2,6,89,162,8,44,37,58,9,223,0,33,42,36,20,105,159,36,16, +16,5,2,5,89,162,8,44,37,58,9,223,0,33,42,36,20,105,159,36,16, 1,2,3,16,0,11,16,5,2,4,89,162,8,44,37,53,9,223,0,33,44, 36,20,105,159,36,16,1,2,3,16,0,11,16,5,2,9,89,162,8,44,37, 54,9,223,0,33,45,36,20,105,159,36,16,1,2,3,16,0,11,16,5,2, -5,89,162,8,44,37,55,9,223,0,33,46,36,20,105,159,36,16,1,2,3, +6,89,162,8,44,37,55,9,223,0,33,46,36,20,105,159,36,16,1,2,3, 16,0,11,16,5,2,12,89,162,8,44,37,58,9,223,0,33,47,36,20,105, 159,36,16,1,2,3,16,1,33,49,11,16,5,2,7,89,162,8,44,37,54, 9,223,0,33,50,36,20,105,159,36,16,1,2,3,16,0,11,16,0,94,2, @@ -99,7 +99,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 2025); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,52,46,50,46,53,46,49,49,65,0,0,0,1,0,0,8,0,21, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,52,46,50,46,53,46,49,50,65,0,0,0,1,0,0,8,0,21, 0,26,0,43,0,58,0,76,0,92,0,102,0,120,0,140,0,156,0,174,0, 205,0,234,0,0,1,14,1,20,1,34,1,39,1,49,1,57,1,85,1,117, 1,123,1,168,1,213,1,237,1,20,2,22,2,188,2,22,4,63,4,136,5, @@ -400,13 +400,13 @@ EVAL_ONE_SIZED_STR((char *)expr, 6246); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,52,46,50,46,53,46,49,49,9,0,0,0,1,0,0,10,0,16, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,52,46,50,46,53,46,49,50,9,0,0,0,1,0,0,10,0,16, 0,29,0,44,0,58,0,72,0,86,0,128,0,0,0,57,1,0,0,69,35, 37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2,67,35,37, 117,116,105,108,115,11,29,94,2,2,69,35,37,110,101,116,119,111,114,107,11, 29,94,2,2,68,35,37,112,97,114,97,109,122,11,29,94,2,2,68,35,37, 101,120,112,111,98,115,11,29,94,2,2,68,35,37,107,101,114,110,101,108,11, -97,36,11,8,240,33,79,0,0,98,159,2,3,36,36,159,2,4,36,36,159, +97,36,11,8,240,103,79,0,0,98,159,2,3,36,36,159,2,4,36,36,159, 2,5,36,36,159,2,6,36,36,159,2,7,36,36,159,2,7,36,36,16,0, 159,36,20,105,159,36,16,1,11,16,0,83,158,42,20,103,145,2,1,2,1, 29,11,11,11,11,11,18,96,11,44,44,44,36,80,158,36,36,20,105,159,36, @@ -420,7 +420,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 353); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,52,46,50,46,53,46,49,49,74,0,0,0,1,0,0,7,0,18, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,52,46,50,46,53,46,49,50,74,0,0,0,1,0,0,7,0,18, 0,45,0,51,0,64,0,73,0,80,0,102,0,124,0,150,0,162,0,180,0, 200,0,212,0,228,0,251,0,7,1,38,1,45,1,50,1,55,1,60,1,65, 1,70,1,79,1,84,1,88,1,94,1,101,1,107,1,115,1,124,1,145,1, diff --git a/src/racket/src/error.c b/src/racket/src/error.c index 42427dcc75..6c5cbcf5d0 100644 --- a/src/racket/src/error.c +++ b/src/racket/src/error.c @@ -1372,16 +1372,10 @@ void scheme_wrong_field_type(Scheme_Object *c_name, Scheme_Object *o) { const char *s; - char *s2; - int l; Scheme_Object *a[1]; a[0] = o; s = scheme_symbol_name(c_name); - l = strlen(s); - s2 = (char *)scheme_malloc_atomic(l + 6); - memcpy(s2, "make-", 5); - memcpy(s2 + 5, s, l + 1); - scheme_wrong_type(s2, expected, -1, 0, a); + scheme_wrong_type(s, expected, -1, 0, a); } void scheme_arg_mismatch(const char *name, const char *msg, Scheme_Object *o) @@ -3467,7 +3461,7 @@ void scheme_init_exn(Scheme_Env *env) #define EXN_PARENT(id) exn_table[id].type -#define EXN_FLAGS SCHEME_STRUCT_EXPTIME | SCHEME_STRUCT_NO_SET +#define EXN_FLAGS (SCHEME_STRUCT_EXPTIME | SCHEME_STRUCT_NO_SET | SCHEME_STRUCT_NO_MAKE_PREFIX) #define SETUP_STRUCT(id, parent, name, argc, args, props, guard) \ { tmpo = scheme_make_struct_type_from_string(name, parent, argc, props, guard, 1); \ diff --git a/src/racket/src/makeexn b/src/racket/src/makeexn index 2ab689797e..1d48f88410 100755 --- a/src/racket/src/makeexn +++ b/src/racket/src/makeexn @@ -175,7 +175,23 @@ Not an exception in the above sense: (#%require "define.rkt") (#%require (for-syntax "struct-info.rkt")) - (#%provide (all-defined)))) + (#%provide (all-defined)) + + (define-values-for-syntax (make-self-ctr-struct-info) + (letrec-values ([(struct: make- ? ref set!) + (make-struct-type 'self-ctor-struct-info struct:struct-info + 1 0 #f + (list (cons prop:procedure + (lambda (v stx) + (let-values ([(id) ((ref v 0))]) + (if (symbol? (syntax-e stx)) + id + (datum->syntax stx + (cons id (cdr (syntax-e stx))) + stx + stx)))))) + (current-inspector) #f '(0))]) + make-)))) (define (sss . args) (string->symbol (apply string-append (map (λ (x) (if (symbol? x) (symbol->string x) x)) args)))) @@ -185,17 +201,23 @@ Not an exception in the above sense: (define (gen-ds name-string fields parent) (let* ([name (sss name-string)] + [kern-name (sss "kernel:" name)] [sn (sss "struct:" name)] [mn (sss "make-" name)] [pn (sss name "?")] [fds `(list ,@(map (λ (x) `(quote-syntax ,x)) fields))] [fdsset! `'(,@(map (λ (x) #f) fields))] [prnt (if (non-parent parent) #t `(quote-syntax ,parent))]) - `(define-syntax ,name (make-struct-info (λ () (list (quote-syntax ,sn) - (quote-syntax ,mn) - (quote-syntax ,pn) - ,fds - ,fdsset! ,prnt)))))) + `(begin + (#%require (rename '#%kernel ,kern-name ,name)) + (define ,mn ,kern-name) + (define-syntax ,name (make-self-ctr-struct-info + (λ () (list (quote-syntax ,sn) + (quote-syntax ,mn) + (quote-syntax ,pn) + ,fds + ,fdsset! ,prnt)) + (λ () (quote-syntax ,kern-name))))))) (define (parent-sym x) (let ([parent (ex-parent x)]) diff --git a/src/racket/src/schminc.h b/src/racket/src/schminc.h index 9da6e8a4e5..a2b9d1a3aa 100644 --- a/src/racket/src/schminc.h +++ b/src/racket/src/schminc.h @@ -11,7 +11,7 @@ EXPECTED_PRIM_COUNT to the new value, and then USE_COMPILED_STARTUP can be set to 1 again. */ -#define USE_COMPILED_STARTUP 1 +#define USE_COMPILED_STARTUP 0 #define EXPECTED_PRIM_COUNT 992 #define EXPECTED_UNSAFE_COUNT 65 diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index 5362b8bb67..2945ec6635 100644 --- a/src/racket/src/schvers.h +++ b/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.2.5.11" +#define MZSCHEME_VERSION "4.2.5.12" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 2 #define MZSCHEME_VERSION_Z 5 -#define MZSCHEME_VERSION_W 11 +#define MZSCHEME_VERSION_W 12 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/racket/src/startup.inc b/src/racket/src/startup.inc index 267bdcd362..bd63fcff21 100644 --- a/src/racket/src/startup.inc +++ b/src/racket/src/startup.inc @@ -181,7 +181,7 @@ "(unless(path-string? s)" " (raise-type-error who \"path or valid-path string\" s))" "(unless(relative-path? s)" -"(raise(make-exn:fail:contract" +"(raise(exn:fail:contract" "(string->immutable-string" " (format \"~a: invalid relative path: ~s\" who s))" "(current-continuation-marks))))))" @@ -194,7 +194,7 @@ "(-check-collection 'collection-path collection collection-path)" "(-find-col 'collection-path(lambda(s)" "(raise" -"(make-exn:fail:filesystem s(current-continuation-marks))))" +"(exn:fail:filesystem s(current-continuation-marks))))" " collection collection-path)))" "(define-values(-find-col)" "(lambda(who fail collection collection-path)" diff --git a/src/racket/src/startup.ss b/src/racket/src/startup.ss index 42e8772fb0..307371469c 100644 --- a/src/racket/src/startup.ss +++ b/src/racket/src/startup.ss @@ -236,7 +236,7 @@ (unless (path-string? s) (raise-type-error who "path or valid-path string" s)) (unless (relative-path? s) - (raise (make-exn:fail:contract + (raise (exn:fail:contract (string->immutable-string (format "~a: invalid relative path: ~s" who s)) (current-continuation-marks)))))) @@ -251,7 +251,7 @@ (-check-collection 'collection-path collection collection-path) (-find-col 'collection-path (lambda (s) (raise - (make-exn:fail:filesystem s (current-continuation-marks)))) + (exn:fail:filesystem s (current-continuation-marks)))) collection collection-path))) (define-values (-find-col) diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index a049309c31..31026c2cc3 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -171,7 +171,7 @@ static Scheme_Object *make_prefab_key(Scheme_Struct_Type *type); #define icons scheme_make_pair #define _intern scheme_intern_symbol -#define BUILTIN_STRUCT_FLAGS SCHEME_STRUCT_NO_SET | SCHEME_STRUCT_EXPTIME +#define BUILTIN_STRUCT_FLAGS (SCHEME_STRUCT_NO_SET | SCHEME_STRUCT_EXPTIME | SCHEME_STRUCT_NO_MAKE_PREFIX) #define TYPE_NAME(base, blen) make_name("struct:", base, blen, "", NULL, 0, "", 1) #define CSTR_NAME(base, blen) make_name("", base, blen, "", NULL, 0, "", 1)