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

Catch up to now.

Browse Source 
svn: r12742
This commit is contained in:
Stevie Strickland 2008-12-08 17:02:26 +00:00
commit dd5afccd82
50 changed files with 1000 additions and 517 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/compiler/cffi.scrbl
View File

@ -272,7 +272,6 @@ Expands to a use of @scheme[c-declare] with the content of
@scheme[path-spec]. The @scheme[path-spec] has the same form as for
@schememodname[mzlib/include]'s @scheme[include].}
@(bibliography
(bib-entry
#:key "Feeley98"

4
collects/compiler/zo-parse.ss
View File

@ -197,7 +197,9 @@
[`(,name ,self-modidx ,lang-info ,functional? ,et-functional?
,rename ,max-let-depth ,dummy
,prefix ,kernel-exclusion ,reprovide-kernel?
,indirect-provides ,num-indirect-provides ,protects
,indirect-provides ,num-indirect-provides
,indirect-et-provides ,num-indirect-et-provides
,protects ,et-protects
,provide-phase-count . ,rest)
(let ([phase-data (take rest (* 8 provide-phase-count))])
(match (list-tail rest (* 8 provide-phase-count))

17
collects/macro-debugger/model/reductions.ss
View File

@ -272,7 +272,7 @@
[#:pass1]
[Expr ?form first]
[#:do (when (pair? (available-lift-stxs))
(error 'lift-deriv "available lifts left over"))]
(lift-error 'lift-deriv "available lifts left over"))]
[#:let begin-stx (stx-car lifted-stx)]
[#:with-visible-form
;; If no lifts visible, then don't show begin-wrapping
@ -299,7 +299,7 @@
[#:pass1]
[Expr ?form first]
[#:do (when (pair? (available-lift-stxs))
(error 'lift/let-deriv "available lifts left over"))]
(lift-error 'lift/let-deriv "available lifts left over"))]
[#:let visible-lifts (visible-lift-stxs)]
[#:with-visible-form
[#:left-foot]
@ -388,7 +388,7 @@
[#:pass1]
[Expr ?form inner]
[#:do (when (pair? (available-lift-stxs))
(error 'local-expand/capture-lifts "available lifts left over"))]
(lift-error 'local-expand/capture-lifts "available lifts left over"))]
[#:let visible-lifts (visible-lift-stxs)]
[#:with-visible-form
[#:left-foot]
@ -402,7 +402,7 @@
[(struct local-lift (expr id))
;; FIXME: add action
(R [#:do (unless (pair? (available-lift-stxs))
(error 'local-lift "out of lifts!"))
(lift-error 'local-lift "out of lifts!"))
(when (pair? (available-lift-stxs))
(let ([lift-d (car (available-lift-stxs))]
[lift-stx (car (available-lift-stxs))])
@ -576,7 +576,7 @@
[#:pass1]
[Expr ?firstL head]
[#:do (when (pair? (available-lift-stxs))
(error 'mod:lift "available lifts left over"))]
(lift-error 'mod:lift "available lifts left over"))]
[#:let visible-lifts (visible-lift-stxs)]
[#:pattern ?forms]
[#:pass2]
@ -602,3 +602,10 @@
(R [#:pattern (?firstC . ?rest)]
[Expr ?firstC head]
[ModulePass ?rest rest])]))
;; lift-error
(define (lift-error sym . args)
(apply fprintf (current-error-port) args)
(when #t
(apply error sym args)))

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "3dec2008")
#lang scheme/base (provide stamp) (define stamp "8dec2008")

3
collects/scheme/private/class-internal.ss
View File

@ -1654,8 +1654,7 @@
;; Need to attach srcloc to this definition:
(syntax/loc stx
(define-syntaxes (id ...)
(values (make-private-name (quote-syntax id)
((syntax-local-certifier) (quote-syntax gen-id)))
(values (make-private-name (quote-syntax id) (quote-syntax gen-id))
...)))])
(syntax/loc stx
(begin

11
collects/scheme/private/define-struct.ss
View File

@ -424,20 +424,19 @@
(let ([protect (lambda (sel)
(and sel
(if (syntax-e sel)
#`(c (quote-syntax #,sel))
#`(quote-syntax #,sel)
sel)))]
[mk-info (if super-info-checked?
#'make-checked-struct-info
#'make-struct-info)])
(quasisyntax/loc stx
(define-syntaxes (#,id)
(let ([c (syntax-local-certifier)])
(#,mk-info
(lambda ()
(list
(c (quote-syntax #,struct:))
(c (quote-syntax #,make-))
(c (quote-syntax #,?))
(quote-syntax #,struct:)
(quote-syntax #,make-)
(quote-syntax #,?)
(list
#,@(map protect (reverse sels))
#,@(if super-info
@ -464,7 +463,7 @@
(protect super-id)
(if super-expr
#f
#t))))))))))])
#t)))))))))])
(let ([result
(cond
[(and (not omit-define-values?) (not omit-define-syntaxes?))

3
collects/scheme/private/for.ss
View File

@ -100,8 +100,7 @@
;; down to all the relevant identifiers and expressions:
(define (recert s) (syntax-recertify s src-stx (current-inspector) cert-key))
(define (cert s) (certifier (recert s) cert-key introducer))
(define (map-cert s) (map (lambda (s) (certifier (recert s) cert-key #;introducer))
(syntax->list s)))
(define (map-cert s) (map cert (syntax->list s)))
(syntax-case clause (:do-in)
[[(id ...) (:do-in ([(outer-id ...) outer-expr] ...)

7
collects/scheme/private/more-scheme.ss
View File

@ -168,6 +168,11 @@
(check-for-break)))
(define (select-handler/no-breaks e bpz l)
(with-continuation-mark
break-enabled-key
;; make a fresh thread cell so that the shared one isn't mutated
(make-thread-cell #f)
(let loop ([l l])
(cond
[(null? l)
(raise e)]
@ -179,7 +184,7 @@
bpz
(check-for-break)))]
[else
(select-handler/no-breaks e bpz (cdr l))]))
(loop (cdr l))]))))
(define (select-handler/breaks-as-is e bpz l)
(cond

2
collects/scribblings/guide/certificates.scrbl
View File

@ -170,7 +170,7 @@ be transferred from one syntax object to another. Such transfers are
allowed because a macro transformer with access to the syntax object
could already wrap it with an arbitrary context before activating the
certificates. In practice, transferring inactive certificates is
useful mainly to macros that implement to new template forms, such as
useful mainly to macros that implement new template forms, such as
@scheme[syntax/loc].
@;------------------------------------------------------------------------

19
collects/scribblings/reference/exns.scrbl
View File

@ -15,7 +15,7 @@ handler} for a primitive error is always an instance of the
@scheme[message] field that is a string, the primitive error message.
The default exception handler recognizes exception values with the
@scheme[exn?] predicate and passes the error message to the current
error display handler (see @scheme[error-display-handler]).
@tech{error display handler} (see @scheme[error-display-handler]).
Primitive procedures that accept a procedure argument with a
particular required arity (e.g., @scheme[call-with-input-file],
@ -80,7 +80,7 @@ In all cases, the constructed message string is passed to
Like @scheme[error], but constructs an exception with
@scheme[make-exn:fail:user] instead of @scheme[make-exn:fail]. The
default error display handler does not show a ``stack trace'' for
default @tech{error display handler} does not show a ``stack trace'' for
@scheme[exn:fail:user] exceptions (see @secref["contmarks"]), so
@scheme[raise-user-error] should be used for errors that are intended
for end users.}
@ -221,16 +221,16 @@ it returns, an exception is raised (to be handled by an exception
handler that reports both the original and newly raised exception).
The default uncaught-exception handler prints an error message using
the current error display handler (see @scheme[error-display-handler])
the current @tech{error display handler} (see @scheme[error-display-handler])
and then escapes by calling the current error escape handler (see
@scheme[error-escape-handler]). The call to each handler is
@scheme[parameterize]d to set @scheme[error-display-handler] to the
default error display handler, and it is @scheme[parameterize-break]ed
default @tech{error display handler}, and it is @scheme[parameterize-break]ed
to disable breaks. The call to the error escape handler is further
parameterized to set @scheme[error-escape-handler] to the default
error escape handler.
When the current error display handler is the default handler, then the
When the current @tech{error display handler} is the default handler, then the
error-display call is parameterized to install an emergency error
display handler that attempts to print directly to a console and never
fails.}
@ -322,7 +322,7 @@ argument if it is an @scheme[exn] value but not an
the second argument to highlight source locations.}
To report a run-time error, use @scheme[raise] or procedures like
@scheme[error], instead of calling the error display procedure
@scheme[error], instead of calling the error display handler
directly.}
@defparam[error-print-width width (and exact-integer? (>=/c 3))]{
@ -333,7 +333,7 @@ message.}
@defparam[error-print-context-length cnt exact-nonnegative-integer?]{
A parameter whose value is used by the default error display handler
A parameter whose value is used by the default @tech{error display handler}
as the maximum number of lines of context (or ``stack trace'') to
print; a single ``...'' line is printed if more lines are available
after the first @scheme[cnt] lines. A @scheme[0] value for
@ -504,13 +504,14 @@ interrupted computation.}
@defthing[prop:exn:srclocs struct-type-property?]{
A property that identifiers structure types that provide a list of
A property that identifies structure types that provide a list of
@scheme[srcloc] values. The property is normally attached to structure
types used to represent exception information.
The property value must be a procedure that accepts a single
value---the structure type instance from which to extract source
locations---and returns a list of @scheme[srcloc]s.}
locations---and returns a list of @scheme[srcloc]s. Some @tech{error
display handlers} use only the first returned location.}
@defproc[(exn:srclocs? [v any/c]) boolean?]{

3
collects/scribblings/reference/package.scrbl
View File

@ -18,6 +18,9 @@
(code:line #:all-defined-except (id ...))])]
)]{
@margin-note{The @scheme[define-package] form is based on the @schemeidfont{module}
form of Chez Scheme @cite["Waddell99"].}
The @scheme[define-package] form is similar to @scheme[module], except
that it can appear in any definition context. The @scheme[form]s
within a @scheme[define-package] form can be definitions or

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

@ -146,6 +146,12 @@ languages.}
#:url "http://srfi.schemers.org/srfi-42/"
#:date "2003")
(bib-entry #:key "Waddell99"
#:author "Oscar Waddell and R. Kent Dybvig"
#:title "Extending the Scope of Syntactic Abstraction"
#:location "Principles of Programming Languages"
#:date "1999")
)
@;------------------------------------------------------------------------

10
collects/scribblings/reference/stx-certs.scrbl
View File

@ -3,6 +3,8 @@
@title[#:tag "stxcerts"]{Syntax Certificates}
@guideintro["stx-certs"]{syntax certificates}
A @deftech{syntax certificate} combines a @tech{syntax mark} (see
@secref["transformer-model"]), a @tech{module path index} or symbol
module name (see @secref["modpathidx"]), an @tech{inspector} (see
@ -112,8 +114,12 @@ expansion context:
@item{When the expander encounters a @scheme[quote-syntax] form, it
attaches all accumulated @tech{active certificates} from the
expressions's context to the quoted syntax objects. The
certificates are attached as @tech{inactive certificates}.}
expressions's context to the quoted syntax objects. A certificate
for the enclosing module (if any) is also included. The
certificates are attached as @tech{inactive certificates} to the
immediate syntax object (i.e., not to any nested syntax
objects). In addition, any inactive certificates within the quoted
syntax object are lifted to the immediate syntax object.}
}

4
collects/tests/mzscheme/optimize.ss
View File

@ -253,6 +253,10 @@
(bin -12 '* -3 4)
(bin -12 '* 3 -4)
(bin 12 '* -3 -4)
(bin (expt 2 70) '* 2 (expt 2 69))
(bin (expt 2 30) '* 2 (expt 2 29))
(bin (expt 2 31) '* 2 (expt 2 30))
(bin (- (expt 2 30)) '* 2 (- (expt 2 29)))
(bin 0 '/ 0 4)
(bin 1/4 '/ 1 4)

9
collects/tests/mzscheme/thread.ss
View File

@ -1275,4 +1275,13 @@
; --------------------
;; Make sure shared thread cell is not exposed:
(test #f 'no-breaks (with-handlers ([void (lambda (x) (break-enabled))]) (/ 0)))
(test #t 'no-breaks (with-handlers ([void (lambda (x) (break-enabled #t) (break-enabled))]) (/ 0)))
(test #f 'no-breaks (with-handlers ([void (lambda (x) (break-enabled))]) (/ 0)))
(test #t 'no-breaks (with-handlers ([(lambda (x) (break-enabled #t)) (lambda (x) (break-enabled))]) (/ 0)))
(test #f 'no-breaks (with-handlers ([void (lambda (x) (break-enabled))]) (/ 0)))
; --------------------
(report-errs)

8
collects/tests/mzscheme/will.ss
View File

@ -125,6 +125,14 @@
(custodian-shutdown-all c1)
(test '(#f #f) map custodian-box-value (list b1 b2)))
(let ()
(let ([c (make-custodian)])
(let ([l (for/list ([i (in-range 32)])
(make-custodian-box c 7))])
(test #t andmap (lambda (b) (number? (custodian-box-value b))) l)
(custodian-shutdown-all c)
(test #f ormap (lambda (b) (number? (custodian-box-value b))) l))))
;; ----------------------------------------
(report-errs)

0
collects/tests/typed-scheme/fail/pr9053-fail.ss → collects/tests/typed-scheme/succeed/pr9053-2.ss
View File

17
collects/tests/typed-scheme/succeed/require-substruct.ss Normal file
View File

@ -0,0 +1,17 @@
#lang scheme/load
(module m scheme
(define-struct X (x) #:transparent)
(define-struct (Y X) (y) #:transparent)
(provide (all-defined-out)))
(module n typed-scheme
(require-typed-struct X ([x : Number]) 'm)
(require-typed-struct (Y X) ([y : Number]) 'm)
(make-X 43)
(define: x : Any 3)
(if (Y? x)
(X-x x)
4))
(require 'n)

17
collects/tests/typed-scheme/succeed/time.ss Normal file
View File

@ -0,0 +1,17 @@
#lang typed-scheme
(: foo : Number Number -> Number)
(define (foo x y)
(* x y))
(: bar : Number -> Number)
(define (bar c)
(: loop : Number Number -> Number)
(define (loop n acc)
(if (< 0 n)
(loop (- n 1) (+ (foo c n) acc))
acc))
(loop 10000000 0))
(time (bar 0))

66
collects/typed-scheme/private/base-env.ss
View File

@ -245,8 +245,10 @@
[apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
[kernel:apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
[time-apply (-poly (a b) (((list) a . ->* . b) (-lst a)
. -> . (-values (list b N N N))))]
[time-apply (-polydots (b a) (((list) (a a) . ->... . b)
(-lst a)
. -> .
(-values (list (-pair b (-val '())) N N N))))]
[call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))]
[call/ec (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))]
@ -289,6 +291,57 @@
[(-Pattern -InpBts N ?N ) (optlist -Bytes)]
[(-Pattern -InpBts N ?N ?outp) (optlist -Bytes)]))]
[regexp-match*
(let ([?N (-opt N)]
[-StrRx (*Un -String -Regexp -PRegexp)]
[-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)]
[-InpBts (*Un -Input-Port -Bytes)])
(cl->*
(-StrRx -String [N ?N] . ->opt . (-lst -String))
(-BtsRx -String [N ?N] . ->opt . (-lst -Bytes))
(-Pattern -InpBts [N ?N] . ->opt . (-lst -Bytes))))]
[regexp-try-match
(let ([?outp (-opt -Output-Port)]
[?N (-opt N)]
[optlist (lambda (t) (-opt (-lst (-opt t))))])
(->opt -Pattern -Input-Port [N ?N ?outp] (optlist -Bytes)))]
[regexp-match-exact?
(-Pattern (Un -String -Bytes -Input-Port) . -> . B)]
[regexp-match-positions
(let ([?outp (-opt -Output-Port)]
[?N (-opt N)]
[optlist (lambda (t) (-opt (-lst (-opt t))))]
[-StrRx (*Un -String -Regexp -PRegexp)]
[-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)]
[-InpBts (*Un -Input-Port -Bytes)])
(->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (optlist (-pair -Nat -Nat))))]
[regexp-match-positions*
(let ([?outp (-opt -Output-Port)]
[?N (-opt N)]
[optlist (lambda (t) (-opt (-lst (-opt t))))]
[-StrRx (*Un -String -Regexp -PRegexp)]
[-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)]
[-InpBts (*Un -Input-Port -Bytes)])
(->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (-lst (-pair -Nat -Nat))))]
#;
[regexp-match-peek-positions*]
#;
[regexp-split]
[regexp-quote (cl->*
(->opt -String [Univ] -String)
(->opt -Bytes [Univ] -Bytes))]
[regexp-replace-quote
(cl->*
[-> -String -String]
[-> -Bytes -Bytes])]
[number->string (N . -> . -String)]
[current-milliseconds (-> -Integer)]
@ -500,3 +553,12 @@
[boolean=? (B B . -> . B)]
[symbol=? (Sym Sym . -> . B)]
[false? (make-pred-ty (-val #f))]
;; with-stx.ss
[generate-temporaries ((Un (-Syntax Univ) (-lst Univ)) . -> . (-lst (-Syntax Sym)))]
[check-duplicate-identifier ((-lst (-Syntax Sym)) . -> . (-opt (-Syntax Sym)))]
;; string.ss
[real->decimal-string (N [-Nat] . ->opt . -String)]
[current-continuation-marks (-> -Cont-Mark-Set)]

4
collects/typed-scheme/private/base-special-env.ss
View File

@ -29,8 +29,8 @@
[year : N] [weekday : N] [year-day : N] [dst? : B] [time-zone-offset : N])
())
(d-s exn ([message : -String] [continuation-marks : Univ]) ())
(d-s (exn:fail exn) () (-String Univ))
(d-s (exn:fail:read exn:fail) ([srclocs : (-lst Univ)]) (-String Univ))
(d-s (exn:fail exn) () (-String -Cont-Mark-Set))
(d-s (exn:fail:read exn:fail) ([srclocs : (-lst Univ)]) (-String -Cont-Mark-Set))
)
(provide (for-syntax initial-env/special-case initialize-others initialize-type-env)

7
collects/typed-scheme/private/env-lang.ss
View File

@ -1,10 +1,12 @@
#lang scheme/base
(require "../utils/utils.ss")
(require (rename-in "../utils/utils.ss" [infer r:infer]))
(require (for-syntax (private type-effect-convenience)
(env init-envs)
scheme/base
(r:infer infer)
(only-in (r:infer infer-dummy) infer-param)
(except-in (rep effect-rep type-rep) make-arr)
"type-effect-convenience.ss"
(only-in "type-effect-convenience.ss" [make-arr* make-arr])
@ -20,7 +22,8 @@
(begin
(require . args)
(define-for-syntax e
(make-env [id ty] ...))
(parameterize ([infer-param infer])
(make-env [id ty] ...)))
(begin-for-syntax
(initialize-type-env e)))))]
[(mb . rest)

3
collects/typed-scheme/private/parse-type.ss
View File

@ -27,6 +27,9 @@
(parameterize ([current-orig-stx stx])
(syntax-case* stx ()
symbolic-identifier=?
[t
(Type? (syntax-e #'t))
(syntax-e #'t)]
[(fst . rst)
(not (syntax->list #'rst))
(-pair (parse-type #'fst) (parse-type #'rst))]

44
collects/typed-scheme/private/prims.ss
View File

@ -57,6 +57,15 @@ This file defines two sorts of primitives. All of them are provided into any mod
(syntax-case* stx (rename) (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
[(_ lib [nm ty] ...)
#'(begin (require/typed nm ty lib) ...)]
[(_ nm ty lib #:struct-maker parent)
(with-syntax ([(cnt*) (generate-temporaries #'(nm))])
(quasisyntax/loc stx (begin
#,(syntax-property (syntax-property #'(define cnt* #f)
'typechecker:contract-def/maker #'ty)
'typechecker:ignore #t)
#,(internal #'(require/typed-internal nm ty #:struct-maker parent))
#,(syntax-property #'(require/contract nm cnt* lib)
'typechecker:ignore #t))))]
[(_ nm ty lib)
(identifier? #'nm)
(with-syntax ([(cnt*) (generate-temporaries #'(nm))])
@ -346,9 +355,8 @@ This file defines two sorts of primitives. All of them are provided into any mod
[(_ nm ([fld : ty] ...) lib)
(identifier? #'nm)
(with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
[(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]
[oty #'(Opaque pred)])
#'(begin
[(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))])
#`(begin
(require (only-in lib struct-info))
(define-syntax nm (make-struct-info
(lambda ()
@ -358,9 +366,33 @@ This file defines two sorts of primitives. All of them are provided into any mod
(list #'sel ...)
(list mut ...)
#f))))
(require/opaque-type nm pred lib #:name-exists)
(require/typed maker (ty ... -> oty) lib)
(require/typed sel (oty -> ty) lib) ...))]))
#,(internal #'(define-typed-struct-internal nm ([fld : ty] ...) #:type-only))
#,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
#,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
(require/typed maker nm lib #:struct-maker #f)
(require/typed lib
[sel (nm -> ty)]) ...))]
[(_ (nm parent) ([fld : ty] ...) lib)
(and (identifier? #'nm) (identifier? #'parent))
(with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
[(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]
#;[(parent-tys ...) (Struct-flds (parse-type #'parent))])
#`(begin
(require (only-in lib struct-info))
(define-syntax nm (make-struct-info
(lambda ()
(list #'struct-info
#'maker
#'pred
(list #'sel ...)
(list mut ...)
#f))))
#,(internal #'(define-typed-struct-internal (nm parent) ([fld : ty] ...) #:type-only))
#,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
#,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
(require/typed maker nm lib #:struct-maker parent)
(require/typed lib
[sel (nm -> ty)]) ...))]))
(define-syntax (do: stx)
(syntax-case stx (:)

14
collects/typed-scheme/private/require-contract.ss
View File

@ -6,13 +6,19 @@
(define-syntax (define-ignored stx)
(syntax-case stx ()
[(_ name expr)
(syntax-case (local-expand/capture-lifts #'expr 'expression
(syntax-case (local-expand/capture-lifts #'expr
'expression
(list #'define-values))
(begin define-values)
[(begin (define-values (n) e) e*)
#'(begin (define-values (n) e)
(define name e*))]
[e #'(define name e)])]))
#`(begin (define-values (n) e)
(define name #,(syntax-property #'e*
'inferred-name
(syntax-e #'name))))]
[(begin (begin e))
#`(define name #,(syntax-property #'e
'inferred-name
(syntax-e #'name)))])]))
(define-syntax (require/contract stx)
(syntax-case stx ()

12
collects/typed-scheme/private/type-contract.ss
View File

@ -23,15 +23,21 @@
(for-template scheme/base scheme/contract (only-in scheme/class object% is-a?/c subclass?/c)))
(define (define/fixup-contract? stx)
(syntax-property stx 'typechecker:contract-def))
(or (syntax-property stx 'typechecker:contract-def)
(syntax-property stx 'typechecker:contract-def/maker)))
(define (generate-contract-def stx)
(define prop (syntax-property stx 'typechecker:contract-def))
(define prop (or (syntax-property stx 'typechecker:contract-def)
(syntax-property stx 'typechecker:contract-def/maker)))
(define maker? (syntax-property stx 'typechecker:contract-def/maker))
(define typ (parse-type prop))
(syntax-case stx (define-values)
[(_ (n) __)
(let ([typ (if maker?
((Struct-flds (lookup-type-name (Name-id typ))) #f . t:->* . typ)
typ)])
(with-syntax ([cnt (type->contract typ (lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))])
(syntax/loc stx (define-values (n) cnt)))]
(syntax/loc stx (define-values (n) cnt))))]
[_ (int-err "should never happen - not a define-values: ~a" (syntax->datum stx))]))
(define (change-contract-fixups forms)

19
collects/typed-scheme/private/type-effect-convenience.ss
View File

@ -3,6 +3,7 @@
(require (rep type-rep effect-rep)
(utils tc-utils)
scheme/list
scheme/match
"type-comparison.ss"
"type-effect-printer.ss"
@ -84,7 +85,7 @@
(define (funty-arities f)
(match f
[(Function: as) as]))
(make-Function (map car (map funty-arities args))))
(make-Function (apply append (map funty-arities args))))
(define-syntax (->key stx)
(syntax-parse stx
@ -143,6 +144,8 @@
(define Univ (make-Univ))
(define Err (make-Error))
(define -Nat -Integer)
(define-syntax -v
(syntax-rules ()
[(_ x) (make-F 'x)]))
@ -213,6 +216,14 @@
(define (-Tuple l)
(foldr -pair (-val '()) l))
(define (untuple t)
(match t
[(Value: '()) null]
[(Pair: a b) (cond [(untuple b) => (lambda (l) (cons a l))]
[else #f])]
[_ #f]))
(define -box make-Box)
(define -vec make-Vector)
@ -277,3 +288,9 @@
(define (opt-fn args opt-args result)
(apply cl->* (for/list ([i (in-range (add1 (length opt-args)))])
(make-Function (list (make-arr* (append args (take opt-args i)) result))))))
(define-syntax-rule (->opt args ... [opt ...] res)
(opt-fn (list args ...) (list opt ...) res))

11
collects/typed-scheme/typecheck/tc-app-unit.ss
View File

@ -14,6 +14,7 @@
(prefix-in c: scheme/contract)
(for-syntax scheme/base)
(for-template
(only-in '#%kernel [apply k:apply])
"internal-forms.ss" scheme/base
(only-in scheme/private/class-internal make-object do-make-object)))
(require (r:infer constraint-structs))
@ -620,7 +621,7 @@
(define (tc/app/internal form expected)
(kernel-syntax-case* form #f
(values apply not list list* call-with-values do-make-object make-object cons
(values apply k:apply not list list* call-with-values do-make-object make-object cons
andmap ormap) ;; the special-cased functions
;; special case for delay
[(#%plain-app
@ -680,6 +681,14 @@
;; if arg was a predicate application, we swap the effects
[(tc-result: t thn-eff els-eff)
(ret B (map var->type-eff els-eff) (map var->type-eff thn-eff))])]
[(#%plain-app k:apply . args)
(tc/app/internal #'(#%plain-app apply . args) expected)]
;; special-er case for (apply values (list x y z))
[(#%plain-app apply values e)
(cond [(with-handlers ([exn:fail? (lambda _ #f)])
(untuple (tc-expr/t #'e)))
=> (lambda (t) (ret (-values t)))]
[else (tc/apply #'values #'(e))])]
;; special case for `apply'
[(#%plain-app apply f . args) (tc/apply #'f #'args)]
;; special case for keywords

16
collects/typed-scheme/typecheck/tc-structs.ss
View File

@ -91,7 +91,8 @@
#:proc-ty [proc-ty #f]
#:maker [maker* #f]
#:constructor-return [cret #f]
#:poly? [poly? #f])
#:poly? [poly? #f]
#:type-only [type-only #f])
;; create the approriate names that define-struct will bind
(define-values (maker pred getters setters) (struct-names nm flds setters?))
(let* ([name (syntax-e nm)]
@ -99,17 +100,19 @@
[sty (make-Struct name parent fld-types proc-ty poly? pred (syntax-local-certifier))]
[external-fld-types/no-parent types]
[external-fld-types fld-types])
(if type-only
(register-type-name nm (wrapper sty))
(register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
#:wrapper wrapper
#:type-wrapper type-wrapper
#:maker (or maker* maker)
#:constructor-return cret)))
#:constructor-return cret))))
;; generate names, and register the approriate types give field types and structure type
;; optionally wrap things
;; identifier Type Listof[identifer] Listof[Type] Listof[Type] #:wrapper (Type -> Type) #:maker identifier
(define (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
#:wrapper [wrapper (lambda (x) x)]
#:wrapper [wrapper values]
#:type-wrapper [type-wrapper values]
#:maker [maker* #f]
#:constructor-return [cret #f])
@ -168,7 +171,9 @@
;; typecheck a non-polymophic struct and register the approriate types
;; tc/struct : (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void
(define (tc/struct nm/par flds tys [proc-ty #f] #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f])
(define (tc/struct nm/par flds tys [proc-ty #f]
#:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f]
#:type-only [type-only #f])
;; get the parent info and create some types and type variables
(define-values (nm parent-name parent name name-tvar) (parse-parent nm/par))
;; parse the field types, and determine if the type is recursive
@ -184,7 +189,8 @@
#:proc-ty proc-ty-parsed
#:maker maker
#:constructor-return (and cret (parse-type cret))
#:mutable mutable))
#:mutable mutable
#:type-only type-only))
;; register a struct type
;; convenience function for built-in structs

11
collects/typed-scheme/typecheck/tc-toplevel.ss
View File

@ -7,6 +7,7 @@
scheme/match
"signatures.ss"
"tc-structs.ss"
(rep type-rep)
(private type-utils type-effect-convenience parse-type type-annotation mutated-vars type-contract)
(env type-env init-envs type-name-env type-alias-env)
(utils tc-utils)
@ -44,6 +45,13 @@
(register-type #'nm t)
(list (make-def-binding #'nm t)))]
[(define-values () (begin (quote-syntax (require/typed-internal nm ty #:struct-maker parent)) (#%plain-app values)))
(let* ([t (parse-type #'ty)]
[flds (Struct-flds (lookup-type-name (Name-id t)))]
[mk-ty (flds #f . ->* . t)])
(register-type #'nm mk-ty)
(list (make-def-binding #'nm mk-ty)))]
;; define-typed-struct
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...))) (#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))]
@ -52,6 +60,9 @@
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:maker m #:constructor-return t))
(#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m #:constructor-return #'t)]
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:type-only))
(#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:type-only #t)]
;; define-typed-struct w/ polymorphism
[(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...))) (#%plain-app values)))
(tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))]

35
src/mzscheme/gc2/newgc.c
View File

@ -1244,35 +1244,37 @@ typedef struct MarkSegment {
struct MarkSegment *prev;
struct MarkSegment *next;
void **top;
void **end;
void *stop_here; /* this is only used for its address */
} MarkSegment;
#define MARK_STACK_START(ms) ((void **)(void *)&ms[1])
#define MARK_STACK_END(ms) ((void **)((char *)ms + STACK_PART_SIZE))
static THREAD_LOCAL MarkSegment *mark_stack = NULL;
inline static MarkSegment* mark_stack_create_frame() {
MarkSegment *mark_frame = (MarkSegment*)ofm_malloc(STACK_PART_SIZE);
mark_frame->next = NULL;
mark_frame->top = &(mark_frame->stop_here);
mark_frame->end = PPTR(NUM(mark_frame) + STACK_PART_SIZE);
mark_frame->top = MARK_STACK_START(mark_frame);
return mark_frame;
}
inline static void push_ptr(void *ptr)
inline static void init_mark_stack()
{
/* This happens at the very beginning */
if(!mark_stack) {
mark_stack = mark_stack_create_frame();
mark_stack->prev = NULL;
}
}
inline static void push_ptr(void *ptr)
{
/* This happens during propoagation if we go past the end of this MarkSegment*/
if(mark_stack->top == mark_stack->end) {
if(mark_stack->top == MARK_STACK_END(mark_stack)) {
/* test to see if we already have another stack page ready */
if(mark_stack->next) {
/* we do, so just use it */
mark_stack = mark_stack->next;
mark_stack->top = &(mark_stack->stop_here);
mark_stack->top = MARK_STACK_START(mark_stack);
} else {
/* we don't, so we need to allocate one */
mark_stack->next = mark_stack_create_frame();
@ -1287,7 +1289,7 @@ inline static void push_ptr(void *ptr)
inline static int pop_ptr(void **ptr)
{
if(mark_stack->top == &mark_stack->stop_here) {
if(mark_stack->top == MARK_STACK_START(mark_stack)) {
if(mark_stack->prev) {
/* if there is a previous page, go to it */
mark_stack = mark_stack->prev;
@ -1323,7 +1325,7 @@ inline static void clear_stack_pages(void)
free(mark_stack);
}
mark_stack = base;
mark_stack->top = PPTR(mark_stack) + 4;
mark_stack->top = MARK_STACK_START(mark_stack);
}
}
@ -1332,7 +1334,7 @@ inline static void reset_pointer_stack(void)
/* go to the head of the list */
for(; mark_stack->prev; mark_stack = mark_stack->prev) {}
/* reset the stack */
mark_stack->top = PPTR(mark_stack) + 4;
mark_stack->top = MARK_STACK_START(mark_stack);
}
/*****************************************************************************/
@ -1424,6 +1426,8 @@ void NewGC_initialize(NewGC *newgc) {
newgc->generations_available = 1;
newgc->last_full_mem_use = (20 * 1024 * 1024);
newgc->new_btc_mark = 1;
init_mark_stack();
}
void GC_init_type_tags(int count, int pair, int mutable_pair, int weakbox, int ephemeron, int weakarray, int custbox)
@ -1621,7 +1625,10 @@ void GC_mark(const void *const_p)
/* now either fetch where we're going to put this object or make
a new page if we couldn't find a page with space to spare */
if(work) {
if (!work->added) {
pagemap_add(gc->page_maps, work);
work->added = 1;
}
work->marked_on = 1;
if (work->mprotected) {
work->mprotected = 0;
@ -1642,6 +1649,7 @@ void GC_mark(const void *const_p)
if(work->next)
work->next->prev = work;
pagemap_add(gc->page_maps, work);
work->added = 1;
gc->gen1_pages[type] = work;
newplace = PTR(NUM(work->addr) + PREFIX_SIZE);
}
@ -1651,11 +1659,11 @@ void GC_mark(const void *const_p)
work->has_new = 1;
/* transfer the object */
ohead->mark = 1; /* mark is copied to newplace, too */
memcpy(newplace, (const void *)ohead, size);
/* mark the old location as marked and moved, and the new location
as marked */
ohead->mark = ohead->moved = 1;
((struct objhead *)newplace)->mark = 1;
ohead->moved = 1;
/* if we're doing memory accounting, then we need the btc_mark
to be set properly */
#ifdef NEWGC_BTC_ACCOUNT
@ -1992,6 +2000,7 @@ static void remove_all_gen1_pages_from_pagemap(NewGC *gc)
add_protect_page_range(protect_range, work->addr, work->big_page ? round_to_apage_size(work->size) : APAGE_SIZE, APAGE_SIZE, 1);
}
pagemap_remove(pagemap, work);
work->added = 0;
}
}
flush_protect_page_ranges(protect_range, 1);

1
src/mzscheme/gc2/newgc.h
View File

@ -22,6 +22,7 @@ typedef struct mpage {
unsigned char marked_on ;
unsigned char has_new ;
unsigned char mprotected ;
unsigned char added ;
unsigned short live_size;
void **backtrace;
} mpage;

325
src/mzscheme/src/cstartup.inc
View File

@ -1,111 +1,115 @@
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,51,50,0,0,0,1,0,0,6,0,9,0,
13,0,26,0,29,0,34,0,41,0,46,0,51,0,58,0,65,0,69,0,78,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,50,0,0,0,1,0,0,6,0,9,0,
18,0,22,0,35,0,38,0,43,0,50,0,55,0,60,0,67,0,74,0,78,
0,84,0,98,0,112,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0,
177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,68,1,107,1,146,
1,215,1,4,2,92,2,137,2,142,2,162,2,51,3,71,3,121,3,187,3,
72,4,230,4,17,5,28,5,107,5,0,0,106,7,0,0,65,98,101,103,105,
110,29,11,11,63,108,101,116,72,112,97,114,97,109,101,116,101,114,105,122,101,
62,111,114,64,108,101,116,42,66,117,110,108,101,115,115,64,99,111,110,100,64,
119,104,101,110,66,108,101,116,114,101,99,66,100,101,102,105,110,101,63,97,110,
100,68,104,101,114,101,45,115,116,120,65,113,117,111,116,101,29,94,2,14,68,
177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,87,1,126,1,165,
1,234,1,42,2,130,2,194,2,199,2,219,2,110,3,130,3,181,3,247,3,
132,4,34,5,84,5,107,5,186,5,0,0,201,7,0,0,65,98,101,103,105,
110,29,11,11,68,104,101,114,101,45,115,116,120,63,108,101,116,72,112,97,114,
97,109,101,116,101,114,105,122,101,62,111,114,64,108,101,116,42,66,117,110,108,
101,115,115,64,99,111,110,100,64,119,104,101,110,66,108,101,116,114,101,99,66,
100,101,102,105,110,101,63,97,110,100,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,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,98,
10,35,11,8,133,229,94,159,2,16,35,35,159,2,15,35,35,16,20,2,3,
2,2,2,4,2,2,2,10,2,2,2,5,2,2,2,6,2,2,2,7,2,
2,2,8,2,2,2,9,2,2,2,11,2,2,2,12,2,2,97,36,11,8,
133,229,93,159,2,15,35,36,16,2,2,13,161,2,2,36,2,13,2,2,2,
13,97,10,11,11,8,133,229,16,0,97,10,37,11,8,133,229,16,0,13,16,
4,35,29,11,11,2,2,11,18,98,64,104,101,114,101,8,31,8,30,8,29,
8,28,8,27,27,248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251,
22,74,2,17,248,22,89,23,200,2,12,249,22,64,2,1,248,22,91,23,202,
1,27,248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251,22,74,2,
17,248,22,89,23,200,2,249,22,64,2,1,248,22,91,23,202,1,12,27,248,
22,66,248,22,133,4,23,197,1,28,248,22,72,23,194,2,20,15,159,36,35,
36,28,248,22,72,248,22,66,23,195,2,248,22,65,193,249,22,190,3,80,158,
38,35,251,22,74,2,17,248,22,65,23,200,2,249,22,64,2,12,248,22,66,
23,202,1,11,18,100,10,8,31,8,30,8,29,8,28,8,27,16,4,11,11,
2,18,3,1,7,101,110,118,57,55,57,56,16,4,11,11,2,19,3,1,7,
101,110,118,57,55,57,57,27,248,22,66,248,22,133,4,23,197,1,28,248,22,
72,23,194,2,20,15,159,36,35,36,28,248,22,72,248,22,66,23,195,2,248,
22,65,193,249,22,190,3,80,158,38,35,250,22,74,2,20,248,22,74,249,22,
74,248,22,74,2,21,248,22,65,23,202,2,251,22,74,2,17,2,21,2,21,
249,22,64,2,5,248,22,66,23,205,1,18,100,11,8,31,8,30,8,29,8,
28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,57,56,48,49,16,4,
11,11,2,19,3,1,7,101,110,118,57,56,48,50,248,22,133,4,193,27,248,
22,133,4,194,249,22,64,248,22,74,248,22,65,196,248,22,66,195,27,248,22,
66,248,22,133,4,23,197,1,249,22,190,3,80,158,38,35,28,248,22,52,248,
22,191,3,248,22,65,23,198,2,27,249,22,2,32,0,89,162,43,36,42,9,
222,33,39,248,22,133,4,248,22,89,23,200,2,250,22,74,2,22,248,22,74,
249,22,74,248,22,74,248,22,65,23,204,2,250,22,75,2,23,249,22,2,22,
65,23,204,2,248,22,91,23,206,2,249,22,64,248,22,65,23,202,1,249,22,
2,22,89,23,200,1,250,22,75,2,20,249,22,2,32,0,89,162,43,36,46,
9,222,33,40,248,22,133,4,248,22,65,201,248,22,66,198,27,248,22,133,4,
194,249,22,64,248,22,74,248,22,65,196,248,22,66,195,27,248,22,66,248,22,
133,4,23,197,1,249,22,190,3,80,158,38,35,250,22,75,2,22,249,22,2,
32,0,89,162,43,36,46,9,222,33,42,248,22,133,4,248,22,65,201,248,22,
66,198,27,248,22,66,248,22,133,4,196,27,248,22,133,4,248,22,65,195,249,
22,190,3,80,158,39,35,28,248,22,72,195,250,22,75,2,20,9,248,22,66,
199,250,22,74,2,3,248,22,74,248,22,65,199,250,22,75,2,6,248,22,66,
201,248,22,66,202,27,248,22,66,248,22,133,4,23,197,1,27,249,22,1,22,
78,249,22,2,22,133,4,248,22,133,4,248,22,65,199,249,22,190,3,80,158,
39,35,251,22,74,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,
105,111,110,45,109,97,114,107,2,24,250,22,75,1,23,101,120,116,101,110,100,
45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,21,95,1,27,
99,111,110,116,105,110,117,97,116,105,111,110,45,109,97,114,107,45,115,101,116,
45,102,105,114,115,116,11,2,24,201,250,22,75,2,20,9,248,22,66,203,27,
248,22,66,248,22,133,4,23,197,1,28,248,22,72,23,194,2,20,15,159,36,
35,36,249,22,190,3,80,158,38,35,27,248,22,133,4,248,22,65,23,198,2,
28,249,22,162,8,62,61,62,248,22,191,3,248,22,89,23,197,2,250,22,74,
2,20,248,22,74,249,22,74,21,93,2,25,248,22,65,199,250,22,75,2,8,
249,22,74,2,25,249,22,74,248,22,98,203,2,25,248,22,66,202,251,22,74,
2,17,28,249,22,162,8,248,22,191,3,248,22,65,23,201,2,64,101,108,115,
101,10,248,22,65,23,198,2,250,22,75,2,20,9,248,22,66,23,201,1,249,
22,64,2,8,248,22,66,23,203,1,99,8,31,8,30,8,29,8,28,8,27,
16,4,11,11,2,18,3,1,7,101,110,118,57,56,50,52,16,4,11,11,2,
19,3,1,7,101,110,118,57,56,50,53,18,158,94,10,64,118,111,105,100,8,
47,27,248,22,66,248,22,133,4,196,249,22,190,3,80,158,38,35,28,248,22,
52,248,22,191,3,248,22,65,197,250,22,74,2,26,248,22,74,248,22,65,199,
248,22,89,198,27,248,22,191,3,248,22,65,197,250,22,74,2,26,248,22,74,
248,22,65,197,250,22,75,2,23,248,22,66,199,248,22,66,202,159,35,20,103,
159,35,16,1,2,1,16,0,83,158,41,20,100,138,69,35,37,109,105,110,45,
115,116,120,2,2,11,10,11,10,35,80,158,35,35,20,103,159,35,16,0,16,
0,11,11,16,0,35,11,38,35,11,11,16,10,2,3,2,4,2,5,2,6,
2,7,2,8,2,9,2,10,2,11,2,12,16,10,11,11,11,11,11,11,11,
11,11,11,16,10,2,3,2,4,2,5,2,6,2,7,2,8,2,9,2,10,
2,11,2,12,35,45,36,11,11,16,0,16,0,16,0,35,35,11,11,11,16,
0,16,0,16,0,35,35,16,11,16,5,93,2,13,20,15,159,35,35,35,35,
20,103,159,35,16,0,16,1,33,32,10,16,5,93,2,7,89,162,43,36,52,
9,223,0,33,33,35,20,103,159,35,16,1,20,25,159,36,2,2,2,13,16,
0,11,16,5,93,2,9,89,162,43,36,52,9,223,0,33,34,35,20,103,159,
35,16,1,20,25,159,36,2,2,2,13,16,0,11,16,5,93,2,12,89,162,
43,36,52,9,223,0,33,35,35,20,103,159,35,16,1,20,25,159,36,2,2,
2,13,16,1,33,36,11,16,5,93,2,5,89,162,43,36,55,9,223,0,33,
37,35,20,103,159,35,16,1,20,25,159,36,2,2,2,13,16,1,33,38,11,
16,5,93,2,3,89,162,43,36,57,9,223,0,33,41,35,20,103,159,35,16,
1,20,25,159,36,2,2,2,13,16,0,11,16,5,93,2,10,89,162,43,36,
52,9,223,0,33,43,35,20,103,159,35,16,1,20,25,159,36,2,2,2,13,
16,0,11,16,5,93,2,6,89,162,43,36,53,9,223,0,33,44,35,20,103,
159,35,16,1,20,25,159,36,2,2,2,13,16,0,11,16,5,93,2,4,89,
162,43,36,54,9,223,0,33,45,35,20,103,159,35,16,1,20,25,159,36,2,
2,2,13,16,0,11,16,5,93,2,8,89,162,43,36,57,9,223,0,33,46,
35,20,103,159,35,16,1,20,25,159,36,2,2,2,13,16,1,33,48,11,16,
5,93,2,11,89,162,43,36,53,9,223,0,33,49,35,20,103,159,35,16,1,
20,25,159,36,2,2,2,13,16,0,11,16,0,94,2,15,2,16,93,2,15,
9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 2019);
10,35,11,8,180,243,94,159,2,16,35,35,159,2,15,35,35,16,20,2,4,
2,2,2,5,2,2,2,11,2,2,2,6,2,2,2,7,2,2,2,8,2,
2,2,9,2,2,2,10,2,2,2,12,2,2,2,13,2,2,97,36,11,8,
180,243,93,159,2,15,35,36,16,2,2,3,161,2,2,36,2,3,2,2,2,
3,97,10,11,11,8,180,243,16,0,97,10,37,11,8,180,243,16,0,13,16,
4,35,29,11,11,2,2,11,18,16,2,99,64,104,101,114,101,8,31,8,30,
8,29,8,28,8,27,93,8,224,251,60,0,0,95,9,8,224,251,60,0,0,
2,2,27,248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251,22,74,
2,17,248,22,89,23,200,2,12,249,22,64,2,1,248,22,91,23,202,1,27,
248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251,22,74,2,17,248,
22,89,23,200,2,249,22,64,2,1,248,22,91,23,202,1,12,27,248,22,66,
248,22,133,4,23,197,1,28,248,22,72,23,194,2,20,15,159,36,35,36,28,
248,22,72,248,22,66,23,195,2,248,22,65,193,249,22,190,3,80,158,38,35,
251,22,74,2,17,248,22,65,23,200,2,249,22,64,2,13,248,22,66,23,202,
1,11,18,16,2,101,10,8,31,8,30,8,29,8,28,8,27,16,4,11,11,
2,18,3,1,7,101,110,118,57,55,57,52,16,4,11,11,2,19,3,1,7,
101,110,118,57,55,57,53,93,8,224,252,60,0,0,95,9,8,224,252,60,0,
0,2,2,27,248,22,66,248,22,133,4,23,197,1,28,248,22,72,23,194,2,
20,15,159,36,35,36,28,248,22,72,248,22,66,23,195,2,248,22,65,193,249,
22,190,3,80,158,38,35,250,22,74,2,20,248,22,74,249,22,74,248,22,74,
2,21,248,22,65,23,202,2,251,22,74,2,17,2,21,2,21,249,22,64,2,
6,248,22,66,23,205,1,18,16,2,101,11,8,31,8,30,8,29,8,28,8,
27,16,4,11,11,2,18,3,1,7,101,110,118,57,55,57,55,16,4,11,11,
2,19,3,1,7,101,110,118,57,55,57,56,93,8,224,253,60,0,0,95,9,
8,224,253,60,0,0,2,2,248,22,133,4,193,27,248,22,133,4,194,249,22,
64,248,22,74,248,22,65,196,248,22,66,195,27,248,22,66,248,22,133,4,23,
197,1,249,22,190,3,80,158,38,35,28,248,22,52,248,22,191,3,248,22,65,
23,198,2,27,249,22,2,32,0,89,162,8,44,36,42,9,222,33,39,248,22,
133,4,248,22,89,23,200,2,250,22,74,2,22,248,22,74,249,22,74,248,22,
74,248,22,65,23,204,2,250,22,75,2,23,249,22,2,22,65,23,204,2,248,
22,91,23,206,2,249,22,64,248,22,65,23,202,1,249,22,2,22,89,23,200,
1,250,22,75,2,20,249,22,2,32,0,89,162,8,44,36,46,9,222,33,40,
248,22,133,4,248,22,65,201,248,22,66,198,27,248,22,133,4,194,249,22,64,
248,22,74,248,22,65,196,248,22,66,195,27,248,22,66,248,22,133,4,23,197,
1,249,22,190,3,80,158,38,35,250,22,75,2,22,249,22,2,32,0,89,162,
8,44,36,46,9,222,33,42,248,22,133,4,248,22,65,201,248,22,66,198,27,
248,22,66,248,22,133,4,196,27,248,22,133,4,248,22,65,195,249,22,190,3,
80,158,39,35,28,248,22,72,195,250,22,75,2,20,9,248,22,66,199,250,22,
74,2,4,248,22,74,248,22,65,199,250,22,75,2,7,248,22,66,201,248,22,
66,202,27,248,22,66,248,22,133,4,23,197,1,27,249,22,1,22,78,249,22,
2,22,133,4,248,22,133,4,248,22,65,199,249,22,190,3,80,158,39,35,251,
22,74,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,105,111,110,
45,109,97,114,107,2,24,250,22,75,1,23,101,120,116,101,110,100,45,112,97,
114,97,109,101,116,101,114,105,122,97,116,105,111,110,21,95,1,27,99,111,110,
116,105,110,117,97,116,105,111,110,45,109,97,114,107,45,115,101,116,45,102,105,
114,115,116,11,2,24,201,250,22,75,2,20,9,248,22,66,203,27,248,22,66,
248,22,133,4,23,197,1,28,248,22,72,23,194,2,20,15,159,36,35,36,249,
22,190,3,80,158,38,35,27,248,22,133,4,248,22,65,23,198,2,28,249,22,
162,8,62,61,62,248,22,191,3,248,22,89,23,197,2,250,22,74,2,20,248,
22,74,249,22,74,21,93,2,25,248,22,65,199,250,22,75,2,9,249,22,74,
2,25,249,22,74,248,22,98,203,2,25,248,22,66,202,251,22,74,2,17,28,
249,22,162,8,248,22,191,3,248,22,65,23,201,2,64,101,108,115,101,10,248,
22,65,23,198,2,250,22,75,2,20,9,248,22,66,23,201,1,249,22,64,2,
9,248,22,66,23,203,1,100,8,31,8,30,8,29,8,28,8,27,16,4,11,
11,2,18,3,1,7,101,110,118,57,56,50,48,16,4,11,11,2,19,3,1,
7,101,110,118,57,56,50,49,93,8,224,254,60,0,0,18,16,2,158,94,10,
64,118,111,105,100,8,47,95,9,8,224,254,60,0,0,2,2,27,248,22,66,
248,22,133,4,196,249,22,190,3,80,158,38,35,28,248,22,52,248,22,191,3,
248,22,65,197,250,22,74,2,26,248,22,74,248,22,65,199,248,22,89,198,27,
248,22,191,3,248,22,65,197,250,22,74,2,26,248,22,74,248,22,65,197,250,
22,75,2,23,248,22,66,199,248,22,66,202,159,35,20,103,159,35,16,1,2,
1,16,0,83,158,41,20,100,141,69,35,37,109,105,110,45,115,116,120,2,2,
11,10,11,10,35,80,158,35,35,20,103,159,35,16,0,16,0,11,11,16,1,
2,3,36,16,0,35,11,11,38,35,11,11,16,10,2,4,2,5,2,6,2,
7,2,8,2,9,2,10,2,11,2,12,2,13,16,10,11,11,11,11,11,11,
11,11,11,11,16,10,2,4,2,5,2,6,2,7,2,8,2,9,2,10,2,
11,2,12,2,13,35,45,36,11,11,16,0,16,0,16,0,35,35,11,11,11,
16,0,16,0,16,0,35,35,16,11,16,5,93,2,3,20,15,159,35,35,35,
35,20,103,159,35,16,0,16,1,33,32,10,16,5,93,2,8,89,162,8,44,
36,52,9,223,0,33,33,35,20,103,159,35,16,1,20,25,159,36,2,2,2,
3,16,0,11,16,5,93,2,10,89,162,8,44,36,52,9,223,0,33,34,35,
20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,2,
13,89,162,8,44,36,52,9,223,0,33,35,35,20,103,159,35,16,1,20,25,
159,36,2,2,2,3,16,1,33,36,11,16,5,93,2,6,89,162,8,44,36,
55,9,223,0,33,37,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,
16,1,33,38,11,16,5,93,2,4,89,162,8,44,36,57,9,223,0,33,41,
35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,
2,11,89,162,8,44,36,52,9,223,0,33,43,35,20,103,159,35,16,1,20,
25,159,36,2,2,2,3,16,0,11,16,5,93,2,7,89,162,8,44,36,53,
9,223,0,33,44,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,
0,11,16,5,93,2,5,89,162,8,44,36,54,9,223,0,33,45,35,20,103,
159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,2,9,89,
162,8,44,36,57,9,223,0,33,46,35,20,103,159,35,16,1,20,25,159,36,
2,2,2,3,16,1,33,48,11,16,5,93,2,12,89,162,8,44,36,53,9,
223,0,33,49,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,
11,16,0,94,2,15,2,16,93,2,15,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 2114);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,51,60,0,0,0,1,0,0,3,0,16,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,60,0,0,0,1,0,0,3,0,16,0,
21,0,38,0,53,0,71,0,87,0,97,0,115,0,135,0,151,0,169,0,200,
0,229,0,251,0,9,1,15,1,29,1,34,1,44,1,52,1,80,1,112,1,
157,1,202,1,226,1,9,2,11,2,68,2,158,3,199,3,33,5,137,5,241,
5,102,6,116,6,150,6,166,6,16,8,30,8,193,8,194,9,194,10,201,10,
208,10,215,10,90,11,103,11,58,12,160,12,173,12,195,12,147,13,51,14,122,
15,130,15,138,15,164,15,18,16,0,0,63,19,0,0,29,11,11,72,112,97,
15,130,15,138,15,164,15,18,16,0,0,67,19,0,0,29,11,11,72,112,97,
116,104,45,115,116,114,105,110,103,63,64,98,115,98,115,76,110,111,114,109,97,
108,45,99,97,115,101,45,112,97,116,104,74,45,99,104,101,99,107,45,114,101,
108,112,97,116,104,77,45,99,104,101,99,107,45,99,111,108,108,101,99,116,105,
@ -302,7 +306,7 @@
173,3,23,202,1,28,192,192,35,249,22,151,5,23,197,1,83,158,39,20,97,
95,89,162,8,44,35,47,9,224,3,2,33,58,23,195,1,23,196,1,27,248,
22,136,5,23,195,1,248,80,159,38,53,36,193,159,35,20,103,159,35,16,1,
65,98,101,103,105,110,16,0,83,158,41,20,100,138,67,35,37,117,116,105,108,
65,98,101,103,105,110,16,0,83,158,41,20,100,141,67,35,37,117,116,105,108,
115,2,1,11,11,10,10,42,80,158,35,35,20,103,159,37,16,17,30,2,1,
2,2,193,30,2,1,2,3,193,30,2,1,2,4,193,30,2,1,2,5,193,
30,2,1,2,6,193,30,2,1,2,7,193,30,2,1,2,8,193,30,2,1,
@ -311,62 +315,63 @@
2,16,193,30,2,18,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,
105,111,110,45,107,101,121,4,30,2,18,1,23,101,120,116,101,110,100,45,112,
97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,3,16,0,11,11,16,
4,2,6,2,5,2,3,2,9,39,11,38,35,11,11,16,11,2,8,2,7,
2,16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,2,16,11,11,
11,11,11,11,11,11,11,11,11,11,16,11,2,8,2,7,2,16,2,15,2,
13,2,12,2,4,2,11,2,14,2,10,2,2,46,46,36,11,11,16,0,16,
0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,17,83,
158,35,16,2,89,162,43,36,48,2,19,223,0,33,29,80,159,35,53,36,83,
158,35,16,2,89,162,8,44,36,55,2,19,223,0,33,30,80,159,35,52,36,
83,158,35,16,2,32,0,89,162,43,36,44,2,2,222,33,31,80,159,35,35,
36,83,158,35,16,2,249,22,159,6,7,92,7,92,80,159,35,36,36,83,158,
35,16,2,89,162,43,36,53,2,4,223,0,33,32,80,159,35,37,36,83,158,
35,16,2,32,0,89,162,8,44,37,49,2,5,222,33,33,80,159,35,38,36,
83,158,35,16,2,32,0,89,162,8,44,38,50,2,6,222,33,35,80,159,35,
39,36,83,158,35,16,2,89,162,8,45,37,47,2,7,223,0,33,37,80,159,
35,40,36,83,158,35,16,2,32,0,89,162,43,39,51,2,8,222,33,40,80,
159,35,41,36,83,158,35,16,2,32,0,89,162,43,38,49,2,9,222,33,41,
80,159,35,42,36,83,158,35,16,2,32,0,89,162,43,37,52,2,10,222,33,
42,80,159,35,43,36,83,158,35,16,2,32,0,89,162,43,37,53,2,11,222,
33,43,80,159,35,44,36,83,158,35,16,2,32,0,89,162,43,36,43,2,12,
222,33,44,80,159,35,45,36,83,158,35,16,2,83,158,38,20,96,96,2,13,
89,162,43,35,43,9,223,0,33,45,89,162,43,36,44,9,223,0,33,46,89,
162,43,37,54,9,223,0,33,47,80,159,35,46,36,83,158,35,16,2,27,248,
22,182,13,248,22,168,7,27,28,249,22,162,8,247,22,176,7,2,21,6,1,
1,59,6,1,1,58,250,22,141,7,6,14,14,40,91,94,126,97,93,42,41,
126,97,40,46,42,41,23,196,2,23,196,1,89,162,8,44,37,47,2,14,223,
0,33,50,80,159,35,47,36,83,158,35,16,2,83,158,38,20,96,96,2,15,
89,162,8,44,38,53,9,223,0,33,55,89,162,43,37,46,9,223,0,33,56,
89,162,43,36,45,9,223,0,33,57,80,159,35,48,36,83,158,35,16,2,89,
162,43,38,51,2,16,223,0,33,59,80,159,35,49,36,94,29,94,2,17,68,
35,37,107,101,114,110,101,108,11,29,94,2,17,69,35,37,109,105,110,45,115,
116,120,11,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 5068);
0,35,16,4,2,6,2,5,2,3,2,9,39,11,11,38,35,11,11,16,11,
2,8,2,7,2,16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,
2,16,11,11,11,11,11,11,11,11,11,11,11,11,16,11,2,8,2,7,2,
16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,2,46,46,36,11,
11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,
0,16,17,83,158,35,16,2,89,162,43,36,48,2,19,223,0,33,29,80,159,
35,53,36,83,158,35,16,2,89,162,8,44,36,55,2,19,223,0,33,30,80,
159,35,52,36,83,158,35,16,2,32,0,89,162,43,36,44,2,2,222,33,31,
80,159,35,35,36,83,158,35,16,2,249,22,159,6,7,92,7,92,80,159,35,
36,36,83,158,35,16,2,89,162,43,36,53,2,4,223,0,33,32,80,159,35,
37,36,83,158,35,16,2,32,0,89,162,8,44,37,49,2,5,222,33,33,80,
159,35,38,36,83,158,35,16,2,32,0,89,162,8,44,38,50,2,6,222,33,
35,80,159,35,39,36,83,158,35,16,2,89,162,8,45,37,47,2,7,223,0,
33,37,80,159,35,40,36,83,158,35,16,2,32,0,89,162,43,39,51,2,8,
222,33,40,80,159,35,41,36,83,158,35,16,2,32,0,89,162,43,38,49,2,
9,222,33,41,80,159,35,42,36,83,158,35,16,2,32,0,89,162,43,37,52,
2,10,222,33,42,80,159,35,43,36,83,158,35,16,2,32,0,89,162,43,37,
53,2,11,222,33,43,80,159,35,44,36,83,158,35,16,2,32,0,89,162,43,
36,43,2,12,222,33,44,80,159,35,45,36,83,158,35,16,2,83,158,38,20,
96,96,2,13,89,162,43,35,43,9,223,0,33,45,89,162,43,36,44,9,223,
0,33,46,89,162,43,37,54,9,223,0,33,47,80,159,35,46,36,83,158,35,
16,2,27,248,22,182,13,248,22,168,7,27,28,249,22,162,8,247,22,176,7,
2,21,6,1,1,59,6,1,1,58,250,22,141,7,6,14,14,40,91,94,126,
97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,8,44,37,
47,2,14,223,0,33,50,80,159,35,47,36,83,158,35,16,2,83,158,38,20,
96,96,2,15,89,162,8,44,38,53,9,223,0,33,55,89,162,43,37,46,9,
223,0,33,56,89,162,43,36,45,9,223,0,33,57,80,159,35,48,36,83,158,
35,16,2,89,162,43,38,51,2,16,223,0,33,59,80,159,35,49,36,94,29,
94,2,17,68,35,37,107,101,114,110,101,108,11,29,94,2,17,69,35,37,109,
105,110,45,115,116,120,11,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 5072);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,51,8,0,0,0,1,0,0,6,0,19,0,
34,0,48,0,62,0,76,0,111,0,0,0,255,0,0,0,65,113,117,111,116,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,8,0,0,0,1,0,0,6,0,19,0,
34,0,48,0,62,0,76,0,111,0,0,0,3,1,0,0,65,113,117,111,116,
101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37,
110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122,
11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35,
37,107,101,114,110,101,108,11,98,10,35,11,8,135,231,97,159,2,2,35,35,
37,107,101,114,110,101,108,11,98,10,35,11,8,186,245,97,159,2,2,35,35,
159,2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,16,
0,159,35,20,103,159,35,16,1,65,98,101,103,105,110,16,0,83,158,41,20,
100,138,69,35,37,98,117,105,108,116,105,110,29,11,11,11,10,10,18,96,11,
100,141,69,35,37,98,117,105,108,116,105,110,29,11,11,11,10,10,18,96,11,
42,42,42,35,80,158,35,35,20,103,159,35,16,0,16,0,11,11,16,0,35,
11,38,35,11,11,16,0,16,0,16,0,35,35,36,11,11,16,0,16,0,16,
0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,0,99,2,6,
2,5,29,94,2,1,69,35,37,102,111,114,101,105,103,110,11,2,4,2,3,
2,2,29,94,2,1,67,35,37,112,108,97,99,101,11,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 292);
16,0,35,11,11,38,35,11,11,16,0,16,0,16,0,35,35,36,11,11,16,
0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,
0,99,2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105,103,110,11,
2,4,2,3,2,2,29,94,2,1,67,35,37,112,108,97,99,101,11,9,9,
9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 296);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,51,53,0,0,0,1,0,0,3,0,14,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,53,0,0,0,1,0,0,3,0,14,0,
41,0,47,0,60,0,74,0,96,0,122,0,134,0,152,0,172,0,184,0,200,
0,223,0,3,1,8,1,13,1,18,1,27,1,32,1,63,1,67,1,75,1,
83,1,91,1,194,1,239,1,3,2,31,2,62,2,117,2,127,2,174,2,184,
2,191,2,78,4,91,4,110,4,229,4,241,4,137,5,151,5,15,6,21,6,
35,6,62,6,147,6,149,6,214,6,149,12,208,12,240,12,0,0,164,15,0,
35,6,62,6,147,6,149,6,214,6,149,12,208,12,240,12,0,0,168,15,0,
0,29,11,11,70,100,108,108,45,115,117,102,102,105,120,1,25,100,101,102,97,
117,108,116,45,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,
65,113,117,111,116,101,29,94,2,4,67,35,37,117,116,105,108,115,11,29,94,
@ -525,7 +530,7 @@
33,43,89,162,43,38,48,9,223,1,33,44,89,162,43,39,8,30,9,225,2,
3,0,33,50,208,87,95,248,22,150,4,248,80,158,37,49,247,22,183,11,248,
22,188,4,80,158,36,36,248,22,174,12,80,159,36,41,36,159,35,20,103,159,
35,16,1,65,98,101,103,105,110,16,0,83,158,41,20,100,138,66,35,37,98,
35,16,1,65,98,101,103,105,110,16,0,83,158,41,20,100,141,66,35,37,98,
111,111,116,2,1,11,11,10,10,36,80,158,35,35,20,103,159,39,16,19,30,
2,1,2,2,193,30,2,1,2,3,193,30,2,5,72,112,97,116,104,45,115,
116,114,105,110,103,63,10,30,2,5,75,112,97,116,104,45,97,100,100,45,115,
@ -537,26 +542,26 @@
1,2,14,193,30,2,1,2,15,193,30,2,5,69,45,102,105,110,100,45,99,
111,108,0,30,2,5,76,110,111,114,109,97,108,45,99,97,115,101,45,112,97,
116,104,6,30,2,5,79,112,97,116,104,45,114,101,112,108,97,99,101,45,115,
117,102,102,105,120,9,30,2,1,2,16,193,16,0,11,11,16,11,2,10,2,
11,2,8,2,9,2,12,2,13,2,3,2,7,2,2,2,15,2,14,46,11,
38,35,11,11,16,1,2,16,16,1,11,16,1,2,16,36,36,36,11,11,16,
0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,
16,83,158,35,16,2,89,162,43,36,44,9,223,0,33,24,80,159,35,57,36,
83,158,35,16,2,89,162,43,36,44,9,223,0,33,25,80,159,35,56,36,83,
158,35,16,2,89,162,43,36,48,67,103,101,116,45,100,105,114,223,0,33,26,
80,159,35,55,36,83,158,35,16,2,89,162,43,37,48,68,119,105,116,104,45,
100,105,114,223,0,33,27,80,159,35,54,36,83,158,35,16,2,248,22,176,7,
69,115,111,45,115,117,102,102,105,120,80,159,35,35,36,83,158,35,16,2,89,
162,43,37,59,2,3,223,0,33,36,80,159,35,36,36,83,158,35,16,2,32,
0,89,162,8,44,36,41,2,7,222,192,80,159,35,41,36,83,158,35,16,2,
247,22,125,80,159,35,42,36,83,158,35,16,2,247,22,124,80,159,35,43,36,
83,158,35,16,2,247,22,60,80,159,35,44,36,83,158,35,16,2,248,22,18,
74,109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159,35,45,36,83,
158,35,16,2,11,80,158,35,46,83,158,35,16,2,11,80,158,35,47,83,158,
35,16,2,32,0,89,162,43,37,44,2,14,222,33,42,80,159,35,48,36,83,
158,35,16,2,89,162,8,44,36,44,2,15,223,0,33,51,80,159,35,49,36,
83,158,35,16,2,89,162,43,35,43,2,16,223,0,33,52,80,159,35,53,36,
95,29,94,2,4,68,35,37,107,101,114,110,101,108,11,29,94,2,4,69,35,
37,109,105,110,45,115,116,120,11,2,5,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 4131);
117,102,102,105,120,9,30,2,1,2,16,193,16,0,11,11,16,0,35,16,11,
2,10,2,11,2,8,2,9,2,12,2,13,2,3,2,7,2,2,2,15,2,
14,46,11,11,38,35,11,11,16,1,2,16,16,1,11,16,1,2,16,36,36,
36,11,11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,
35,16,0,16,16,83,158,35,16,2,89,162,43,36,44,9,223,0,33,24,80,
159,35,57,36,83,158,35,16,2,89,162,43,36,44,9,223,0,33,25,80,159,
35,56,36,83,158,35,16,2,89,162,43,36,48,67,103,101,116,45,100,105,114,
223,0,33,26,80,159,35,55,36,83,158,35,16,2,89,162,43,37,48,68,119,
105,116,104,45,100,105,114,223,0,33,27,80,159,35,54,36,83,158,35,16,2,
248,22,176,7,69,115,111,45,115,117,102,102,105,120,80,159,35,35,36,83,158,
35,16,2,89,162,43,37,59,2,3,223,0,33,36,80,159,35,36,36,83,158,
35,16,2,32,0,89,162,8,44,36,41,2,7,222,192,80,159,35,41,36,83,
158,35,16,2,247,22,125,80,159,35,42,36,83,158,35,16,2,247,22,124,80,
159,35,43,36,83,158,35,16,2,247,22,60,80,159,35,44,36,83,158,35,16,
2,248,22,18,74,109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159,
35,45,36,83,158,35,16,2,11,80,158,35,46,83,158,35,16,2,11,80,158,
35,47,83,158,35,16,2,32,0,89,162,43,37,44,2,14,222,33,42,80,159,
35,48,36,83,158,35,16,2,89,162,8,44,36,44,2,15,223,0,33,51,80,
159,35,49,36,83,158,35,16,2,89,162,43,35,43,2,16,223,0,33,52,80,
159,35,53,36,95,29,94,2,4,68,35,37,107,101,114,110,101,108,11,29,94,
2,4,69,35,37,109,105,110,45,115,116,120,11,2,5,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 4135);
}

29
src/mzscheme/src/eval.c
View File

@ -2220,6 +2220,11 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
if (info->inline_fuel < 0)
return NULL;
if (SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) {
/* Found a `((lambda' */
single_use = 1;
}
if (SAME_TYPE(SCHEME_TYPE(le), scheme_local_type)) {
/* Check for inlining: */
le = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(le), &offset, &single_use);
@ -2458,6 +2463,16 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
le = scheme_optimize_expr(app->args[i], info);
app->args[i] = le;
if (!i) {
if (SAME_TYPE(SCHEME_TYPE(app->args[0]),scheme_compiled_unclosed_procedure_type)) {
/* Found "((lambda" after optimizing; try again */
le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags);
if (le)
return le;
}
}
if (i && (SCHEME_TYPE(le) < _scheme_compiled_values_types_))
all_vals = 0;
}
@ -2501,6 +2516,13 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
le = scheme_optimize_expr(app->rator, info);
app->rator = le;
if (SAME_TYPE(SCHEME_TYPE(app->rator),scheme_compiled_unclosed_procedure_type)) {
/* Found "((lambda" after optimizing; try again */
le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags);
if (le)
return le;
}
le = scheme_optimize_expr(app->rand, info);
app->rand = le;
if (SCHEME_TYPE(le) > _scheme_compiled_values_types_) {
@ -2564,6 +2586,13 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
le = scheme_optimize_expr(app->rator, info);
app->rator = le;
if (SAME_TYPE(SCHEME_TYPE(app->rator),scheme_compiled_unclosed_procedure_type)) {
/* Found "((lambda" after optimizing; try again */
le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags);
if (le)
return le;
}
/* 1st arg */
le = scheme_optimize_expr(app->rand1, info);

21
src/mzscheme/src/jit.c
View File

@ -3185,10 +3185,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
}
CHECK_LIMIT();
if (arith == 2) {
if (rand2 || ((v != 0) && (v != 1)))
has_fixnum_fast = 0;
} else if (arith == -2) {
if (arith == -2) {
if (rand2 || (v != 1) || reversed)
has_fixnum_fast = 0;
}
@ -3326,10 +3323,10 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
}
jit_ori_ul(JIT_R0, JIT_R2, 0x1);
} else if (arith == 2) {
if (has_fixnum_fast) {
/* No fast path for fixnum multiplication, yet */
(void)jit_jmpi(refslow);
}
jit_andi_ul(JIT_R2, JIT_R1, (~0x1));
jit_rshi_l(JIT_V1, JIT_R0, 0x1);
(void)jit_bomulr_l(refslow, JIT_V1, JIT_R2);
jit_ori_ul(JIT_R0, JIT_V1, 0x1);
} else if (arith == -2) {
if (has_fixnum_fast) {
/* No fast path for fixnum division, yet */
@ -3432,11 +3429,11 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
} else if (v == 0) {
(void)jit_movi_p(JIT_R0, scheme_make_integer(0));
} else {
if (has_fixnum_fast) {
/* No general fast path for fixnum multiplication, yet */
(void)jit_movi_p(JIT_R1, scheme_make_integer(v));
(void)jit_jmpi(refslow);
}
jit_andi_ul(JIT_R2, JIT_R1, (~0x1));
jit_rshi_l(JIT_V1, JIT_R0, 0x1);
(void)jit_bomulr_l(refslow, JIT_V1, JIT_R2);
jit_ori_ul(JIT_R0, JIT_V1, 0x1);
}
} else if (arith == -2) {
if ((v == 1) && !reversed) {

7
src/mzscheme/src/lightning/i386/asm.h
View File

@ -217,6 +217,11 @@ typedef _uc jit_insn;
# define _qOr( OP,R ) _Or(OP,R)
#endif
#define _OO( OP ) ( _jit_B((OP)>>8), _jit_B( (OP) ) )
#ifdef JIT_X86_64
# define _qOO(OP) ( _REX(0,0,0), _OO(OP))
#else
# define _qOO(OP) _OO(OP)
#endif
#define _OOr( OP,R ) ( _jit_B((OP)>>8), _jit_B( (OP)|_r(R)) )
#define _Os( OP,B ) ( _s8P(B) ? _jit_B(((OP)|_b10)) : _jit_B(OP) )
#ifdef JIT_X86_64
@ -240,6 +245,7 @@ typedef _uc jit_insn;
#define _O_Mrm( OP ,MO,R,M ) ( _O ( OP ),_Mrm(MO,R,M ) )
#define _qO_Mrm( OP ,MO,R,M ) ( _qO ( OP,R,0,M),_qMrm(MO,R,M ) )
#define _OO_Mrm( OP ,MO,R,M ) ( _OO ( OP ),_Mrm(MO,R,M ) )
#define _qOO_Mrm( OP ,MO,R,M ) ( _qOO ( OP ),_Mrm(MO,R,M ) )
#define _O_Mrm_B( OP ,MO,R,M ,B ) ( _O ( OP ),_Mrm(MO,R,M ) ,_jit_B(B) )
#define _qO_Mrm_B( OP ,MO,R,M ,B ) ( _qO ( OP,R,0,M),_qMrm(MO,R,M ) ,_jit_B(B) )
#define _O_Mrm_W( OP ,MO,R,M ,W ) ( _O ( OP ),_Mrm(MO,R,M ) ,_jit_W(W) )
@ -500,6 +506,7 @@ typedef _uc jit_insn;
#define IMULLirr(IM,RS,RD) _Os_Mrm_sL (0x69 ,_b11,_r4(RS),_r4(RD) ,IM )
#define IMULLimr(IM,MD,MB,MI,MS,RD) _Os_r_X_sL (0x69 ,_r4(RD) ,MD,MB,MI,MS ,IM )
#define IMULQrr(RS,RD) _qOO_Mrm (0x0faf ,_b11,_r4(RD),_r4(RS) )
#define INCBr(RD) _O_Mrm (0xfe ,_b11,_b000 ,_r1(RD) )
#define INCBm(MD,MB,MI,MS) _O_r_X (0xfe ,_b000 ,MD,MB,MI,MS )

1
src/mzscheme/src/lightning/i386/core.h
View File

@ -467,6 +467,7 @@ static int jit_arg_reg_order[] = { _EDI, _ESI, _EDX, _ECX };
#define jit_bosubr_l(label, s1, s2) (SUBQrr((s2), (s1)), JOm(label,0,0,0), _jit.x.pc)
#define jit_boaddr_ul(label, s1, s2) (ADDQrr((s2), (s1)), JCm(label,0,0,0), _jit.x.pc)
#define jit_bosubr_ul(label, s1, s2) (SUBQrr((s2), (s1)), JCm(label,0,0,0), _jit.x.pc)
#define jit_bomulr_l(label, s1, s2) (IMULQrr((s2), (s1)), JOm(label,0,0,0), _jit.x.pc)
#define jit_blti_i(label, rs, is) jit_bra_i0((rs), (is), JLm(label, 0,0,0), JSm(label, 0,0,0) )
#define jit_blei_i(label, rs, is) jit_bra_i ((rs), (is), JLEm(label,0,0,0) )

1
src/mzscheme/src/lightning/ppc/core.h
View File

@ -177,6 +177,7 @@ struct jit_local_state {
#define jit_bosubi_ui(label, rs, is) (jit_chk_ims ((is), SUBICri((rs), (rs), is), SUBCrr((rs), JIT_AUX)), MCRXRi(0), BEQi((label)), _jit.x.pc)
#define jit_boaddr_ui(label, s1, s2) ( ADDCrr((s1), (s1), (s2)), MCRXRi(0), BEQi((label)), _jit.x.pc)
#define jit_bosubr_ui(label, s1, s2) ( SUBCrr((s1), (s1), (s2)), MCRXRi(0), BEQi((label)), _jit.x.pc)
#define jit_bomulr_i(label, s1, s2) ( MULLWOrrr((s1), (s1), (s2)), MCRXRi(0), BGTi((label)), _jit.x.pc)
#define jit_calli(label) ((void)jit_movi_p(JIT_AUX, (label)), MTCTRr(JIT_AUX), BCTRL(), _jitl.nextarg_puti = _jitl.nextarg_putf = _jitl.nextarg_putd = 0, _jit.x.pc)
#define jit_callr(reg) (MTCTRr(reg), BCTRL())
#define jit_divi_i(d, rs, is) jit_big_ims((is), DIVWrrr ((d), (rs), JIT_AUX))

327
src/mzscheme/src/module.c
View File

@ -244,7 +244,11 @@ static char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash
Scheme_Module_Exports *me,
Scheme_Env *genv,
int reprovide_kernel,
Scheme_Object *form);
Scheme_Object *form,
char **_phase1_protects);
static Scheme_Object **compute_indirects(Scheme_Env *genv,
Scheme_Module_Phase_Exports *pt,
int *_count);
static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx,
int eval_exp, int eval_run, long base_phase, Scheme_Object *cycle_list);
static void finish_expstart_module(Scheme_Env *menv);
@ -3100,28 +3104,51 @@ static Scheme_Module *module_load(Scheme_Object *name, Scheme_Env *env, const ch
static void setup_accessible_table(Scheme_Module *m)
{
if (!m->accessible) {
Scheme_Module_Phase_Exports *pt;
int j;
for (j = 0; j < 2; j++) {
if (!j)
pt = m->me->rt;
else
pt = m->me->et;
if (pt) {
Scheme_Hash_Table *ht;
int i, count, nvp;
ht = scheme_make_hash_table(SCHEME_hash_ptr);
nvp = m->me->rt->num_var_provides;
nvp = pt->num_var_provides;
for (i = 0; i < nvp; i++) {
if (SCHEME_FALSEP(m->me->rt->provide_srcs[i])) {
scheme_hash_set(ht, m->me->rt->provide_src_names[i], scheme_make_integer(i));
if (SCHEME_FALSEP(pt->provide_srcs[i])) {
scheme_hash_set(ht, pt->provide_src_names[i], scheme_make_integer(i));
}
}
if (j == 0) {
count = m->num_indirect_provides;
for (i = 0; i < count; i++) {
scheme_hash_set(ht, m->indirect_provides[i], scheme_make_integer(i + nvp));
}
m->accessible = ht;
} else {
count = m->num_indirect_et_provides;
for (i = 0; i < count; i++) {
scheme_hash_set(ht, m->et_indirect_provides[i], scheme_make_integer(i + nvp));
}
}
/* Add syntax as negative ids: */
count = m->me->rt->num_provides;
count = pt->num_provides;
for (i = nvp; i < count; i++) {
if (SCHEME_FALSEP(m->me->rt->provide_srcs[i])) {
scheme_hash_set(ht, m->me->rt->provide_src_names[i], scheme_make_integer(-(i+1)));
if (SCHEME_FALSEP(pt->provide_srcs[i])) {
scheme_hash_set(ht, pt->provide_src_names[i], scheme_make_integer(-(i+1)));
}
}
if (!j)
m->accessible = ht;
else
m->et_accessible = ht;
}
}
}
@ -3212,35 +3239,63 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
supplied (not both). For unprotected access, both prot_insp
and stx+certs should be supplied. */
{
Scheme_Module_Phase_Exports *pt;
if (!SCHEME_SYMBOLP(symbol))
symbol = scheme_tl_id_sym(env, symbol, NULL, 0, NULL, NULL);
if (scheme_is_kernel_env(env)
|| ((env->module->primitive && !env->module->provide_protects))
/* For now[?], we're pretending that all definitions exists for
non-0 local phase. */
|| env->mod_phase) {
|| ((env->module->primitive && !env->module->provide_protects))) {
if (want_pos)
return scheme_make_integer(-1);
else
return symbol;
}
switch (env->mod_phase) {
case 0:
pt = env->module->me->rt;
break;
case 1:
pt = env->module->me->et;
break;
default:
pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(env->module->me->other_phases,
scheme_make_integer(env->mod_phase));
break;
}
if (pt) {
if (position >= 0) {
/* Check whether the symbol at `pos' matches the string part of
the expected symbol. */
Scheme_Object *isym;
int need_cert = 0;
if (position < env->module->me->rt->num_var_provides) {
if (!env->module->me->rt->provide_srcs
|| SCHEME_FALSEP(env->module->me->rt->provide_srcs[position]))
isym = env->module->me->rt->provide_src_names[position];
if (position < pt->num_var_provides) {
if (!pt->provide_srcs
|| SCHEME_FALSEP(pt->provide_srcs[position]))
isym = pt->provide_src_names[position];
else
isym = NULL;
} else {
int ipos = position - env->module->me->rt->num_var_provides;
if (ipos < env->module->num_indirect_provides) {
isym = env->module->indirect_provides[ipos];
int ipos = position - pt->num_var_provides;
int num_indirect_provides;
Scheme_Object **indirect_provides;
if (env->mod_phase == 0) {
num_indirect_provides = env->module->num_indirect_provides;
indirect_provides = env->module->indirect_provides;
} else if (env->mod_phase == 1) {
num_indirect_provides = env->module->num_indirect_et_provides;
indirect_provides = env->module->et_indirect_provides;
} else {
num_indirect_provides = 0;
indirect_provides = NULL;
}
if (ipos < num_indirect_provides) {
isym = indirect_provides[ipos];
need_cert = 1;
if (_protected)
*_protected = 1;
@ -3253,14 +3308,24 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
|| (SCHEME_SYM_LEN(isym) == SCHEME_SYM_LEN(symbol)
&& !memcmp(SCHEME_SYM_VAL(isym), SCHEME_SYM_VAL(symbol), SCHEME_SYM_LEN(isym)))) {
if ((position < env->module->me->rt->num_var_provides)
&& scheme_module_protected_wrt(env->insp, prot_insp)
&& env->module->provide_protects
&& env->module->provide_protects[position]) {
if ((position < pt->num_var_provides)
&& scheme_module_protected_wrt(env->insp, prot_insp)) {
char *provide_protects;
if (env->mod_phase == 0)
provide_protects = env->module->provide_protects;
else if (env->mod_phase == 0)
provide_protects = env->module->et_provide_protects;
else
provide_protects = NULL;
if (provide_protects
&& provide_protects[position]) {
if (_protected)
*_protected = 1;
check_certified(stx, certs, prot_insp, in_modidx, env, symbol, 1, 1);
}
}
if (need_cert)
check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 1, 0);
@ -3275,7 +3340,12 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
} else {
Scheme_Object *pos;
if (!env->mod_phase)
pos = scheme_hash_get(env->module->accessible, symbol);
else if (env->mod_phase == 1)
pos = scheme_hash_get(env->module->et_accessible, symbol);
else
pos = NULL;
if (pos) {
if (position < -1) {
@ -3290,16 +3360,25 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
}
if (pos) {
if (env->module->provide_protects
&& (SCHEME_INT_VAL(pos) < env->module->me->rt->num_provides)
&& env->module->provide_protects[SCHEME_INT_VAL(pos)]) {
char *provide_protects;
if (env->mod_phase == 0)
provide_protects = env->module->provide_protects;
else if (env->mod_phase == 1)
provide_protects = env->module->et_provide_protects;
else
provide_protects = NULL;
if (provide_protects
&& (SCHEME_INT_VAL(pos) < pt->num_provides)
&& provide_protects[SCHEME_INT_VAL(pos)]) {
if (_protected)
*_protected = 1;
check_certified(stx, certs, prot_insp, in_modidx, env, symbol, 1, 1);
}
if ((position >= -1)
&& (SCHEME_INT_VAL(pos) >= env->module->me->rt->num_var_provides)) {
&& (SCHEME_INT_VAL(pos) >= pt->num_var_provides)) {
/* unexported var -- need cert */
if (_protected)
*_protected = 1;
@ -3318,6 +3397,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
return NULL;
}
}
}
/* For error, if stx is no more specific than symbol, drop symbol. */
if (stx && SAME_OBJ(SCHEME_STX_SYM(stx), symbol)) {
@ -3338,11 +3418,12 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
scheme_wrong_syntax("link", stx, symbol,
"module mismatch, probably from old bytecode whose dependencies have changed: "
"variable not provided (directly or indirectly%s) from module: %D %s%t",
"variable not provided (directly or indirectly%s) from module: %D%s%t at source phase level: %d",
(position >= 0) ? " and at the expected position" : "",
env->module->modname,
srclen ? " accessed from module: " : "",
srcstr, srclen);
srcstr, srclen,
env->mod_phase);
}
return NULL;
@ -5597,10 +5678,10 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
Scheme_Object *post_ex_rn_set; /* phase -> post_ex_rn-like rename */
Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */
Scheme_Object *exclude_hint = scheme_false, *lift_data;
Scheme_Object **exis;
Scheme_Object **exis, **et_exis;
Scheme_Object *lift_ctx;
int exicount;
char *exps;
int exicount, et_exicount;
char *exps, *et_exps;
int all_simple_renames = 1;
int maybe_has_lifts = 0;
int reprovide_kernel;
@ -5979,13 +6060,14 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
mrec.pre_unwrapped = 0;
mrec.env_already = 0;
mrec.comp_flags = rec[drec].comp_flags;
scheme_rec_add_certs(&mrec, 0, e);
if (!rec[drec].comp) {
Scheme_Expand_Info erec1;
erec1.comp = 0;
erec1.depth = -1;
erec1.value_name = boundname;
erec1.certs = rec[drec].certs;
erec1.certs = mrec.certs;
erec1.observer = rec[drec].observer;
erec1.pre_unwrapped = 0;
erec1.env_already = 0;
@ -6310,51 +6392,16 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
env->genv->module->me,
env->genv,
reprovide_kernel,
form);
form, &et_exps);
/* Compute indirect provides (which is everything at the top-level): */
exis = compute_indirects(env->genv, env->genv->module->me->rt, &exicount);
et_exis = compute_indirects(env->genv->exp_env, env->genv->module->me->et, &et_exicount);
if (rec[drec].comp || (rec[drec].depth != -2)) {
scheme_clean_dead_env(env->genv);
}
/* Compute indirect provides (which is everything at the top-level): */
{
int i, count, j;
Scheme_Bucket **bs, *b;
Scheme_Object **exsns = env->genv->module->me->rt->provide_src_names;
int exvcount = env->genv->module->me->rt->num_var_provides;
bs = env->genv->toplevel->buckets;
for (count = 0, i = env->genv->toplevel->size; i--; ) {
b = bs[i];
if (b && b->val)
count++;
}
exis = MALLOC_N(Scheme_Object *, count);
for (count = 0, i = env->genv->toplevel->size; i--; ) {
b = bs[i];
if (b && b->val) {
Scheme_Object *name;
name = (Scheme_Object *)b->key;
/* If the name is directly provided, no need for indirect... */
for (j = 0; j < exvcount; j++) {
if (SAME_OBJ(name, exsns[j]))
break;
}
if (j == exvcount)
exis[count++] = name;
}
}
exicount = count;
qsort_provides(exis, NULL, NULL, NULL, NULL, NULL, 0, exicount, 1);
}
if (!rec[drec].comp) {
Scheme_Module_Phase_Exports *rt = env->genv->module->me->rt;
int excount = rt->num_provides;
@ -6464,6 +6511,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
env->genv->module->et_body = exp_body_r;
env->genv->module->provide_protects = exps;
env->genv->module->et_provide_protects = et_exps;
env->genv->module->me->rt->reprovide_kernel = reprovide_kernel;
env->genv->module->me->rt->kernel_exclusion = exclude_hint;
@ -6471,6 +6519,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
env->genv->module->indirect_provides = exis;
env->genv->module->num_indirect_provides = exicount;
env->genv->module->et_indirect_provides = et_exis;
env->genv->module->num_indirect_et_provides = et_exicount;
env->genv->module->comp_prefix = cenv->prefix;
if (all_simple_renames) {
@ -6877,6 +6928,64 @@ int compute_reprovides(Scheme_Hash_Table *all_provided,
return reprovide_kernel;
}
static Scheme_Object **compute_indirects(Scheme_Env *genv,
Scheme_Module_Phase_Exports *pt,
int *_count)
{
int i, count, j;
Scheme_Bucket **bs, *b;
Scheme_Object **exsns = pt->provide_src_names, **exis;
int exvcount = pt->num_var_provides, exicount;
if (!genv->toplevel)
count = 0;
else {
bs = genv->toplevel->buckets;
for (count = 0, i = genv->toplevel->size; i--; ) {
b = bs[i];
if (b && b->val)
count++;
}
}
if (!count) {
*_count = 0;
return NULL;
}
exis = MALLOC_N(Scheme_Object *, count);
for (count = 0, i = genv->toplevel->size; i--; ) {
b = bs[i];
if (b && b->val) {
Scheme_Object *name;
name = (Scheme_Object *)b->key;
/* If the name is directly provided, no need for indirect... */
for (j = 0; j < exvcount; j++) {
if (SAME_OBJ(name, exsns[j]))
break;
}
if (j == exvcount)
exis[count++] = name;
}
}
if (!count) {
*_count = 0;
return NULL;
}
exicount = count;
qsort_provides(exis, NULL, NULL, NULL, NULL, NULL, 0, exicount, 1);
*_count = exicount;
return exis;
}
Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bindings, Scheme_Object *modpath,
Scheme_Object *mode)
{
@ -6978,12 +7087,13 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
Scheme_Module_Exports *me,
Scheme_Env *genv,
int reprovide_kernel,
Scheme_Object *form)
Scheme_Object *form,
char **_phase1_protects)
{
int i, count, z;
Scheme_Object **exs, **exsns, **exss, **exsnoms, *phase;
Scheme_Hash_Table *provided, *required;
char *exps, *exets, *phase0_exps = NULL;
char *exps, *exets, *phase0_exps = NULL, *phase1_exps = NULL;
int excount, exvcount;
Scheme_Module_Phase_Exports *pt;
@ -7189,9 +7299,13 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
if (SAME_OBJ(phase, scheme_make_integer(0)))
phase0_exps = exps;
else if (SAME_OBJ(phase, scheme_make_integer(1)))
phase1_exps = exps;
}
}
*_phase1_protects = phase1_exps;
return phase0_exps;
}
@ -8944,7 +9058,6 @@ static Scheme_Object *write_module(Scheme_Object *obj)
l = cons(scheme_make_integer(cnt), l);
count = m->me->rt->num_provides;
if (m->provide_protects) {
for (i = 0; i < count; i++) {
if (m->provide_protects[i])
@ -8961,16 +9074,39 @@ static Scheme_Object *write_module(Scheme_Object *obj)
} else
l = cons(scheme_false, l);
l = cons(scheme_make_integer(m->num_indirect_provides), l);
count = m->me->et->num_provides;
if (m->et_provide_protects) {
for (i = 0; i < count; i++) {
if (m->et_provide_protects[i])
break;
}
if (i < count) {
v = scheme_make_vector(count, NULL);
for (i = 0; i < count; i++) {
SCHEME_VEC_ELS(v)[i] = (m->et_provide_protects[i] ? scheme_true : scheme_false);
}
} else
v = scheme_false;
l = cons(v, l);
} else
l = cons(scheme_false, l);
count = m->num_indirect_provides;
l = cons(scheme_make_integer(count), l);
v = scheme_make_vector(count, NULL);
for (i = 0; i < count; i++) {
SCHEME_VEC_ELS(v)[i] = m->indirect_provides[i];
}
l = cons(v, l);
count = m->num_indirect_et_provides;
l = cons(scheme_make_integer(count), l);
v = scheme_make_vector(count, NULL);
for (i = 0; i < count; i++) {
SCHEME_VEC_ELS(v)[i] = m->et_indirect_provides[i];
}
l = cons(v, l);
l = cons(m->me->rt->reprovide_kernel ? scheme_true : scheme_false, l);
l = cons(m->me->rt->kernel_exclusion, l);
@ -9017,7 +9153,7 @@ static Scheme_Object *read_module(Scheme_Object *obj)
{
Scheme_Module *m;
Scheme_Object *ie, *nie;
Scheme_Object *esp, *esn, *esph, *es, *esnom, *e, *nve, *ne, **v;
Scheme_Object *eesp, *esp, *esn, *esph, *es, *esnom, *e, *nve, *ne, **v;
Scheme_Module_Exports *me;
Scheme_Module_Phase_Exports *pt;
char *ps, *sps;
@ -9095,6 +9231,24 @@ static Scheme_Object *read_module(Scheme_Object *obj)
count = SCHEME_INT_VAL(nie);
if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL();
v = MALLOC_N(Scheme_Object *, count);
for (i = 0; i < count; i++) {
v[i] = SCHEME_VEC_ELS(ie)[i];
}
m->et_indirect_provides = v;
m->num_indirect_et_provides = count;
if (!SCHEME_PAIRP(obj)) return_NULL();
ie = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return_NULL();
nie = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
count = SCHEME_INT_VAL(nie);
if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL();
v = MALLOC_N(Scheme_Object *, count);
for (i = 0; i < count; i++) {
@ -9103,6 +9257,10 @@ static Scheme_Object *read_module(Scheme_Object *obj)
m->indirect_provides = v;
m->num_indirect_provides = count;
if (!SCHEME_PAIRP(obj)) return_NULL();
eesp = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return_NULL();
esp = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
@ -9230,6 +9388,17 @@ static Scheme_Object *read_module(Scheme_Object *obj)
m->provide_protects = ps;
}
if (SCHEME_FALSEP(eesp)) {
m->et_provide_protects = NULL;
} else {
if (!SCHEME_VECTORP(eesp) || (SCHEME_VEC_SIZE(eesp) != count)) return_NULL();
ps = MALLOC_N_ATOMIC(char, count);
for (i = 0; i < count; i++) {
ps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(eesp)[i]);
}
m->et_provide_protects = ps;
}
if (!SCHEME_PAIRP(obj)) return_NULL();
e = SCHEME_CAR(obj);
if (!SCHEME_VECTORP(e)) return_NULL();

4
src/mzscheme/src/schpriv.h
View File

@ -2563,8 +2563,8 @@ typedef struct Scheme_Module
Scheme_Object *self_modidx;
Scheme_Hash_Table *accessible;
Scheme_Hash_Table *et_accessible;
Scheme_Hash_Table *accessible; /* (symbol -> ...) */
Scheme_Hash_Table *et_accessible; /* phase -> (symbol -> ...) */
Scheme_Object *insp; /* declaration-time inspector, for creating certificates
and for module instantiation */

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "4.1.3.3"
#define MZSCHEME_VERSION "4.1.3.4"
#define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 3
#define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_W 4
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

76
src/mzscheme/src/stxobj.c
View File

@ -185,8 +185,10 @@ typedef struct Scheme_Cert {
/* Certs encoding:
- NULL: no inactive or active certs;
maybe inactive certs in nested parts
- cons(c1, c2): active certs c1 (maybe NULL), inactive certs c2 (maybe NULL);
no inactive certs in nested parts */
- rcons(c1, c2): active certs c1 (maybe NULL), inactive certs c2 (maybe NULL);
maybe inactive certs in nested parts
- immutable-rcons(c1, c2): active certs c1 (maybe NULL), inactive certs c2 (maybe NULL);
no inactive certs in nested parts (using the immutable flag as a hack!) */
#define ACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CAR((stx)->certs) : (stx)->certs) : NULL))
#define INACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CDR((stx)->certs) : NULL) : NULL))
static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp);
@ -557,6 +559,7 @@ void scheme_init_stx(Scheme_Env *env)
REGISTER_SO(no_nested_inactive_certs);
no_nested_inactive_certs = scheme_make_raw_pair(NULL, NULL);
SCHEME_SET_IMMUTABLE(no_nested_inactive_certs);
}
/*========================================================================*/
@ -1983,17 +1986,22 @@ static void phase_shift_certs(Scheme_Object *o, Scheme_Object *owner_wraps, int
icerts = first;
}
/* Even if icerts is NULL, preserve the pair in ->certs,
to indicate no nested inactive certs. */
if (icerts || SCHEME_RPAIRP(((Scheme_Stx *)o)->certs)) {
/* Even if icerts is NULL, may preserve the pair in ->certs,
to indicate no nested inactive certs: */
{
int no_sub = (SCHEME_RPAIRP(((Scheme_Stx *)o)->certs)
&& SCHEME_IMMUTABLEP(((Scheme_Stx *)o)->certs));
if (icerts || no_sub) {
nc = scheme_make_raw_pair((Scheme_Object *)acerts, (Scheme_Object *)icerts);
if (no_sub)
SCHEME_SET_IMMUTABLE(nc);
} else
nc = (Scheme_Object *)acerts;
((Scheme_Stx *)o)->certs = nc;
}
}
}
static Scheme_Object *make_chunk(int len, Scheme_Object *owner_wraps)
/* Result is a single wrap element (possibly a chunk) or a list
@ -2396,7 +2404,6 @@ static Scheme_Cert *append_certs(Scheme_Cert *a, Scheme_Cert *b)
}
static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Object *use_key, int active)
/* If !active, then inactive certs must have been lifted already. */
{
Scheme_Cert *orig_certs, *cl, *now_certs, *next_certs;
Scheme_Stx *stx = (Scheme_Stx *)o, *res;
@ -2469,9 +2476,13 @@ static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Obj
if (!active) {
pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)orig_certs);
res->certs = pr;
if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_IMMUTABLEP(stx->certs))
SCHEME_SET_IMMUTABLE(pr);
} else if (stx->certs && SCHEME_RPAIRP(stx->certs)) {
pr = scheme_make_raw_pair((Scheme_Object *)orig_certs, SCHEME_CDR(stx->certs));
res->certs = pr;
if (SCHEME_IMMUTABLEP(stx->certs))
SCHEME_SET_IMMUTABLE(pr);
} else
res->certs = (Scheme_Object *)orig_certs;
stx = res;
@ -2529,7 +2540,8 @@ Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env
int active)
/* If `name' is module-bound, add the module's certification.
Also copy any certifications from plus_stx.
If active and mark is non-NULL, make inactive certificates active. */
If active and mark is non-NULL, make inactive certificates active.
Existing inactive are lifted when adding from plus_stx_or_certs. */
{
if (mark && active) {
o = scheme_stx_activate_certs(o);
@ -2583,12 +2595,16 @@ Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env
Scheme_Object *pr;
pr = scheme_make_raw_pair((Scheme_Object *)cert, SCHEME_CDR(stx->certs));
res->certs = pr;
if (SCHEME_IMMUTABLEP(stx->certs))
SCHEME_SET_IMMUTABLE(pr);
} else
res->certs = (Scheme_Object *)cert;
} else {
Scheme_Object *pr;
pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)cert);
res->certs = pr;
if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_IMMUTABLEP(stx->certs))
SCHEME_SET_IMMUTABLE(pr);
}
o = (Scheme_Object *)res;
@ -2871,28 +2887,38 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp)
Scheme_Stx *stx = (Scheme_Stx *)o;
if (INACTIVE_CERTS(stx)) {
/* Change inactive certs to active certs. (No
sub-object has inactive certs, because they
are always lifted when inactive certs are added.) */
Scheme_Object *np;
/* Change inactive certs to active certs. */
Scheme_Object *np, *v;
Scheme_Stx *res;
Scheme_Cert *certs;
res = (Scheme_Stx *)scheme_make_stx(stx->val,
if (SCHEME_IMMUTABLEP(stx->certs)) {
/* No sub-object has other inactive certs */
v = stx->val;
} else {
v = stx_activate_certs(stx->val, cp);
}
res = (Scheme_Stx *)scheme_make_stx(v,
stx->srcloc,
stx->props);
res->wraps = stx->wraps;
res->u.lazy_prefix = stx->u.lazy_prefix;
np = scheme_make_raw_pair(SCHEME_CAR(stx->certs), NULL);
if (!ACTIVE_CERTS(stx))
np = no_nested_inactive_certs;
else {
np = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), NULL);
SCHEME_SET_IMMUTABLE(np);
}
res->certs = np;
certs = append_certs(INACTIVE_CERTS(stx), *cp);
*cp = certs;
return (Scheme_Object *)res;
} else if (stx->certs && SCHEME_RPAIRP(stx->certs)) {
/* Explicit pair but NULL for inactive certs means no
inactive certs anywhere in this object. */
} else if (stx->certs && SCHEME_RPAIRP(stx->certs)
&& SCHEME_IMMUTABLEP(stx->certs)) {
/* Explicit pair, but no inactive certs anywhere in this object. */
return (Scheme_Object *)stx;
} else {
o = stx_activate_certs(stx->val, cp);
@ -2904,14 +2930,11 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp)
stx->props);
res->wraps = stx->wraps;
res->u.lazy_prefix = stx->u.lazy_prefix;
/* stx->certs must not be a pair, otherwise we
would have taken an earlier branch; allocate
a pair with an explicitl NULL now to inidicate
that there are no nested certs here */
if (stx->certs) {
if (ACTIVE_CERTS(stx)) {
Scheme_Object *np;
np = scheme_make_raw_pair(stx->certs, NULL);
np = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), NULL);
res->certs = np;
SCHEME_SET_IMMUTABLE(np);
} else
res->certs = no_nested_inactive_certs;
@ -2922,6 +2945,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp)
Scheme_Object *np;
np = scheme_make_raw_pair(stx->certs, NULL);
stx->certs = np;
SCHEME_SET_IMMUTABLE(np);
} else
stx->certs = no_nested_inactive_certs;
@ -2937,6 +2961,8 @@ static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active)
Scheme_Cert *certs = NULL;
o = stx_activate_certs(o, &certs);
/* the inactive certs collected into `certs'
have been stripped from `o' at this point */
if (certs)
o = add_certs(o, certs, NULL, as_active);
@ -6925,10 +6951,8 @@ static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv)
((Scheme_Stx *)src)->props = properties;
}
if (certs) {
src = lift_inactive_certs(src, 0);
if (certs)
src = add_certs(src, (Scheme_Cert *)certs, NULL, 0);
}
return src;
}

4
src/mzscheme/src/syntax.c
View File

@ -5184,6 +5184,10 @@ quote_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_In
/* Push all certificates in the environment down to the syntax object. */
stx = scheme_stx_add_inactive_certs(stx, rec[drec].certs);
if (env->genv->module) {
/* Also certify access to the enclosing module: */
stx = scheme_stx_cert(stx, scheme_false, env->genv, NULL, NULL, 0);
}
if (rec[drec].comp) {
return scheme_register_stx_in_prefix(stx, env, rec, drec);

2
src/worksp/mred/mred.manifest
View File

@ -1,7 +1,7 @@
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assemblyIdentity
version="4.1.3.3"
version="4.1.3.4"
processorArchitecture="X86"
name="Org.PLT-Scheme.MrEd"
type="win32"

8
src/worksp/mred/mred.rc
View File

@ -20,8 +20,8 @@ APPLICATION ICON DISCARDABLE "mred.ico"
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,3
PRODUCTVERSION 4,1,3,3
FILEVERSION 4,1,3,4
PRODUCTVERSION 4,1,3,4
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -39,11 +39,11 @@ BEGIN
VALUE "CompanyName", "PLT Scheme Inc.\0"
VALUE "FileDescription", "PLT Scheme GUI application\0"
VALUE "InternalName", "MrEd\0"
VALUE "FileVersion", "4, 1, 3, 3\0"
VALUE "FileVersion", "4, 1, 3, 4\0"
VALUE "LegalCopyright", "Copyright © 1995-2008\0"
VALUE "OriginalFilename", "MrEd.exe\0"
VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 1, 3, 3\0"
VALUE "ProductVersion", "4, 1, 3, 4\0"
END
END
BLOCK "VarFileInfo"

8
src/worksp/mzcom/mzcom.rc
View File

@ -53,8 +53,8 @@ END
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,3
PRODUCTVERSION 4,1,3,3
FILEVERSION 4,1,3,4
PRODUCTVERSION 4,1,3,4
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -70,12 +70,12 @@ BEGIN
BLOCK "040904b0"
BEGIN
VALUE "FileDescription", "MzCOM Module"
VALUE "FileVersion", "4, 1, 3, 3"
VALUE "FileVersion", "4, 1, 3, 4"
VALUE "InternalName", "MzCOM"
VALUE "LegalCopyright", "Copyright 2000-2008 PLT (Paul Steckler)"
VALUE "OriginalFilename", "MzCOM.EXE"
VALUE "ProductName", "MzCOM Module"
VALUE "ProductVersion", "4, 1, 3, 3"
VALUE "ProductVersion", "4, 1, 3, 4"
END
END
BLOCK "VarFileInfo"

6
src/worksp/mzcom/mzobj.rgs
View File

@ -1,19 +1,19 @@
HKCR
{
MzCOM.MzObj.4.1.3.3 = s 'MzObj Class'
MzCOM.MzObj.4.1.3.4 = s 'MzObj Class'
{
CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
}
MzCOM.MzObj = s 'MzObj Class'
{
CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
CurVer = s 'MzCOM.MzObj.4.1.3.3'
CurVer = s 'MzCOM.MzObj.4.1.3.4'
}
NoRemove CLSID
{
ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class'
{
ProgID = s 'MzCOM.MzObj.4.1.3.3'
ProgID = s 'MzCOM.MzObj.4.1.3.4'
VersionIndependentProgID = s 'MzCOM.MzObj'
ForceRemove 'Programmable'
LocalServer32 = s '%MODULE%'

8
src/worksp/mzscheme/mzscheme.rc
View File

@ -29,8 +29,8 @@ APPLICATION ICON DISCARDABLE "mzscheme.ico"
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,3
PRODUCTVERSION 4,1,3,3
FILEVERSION 4,1,3,4
PRODUCTVERSION 4,1,3,4
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -48,11 +48,11 @@ BEGIN
VALUE "CompanyName", "PLT Scheme Inc.\0"
VALUE "FileDescription", "PLT Scheme application\0"
VALUE "InternalName", "MzScheme\0"
VALUE "FileVersion", "4, 1, 3, 3\0"
VALUE "FileVersion", "4, 1, 3, 4\0"
VALUE "LegalCopyright", "Copyright <20>© 1995-2008\0"
VALUE "OriginalFilename", "mzscheme.exe\0"
VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 1, 3, 3\0"
VALUE "ProductVersion", "4, 1, 3, 4\0"
END
END
BLOCK "VarFileInfo"

8
src/worksp/starters/start.rc
View File

@ -22,8 +22,8 @@ APPLICATION ICON DISCARDABLE "mzstart.ico"
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,3
PRODUCTVERSION 4,1,3,3
FILEVERSION 4,1,3,4
PRODUCTVERSION 4,1,3,4
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -45,7 +45,7 @@ BEGIN
#ifdef MZSTART
VALUE "FileDescription", "PLT Scheme Launcher\0"
#endif
VALUE "FileVersion", "4, 1, 3, 3\0"
VALUE "FileVersion", "4, 1, 3, 4\0"
#ifdef MRSTART
VALUE "InternalName", "mrstart\0"
#endif
@ -60,7 +60,7 @@ BEGIN
VALUE "OriginalFilename", "MzStart.exe\0"
#endif
VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 1, 3, 3\0"
VALUE "ProductVersion", "4, 1, 3, 4\0"
END
END
BLOCK "VarFileInfo"