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

change 'define-struct' to bind the type name as a constructor, add an #:extra-constructor-name option, etc.

Browse Source
This commit is contained in:
Matthew Flatt 2010-04-25 12:10:36 -06:00
parent 1d9757df02
commit 616080c7c4
33 changed files with 1160 additions and 718 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/lang/private/teach.ss
View File

@ -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

312
collects/mzlib/unit.ss
View File

@ -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)

12
collects/racket/contract/private/provide.ss
View File

@ -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

34
collects/racket/private/define-struct.rkt
View File

@ -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

2
collects/racket/private/for.rkt
View File

@ -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)

698
collects/racket/private/kernstruct.rkt
View File

@ -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))))))

4
collects/racket/private/kw.rkt
View File

@ -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)]

4
collects/racket/private/misc.rkt
View File

@ -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)"

12
collects/racket/private/more-scheme.rkt
View File

@ -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)])

1
collects/racket/private/struct.rkt
View File

@ -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])

7
collects/racket/unit.rkt
View File

@ -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])))

5
collects/scribble/manual.ss
View File

@ -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))

18
collects/scribble/private/manual-form.ss
View File

@ -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)

386
collects/scribble/private/manual-proc.ss
View File

@ -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)

4
collects/scribble/private/manual-vars.ss
View File

@ -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

4
collects/scribble/run.ss
View File

@ -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"

157
collects/scribblings/reference/define-struct.scrbl
View File

@ -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

6
collects/scribblings/reference/units.scrbl
View File

@ -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

31
collects/scribblings/scribble/manual.scrbl
View File

@ -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 ...)]{

12
collects/scribblings/scribble/utils.ss
View File

@ -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)

6
collects/syntax/struct.ss
View File

@ -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?))]))

2
collects/tests/mzscheme/name.ss
View File

@ -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)")))))

31
collects/tests/mzscheme/namespac.ss
View File

@ -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)

2
collects/tests/mzscheme/unit.ss
View File

@ -231,7 +231,7 @@
(export)))
(test (string-append "(5 #<a> #<struct-type:a> (proc: y)"
" (proc: make-x) (proc: x?)"
" (proc: x) (proc: x?)"
" (proc: x-z) (proc: both))"
"(5 #t #<a> #t #f #<x> #t #t #f #t)")
get-output-string p))

2
collects/tests/mzscheme/unitsig.ss
View File

@ -334,7 +334,7 @@
M@)])
(export)))
(test (string-append "(5 #(struct:a 5 6) #<struct-type:a> (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)))

50
src/racket/src/cstartup.inc
View File

@ -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,

10
src/racket/src/error.c
View File

@ -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); \

34
src/racket/src/makeexn
View File

@ -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)])

2
src/racket/src/schminc.h
View File

@ -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

4
src/racket/src/schvers.h
View File

@ -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)

4
src/racket/src/startup.inc
View File

@ -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)"

4
src/racket/src/startup.ss
View File

@ -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)

2
src/racket/src/struct.c
View File

@ -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)