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

Sync up to trunk.

Browse Source 
svn: r18386
This commit is contained in:
Stevie Strickland 2010-02-27 19:16:28 +00:00
commit 3f0f5373dd
43 changed files with 616 additions and 1036 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/drscheme/private/module-browser.ss
View File

@ -712,16 +712,41 @@
(label "")
(parent vp)
(stretchable-width #t)))
(define font/label-panel (new horizontal-panel%
[parent vp]
[stretchable-height #f]))
(define font-size-gauge
(instantiate slider% ()
(label font-size-gauge-label)
(min-value 1)
(max-value 72)
(init-value (preferences:get 'drscheme:module-overview:label-font-size))
(parent vp)
(parent font/label-panel)
(callback
(λ (x y)
(send pasteboard set-label-font-size (send font-size-gauge get-value))))))
(define module-browser-name-length-choice
(new choice%
(parent font/label-panel)
(label (string-constant module-browser-name-length))
(choices (list (string-constant module-browser-name-long)
(string-constant module-browser-name-very-long)))
(selection (case (preferences:get 'drscheme:module-browser:name-length)
[(0) 0]
[(1) 0]
[(2) 0]
[(3) 1]))
(callback
(λ (x y)
;; note: the preference drscheme:module-browser:name-length is also used for the View|Show Module Browser version of the module browser
;; here we just treat any pref value except '3' as if it were for the long names.
(let ([selection (send module-browser-name-length-choice get-selection)])
(preferences:set 'drscheme:module-browser:name-length (+ 2 selection))
(send pasteboard set-name-length
(case selection
[(0) 'long]
[(1) 'very-long])))))))
(define lib-paths-checkbox
(instantiate check-box% ()
(label lib-paths-checkbox-constant)
@ -746,6 +771,12 @@
(format filename-constant fn lines))))
(send label-message set-label ""))))
(send pasteboard set-name-length
(case (preferences:get 'drscheme:module-browser:name-length)
[(0) 'long]
[(1) 'long]
[(2) 'long]
[(3) 'very-long]))
;; shouldn't be necessary here -- need to find callback on editor
(send pasteboard render-snips)

2
collects/drscheme/private/unit.ss
View File

@ -3247,7 +3247,7 @@ module browser threading seems wrong.
[lang (drscheme:language-configuration:language-settings-language lang/config)]
[strs (send lang get-language-position)]
[can-browse?
(or (regexp-match #rx"Module" (last strs))
(or (is-a? lang drscheme:module-language:module-language<%>)
(ormap (λ (x) (regexp-match #rx"PLT" x))
strs))])
(unless can-browse?

2
collects/mzlib/port.ss
View File

@ -2,7 +2,7 @@
(require (for-syntax scheme/base)
mzlib/etc
scheme/contract
scheme/contract/base
mzlib/list
"private/port.ss")

2
collects/mzlib/private/contract-define.ss
View File

@ -5,7 +5,7 @@
(require (for-syntax scheme/base
unstable/srcloc
(prefix-in a: scheme/contract/private/helpers))
(only-in scheme/contract contract))
(only-in scheme/contract/private/base contract))
;; First, we have the old define/contract implementation, which
;; is still used in mzlib/contract.

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

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "26feb2010")
#lang scheme/base (provide stamp) (define stamp "27feb2010")

397
collects/scheme/contract/regions.ss
View File

@ -9,8 +9,11 @@
scheme/struct-info
syntax/define
syntax/kerncase
syntax/parse
unstable/syntax
(prefix-in a: "private/helpers.ss"))
scheme/splicing
scheme/stxparam
"private/arrow.ss"
"private/base.ss"
"private/guts.ss")
@ -45,55 +48,50 @@
;; defines `id' with `contract'; initially binding
;; it to the result of `expr'. These variables may not be set!'d.
(define-syntax (define/contract define-stx)
(when (eq? (syntax-local-context) 'expression)
(define-splicing-syntax-class fv-clause
#:description "a free variable clause"
#:attributes ([var 1] [ctc 1])
[pattern (~seq #:freevars ([var:id ctc:expr] ...))]
[pattern (~seq #:freevar v:id c:expr)
#:with (var ...) (list #'v)
#:with (ctc ...) (list #'c)])
(define-splicing-syntax-class fvs
#:description "a sequence of free variable clauses"
#:attributes ([var 1] [ctc 1])
[pattern (~seq f:fv-clause ...)
#:with (var ...) #'(f.var ... ...)
#:with (ctc ...) #'(f.ctc ... ...)
#:fail-when (check-duplicate-identifier (syntax->list #'(var ...)))
(format "duplicate imported name ~a"
(syntax-e (check-duplicate-identifier (syntax->list #'(var ...)))))])
(when (memq (syntax-local-context) '(expression module-begin))
(raise-syntax-error 'define/contract
"used in expression context"
"not used in definition context"
define-stx))
(syntax-case define-stx ()
[(_ name)
(raise-syntax-error 'define/contract
"no contract or body"
define-stx)]
[(_ name contract-expr)
(raise-syntax-error 'define/contract
"expected a contract expression and a definition body, but found only one expression"
define-stx)]
[(_ name+arg-list contract #:freevars args . body)
(identifier? #'args)
(raise-syntax-error 'define/contract
"expected list of identifier/contract pairs"
#'args)]
[(_ name+arg-list contract #:freevars (arg ...) #:freevar x c . body)
(syntax-parse define-stx
[(_ name:id contract fv:fvs body)
(syntax/loc define-stx
(define/contract name+arg-list contract #:freevars (arg ... [x c]) . body))]
[(_ name+arg-list contract #:freevar x c . body)
(syntax/loc define-stx
(define/contract name+arg-list contract #:freevars () #:freevar x c . body))]
[(_ name+arg-list contract #:freevars args body0 body ...)
(begin
(when (and (identifier? #'name+arg-list)
(not (null? (syntax->list #'(body ...)))))
(raise-syntax-error 'define/contract
"multiple expressions after identifier and contract"
#'(body ...)))
(let-values ([(name body-expr)
(if (identifier? #'name+arg-list)
(values #'name+arg-list #'body0)
(normalize-definition
(datum->syntax #'define-stx (list* 'define/contract #'name+arg-list
#'body0 #'(body ...)))
#'lambda #t #t))])
(with-syntax ([name name]
[body-expr body-expr]
[type (if (identifier? #'name+arg-list) 'definition 'function)])
(syntax/loc define-stx
(with-contract #:type type name
([name contract])
#:freevars args
(define name body-expr))))))]
[(_ name+arg-list contract body0 body ...)
(syntax/loc define-stx
(define/contract name+arg-list contract #:freevars () body0 body ...))]))
(with-contract #:region definition name
([name contract])
#:freevars ([fv.var fv.ctc] ...)
(define name body)))]
[(_ name:id contract fv:fvs body0 body ...)
(raise-syntax-error 'define/contract
"multiple expressions after identifier and contract"
#'(body ...))]
[(_ name+arg-list contract fv:fvs body0 body ...)
(let-values ([(name body-expr)
(normalize-definition
(datum->syntax #'define-stx (list* 'define/contract #'name+arg-list
#'body0 #'(body ...)))
#'lambda #t #t)])
(with-syntax ([name name]
[body-expr body-expr])
(syntax/loc define-stx
(with-contract #:region function name
([name contract])
#:freevars ([fv.var fv.ctc] ...)
(define name body-expr)))))]))
(define-syntax (define-struct/contract stx)
(define-struct field-info (stx ctc [mutable? #:mutable] auto?))
@ -337,7 +335,7 @@
(values super-fields ... non-auto-name ...))
(define blame-id
(current-contract-region))
(with-contract #:type struct struct-name
(with-contract #:region struct struct-name
ctc-bindings
(define-struct/derived orig name (field ...)
kwds ...
@ -372,59 +370,25 @@
;
;
(define-for-syntax (make-contracted-id-transformer id contract-stx pos-blame-id neg-blame-id)
(make-set!-transformer
(lambda (stx)
(syntax-case stx (set!)
[(set! i arg)
(quasisyntax/loc stx
(set! #,id
(contract #,contract-stx
arg
#,neg-blame-id
#,pos-blame-id
(quote #,id)
(quote-syntax #,id))))]
[(f arg ...)
(quasisyntax/loc stx
((contract #,contract-stx
#,id
#,pos-blame-id
#,neg-blame-id
(quote #,id)
(quote-syntax #,id))
arg ...))]
[ident
(identifier? (syntax ident))
(quasisyntax/loc stx
(contract #,contract-stx
#,id
#,pos-blame-id
#,neg-blame-id
(quote #,id)
(quote-syntax #,id)))]))))
(define-for-syntax (check-and-split-with-contracts args)
(let loop ([args args]
[protected null]
[protections null])
(cond
[(null? args)
(values protected protections)]
[(let ([lst (syntax->list (car args))])
(and (list? lst)
(= (length lst) 2)
(identifier? (first lst))
lst))
=>
(lambda (l)
(loop (cdr args)
(cons (first l) protected)
(cons (second l) protections)))]
[else
(raise-syntax-error 'with-contract
"expected (identifier contract)"
(car args))])))
(define-for-syntax (make-contracted-id-transformer id contract-stx pos-blame-stx neg-blame-stx)
(with-syntax ([ctc contract-stx]
[id id]
[pos pos-blame-stx]
[neg neg-blame-stx])
(make-set!-transformer
(lambda (stx)
(syntax-case stx (set!)
[(set! i arg)
(quasisyntax/loc stx
(set! id (contract ctc arg neg pos (quote id) (quote-syntax id))))]
[(f arg ...)
(quasisyntax/loc stx
((contract ctc id pos neg (quote id) (quote-syntax id))
arg ...))]
[ident
(identifier? (syntax ident))
(quasisyntax/loc stx
(contract ctc id pos neg (quote id) (quote-syntax id)))])))))
(define-syntax (with-contract-helper stx)
(syntax-case stx ()
@ -467,39 +431,110 @@
(with-contract-helper (p ...) body ...)))]))]))
(define-syntax (with-contract stx)
(when (eq? (syntax-local-context) 'expression)
(raise-syntax-error 'with-contract
"used in expression context"
stx))
(syntax-case stx ()
[(_ #:type type etc ...)
(not (identifier? #'type))
(raise-syntax-error 'with-contract
"expected identifier for type"
#'type)]
[(_ #:type type args etc ...)
(not (identifier? #'args))
(raise-syntax-error 'with-contract
"expected identifier for blame"
#'args)]
[(_ #:type type blame (arg ...) #:freevars (fv ...) #:freevar x c . body)
(identifier? #'x)
(syntax/loc stx
(with-contract #:type type blame (arg ...) #:freevars (fv ... [x c]) . body))]
[(_ #:type type blame (arg ...) #:freevars (fv ...) #:freevar x c . body)
(raise-syntax-error 'with-contract
"use of #:freevar with non-identifier"
#'x)]
[(_ #:type type blame (arg ...) #:freevars (fv ...) . body)
(and (identifier? #'blame)
(identifier? #'type))
(define-splicing-syntax-class region-clause
#:description "contract region type"
[pattern (~seq #:region region:id)])
(define-splicing-syntax-class fv-clause
#:description "a free variable clause"
#:attributes ([var 1] [ctc 1])
[pattern (~seq #:freevars ([var:id ctc:expr] ...))]
[pattern (~seq #:freevar v:id c:expr)
#:with (var ...) (list #'v)
#:with (ctc ...) (list #'c)])
(define-splicing-syntax-class fvs
#:description "a sequence of free variable clauses"
#:attributes ([var 1] [ctc 1])
[pattern (~seq f:fv-clause ...)
#:with (var ...) #'(f.var ... ...)
#:with (ctc ...) #'(f.ctc ... ...)
#:fail-when (check-duplicate-identifier (syntax->list #'(var ...)))
(format "duplicate imported name ~a"
(syntax-e (check-duplicate-identifier (syntax->list #'(var ...)))))])
(define-syntax-class export-clause
#:description "a name/contract pair"
[pattern (var:id ctc:expr)])
(define-syntax-class exports-clause
#:attributes ([var 1] [ctc 1])
#:description "a sequence of name/contract pairs"
[pattern (ec:export-clause ...)
#:with (var ...) #'(ec.var ...)
#:with (ctc ...) #'(ec.ctc ...)
#:fail-when (check-duplicate-identifier (syntax->list #'(var ...)))
(format "duplicate exported name ~a"
(syntax-e (check-duplicate-identifier (syntax->list #'(var ...)))))])
(define-splicing-syntax-class result-clause
#:description "a results clause"
[pattern (~seq #:result ctc:expr)])
(syntax-parse stx
[(_ (~optional :region-clause #:defaults ([region #'region])) blame:id rc:result-clause fv:fvs . body)
(if (not (eq? (syntax-local-context) 'expression))
(quasisyntax/loc stx (#%expression #,stx))
(let*-values ([(intdef) (syntax-local-make-definition-context)]
[(ctx) (list (gensym 'intdef))]
[(cid-marker) (make-syntax-introducer)]
[(free-vars free-ctcs)
(values (syntax->list #'(fv.var ...))
(syntax->list #'(fv.ctc ...)))])
(define (add-context stx)
(let ([ctx-added-stx (local-expand #`(quote #,stx)
ctx
(list #'quote)
intdef)])
(syntax-case ctx-added-stx ()
[(_ expr) #'expr])))
(syntax-local-bind-syntaxes free-vars #f intdef)
(internal-definition-context-seal intdef)
(with-syntax ([blame-stx #''(region blame)]
[blame-id (generate-temporary)]
[(free-var ...) free-vars]
[(free-var-id ...) (add-context #`#,free-vars)]
[(free-ctc-id ...) (map cid-marker free-vars)]
[(free-ctc ...) (map (λ (c v)
(syntax-property c 'inferred-name v))
free-ctcs
free-vars)])
(with-syntax ([new-stx (add-context #'(syntax-parameterize
([current-contract-region (λ (stx) #'blame-stx)])
(contract (verify-contract 'with-contract rc.ctc)
(let () . body)
blame-stx
blame-id)))])
(quasisyntax/loc stx
(let ()
(define-values (free-ctc-id ...)
(values (verify-contract 'with-contract free-ctc) ...))
(define blame-id
(current-contract-region))
(define-values ()
(begin (contract free-ctc-id
free-var
blame-id
'cant-happen
(quote free-var)
(quote-syntax free-var))
...
(values)))
(define-syntaxes (free-var-id ...)
(values (make-contracted-id-transformer
(quote-syntax free-var)
(quote-syntax free-ctc-id)
(quote-syntax blame-id)
(quote-syntax blame-stx)) ...))
new-stx))))))]
[(_ (~optional :region-clause #:defaults ([region #'region])) blame:id ec:exports-clause fv:fvs . body)
(when (memq (syntax-local-context) '(expression module-begin))
(raise-syntax-error 'with-contract
"not used in definition context"
stx))
(let*-values ([(intdef) (syntax-local-make-definition-context)]
[(ctx) (list (gensym 'intdef))]
[(cid-marker) (make-syntax-introducer)]
[(free-vars free-ctcs)
(check-and-split-with-contracts (syntax->list #'(fv ...)))]
(values (syntax->list #'(fv.var ...))
(syntax->list #'(fv.ctc ...)))]
[(protected protections)
(check-and-split-with-contracts (syntax->list #'(arg ...)))])
(values (syntax->list #'(ec.var ...))
(syntax->list #'(ec.ctc ...)))])
(define (add-context stx)
(let ([ctx-added-stx (local-expand #`(quote #,stx)
ctx
@ -507,20 +542,11 @@
intdef)])
(syntax-case ctx-added-stx ()
[(_ expr) #'expr])))
(when (eq? (syntax-local-context) 'expression)
(raise-syntax-error 'with-contract
"cannot use in an expression context"
stx))
(let ([dupd-id (check-duplicate-identifier protected)])
(when dupd-id
(raise-syntax-error 'with-contract
"identifier appears twice in exports"
dupd-id)))
(syntax-local-bind-syntaxes protected #f intdef)
(syntax-local-bind-syntaxes free-vars #f intdef)
(internal-definition-context-seal intdef)
(with-syntax ([blame-stx #''(type blame)]
[blame-id (car (generate-temporaries (list #t)))]
(with-syntax ([blame-stx #''(region blame)]
[blame-id (generate-temporary)]
[(free-var ...) free-vars]
[(free-var-id ...) (add-context #`#,free-vars)]
[(free-ctc-id ...) (map cid-marker free-vars)]
@ -539,58 +565,41 @@
([current-contract-region (λ (stx) #'blame-stx)])
. body))])
(quasisyntax/loc stx
(begin
(define-values (free-ctc-id ...)
(values (verify-contract 'with-contract free-ctc) ...))
(define blame-id
(current-contract-region))
(define-values ()
(begin (contract free-ctc-id
free-var
blame-id
'cant-happen
(quote free-var)
(quote-syntax free-var))
...
(values)))
(define-syntaxes (free-var-id ...)
(values (make-contracted-id-transformer
(quote-syntax free-var)
(quote-syntax free-ctc-id)
(quote-syntax blame-id)
(quote-syntax blame-stx)) ...))
(with-contract-helper (marked-p ...) new-stx)
(define-values (ctc-id ...)
(values (verify-contract 'with-contract ctc) ...))
(define-values ()
(begin (contract ctc-id
marked-p
blame-stx
'cant-happen
(quote marked-p)
(quote-syntax marked-p))
...
(values)))
(define-syntaxes (p ...)
(values (make-contracted-id-transformer
(quote-syntax marked-p)
(quote-syntax ctc-id)
(quote-syntax blame-stx)
(quote-syntax blame-id)) ...)))))))]
[(_ #:type type blame (arg ...) #:freevar x c . body)
(syntax/loc stx
(with-contract #:type type blame (arg ...) #:freevars ([x c]) . body))]
[(_ #:type type blame (arg ...) . body)
(syntax/loc stx
(with-contract #:type type blame (arg ...) #:freevars () . body))]
[(_ #:type type blame bad-args etc ...)
(raise-syntax-error 'with-contract
"expected list of identifier and/or (identifier contract)"
#'bad-args)]
[(_ #:type type blame)
(raise-syntax-error 'with-contract
"only blame"
stx)]
[(_ etc ...)
(syntax/loc stx
(with-contract #:type region etc ...))]))
(begin
(define-values (free-ctc-id ...)
(values (verify-contract 'with-contract free-ctc) ...))
(define blame-id
(current-contract-region))
(define-values ()
(begin (contract free-ctc-id
free-var
blame-id
'cant-happen
(quote free-var)
(quote-syntax free-var))
...
(values)))
(define-syntaxes (free-var-id ...)
(values (make-contracted-id-transformer
(quote-syntax free-var)
(quote-syntax free-ctc-id)
(quote-syntax blame-id)
(quote-syntax blame-stx)) ...))
(with-contract-helper (marked-p ...) new-stx)
(define-values (ctc-id ...)
(values (verify-contract 'with-contract ctc) ...))
(define-values ()
(begin (contract ctc-id
marked-p
blame-stx
'cant-happen
(quote marked-p)
(quote-syntax marked-p))
...
(values)))
(define-syntaxes (p ...)
(values (make-contracted-id-transformer
(quote-syntax marked-p)
(quote-syntax ctc-id)
(quote-syntax blame-stx)
(quote-syntax blame-id)) ...)))))))]))

2
collects/scheme/unit.ss
View File

@ -1,7 +1,7 @@
(module unit scheme/base
(require mzlib/unit
scheme/contract
scheme/contract/base
(for-syntax scheme/base
syntax/struct))
(provide (except-out (all-from-out mzlib/unit)

8
collects/scribblings/guide/scripts.scrbl
View File

@ -5,9 +5,9 @@
@title[#:tag "scripts"]{Scripts}
Scheme files can be turned into executable scripts on Unix and Mac OS
X. On Windows, one option is to use a compatibility layer like Cygwin,
or write scripts as batch files.
Scheme files can be turned into executable scripts under Unix and Mac
OS X. Under Windows, a compatibility layer like Cygwin support the
same kind of scripts, or scripts can be implemented as batch files.
@section{Unix Scripts}
@ -119,7 +119,7 @@ the script file turns out to be valid input to both @exec{/bin/sh} and
@section{Windows Batch Files}
A similar trick can be used to write Scheme code in Windows
@as-index{@tt{batch}} files:
@as-index{@tt{.bat}} batch files:
@verbatim[#:indent 2]|{
; @echo off

24
collects/scribblings/reference/contracts.scrbl
View File

@ -743,20 +743,28 @@ expression to new contracts that hide the values they accept and
ensure that the exported functions are treated parametrically.
}
@defform/subs[
(with-contract blame-id (wc-export ...) free-var-list body ...+)
@defform*/subs[
[(with-contract blame-id (wc-export ...) free-var-list ... body ...+)
(with-contract blame-id result-spec free-var-list ... body ...+)]
([wc-export
(id contract-expr)]
[result-spec
(code:line #:result contract-expr)]
[free-var-list
code:blank
(code:line #:freevars ([id contract-expr] ...))
(code:line #:freevar id contract-expr)])]{
Generates a local contract boundary. The @scheme[contract-expr]
form cannot appear in expression position. The @scheme[body] of the
form allows definition/expression interleaving like a @scheme[module]
body. All names defined within the @scheme[with-contract] form are
Generates a local contract boundary.
The first @scheme[with-contract] form cannot appear in expression position.
All names defined within the first @scheme[with-contract] form are
visible externally, but those names listed in the @scheme[wc-export]
list are protected with the corresponding contract.
list are protected with the corresponding contract. The @scheme[body] of
the form allows definition/expression interleaving if its context does.
The second @scheme[with-contract] form must appear in expression position.
The result of the final @scheme[body] expression is contracted with
the contract listed in the @scheme[result-spec]. The sequence of @scheme[body]
forms is treated as for @scheme[let].
The @scheme[blame-id] is used for the positive positions of
contracts paired with exported @scheme[id]s. Contracts broken

10
collects/scribblings/reference/numbers.scrbl
View File

@ -589,9 +589,9 @@ produces @scheme[+nan.0] in the case that neither @scheme[y] nor
Returns @scheme[#t] when the @scheme[m]th bit of @scheme[n] is set in @scheme[n]'s
(semi-infinite) two's complement representation.
This is equivalent to
This operation is equivalent to
@scheme[(not (zero? (bitwise-and n (arithmetic-shift 1 m))))],
but is faster and runs in constant time when @scheme[n] is positive.
but it is faster and runs in constant time when @scheme[n] is positive.
@mz-examples[(bitwise-bit-set? 5 0) (bitwise-bit-set? 5 2) (bitwise-bit-set? -5 (expt 2 700))]}
@ -605,7 +605,7 @@ but is faster and runs in constant time when @scheme[n] is positive.
Extracts the bits between position @scheme[start] and @scheme[(- end 1)] (inclusive)
from @scheme[n] and shifts them down to the least significant portion of the number.
This is equivalent to this computation,
This operation is equivalent to the computation
@schemeblock[
(bitwise-and (sub1 (arithmetic-shift 1 (- end start)))
@ -616,8 +616,8 @@ but it runs in constant time when @scheme[n] is positive, @scheme[start] and
@scheme[end] are fixnums, and @scheme[(- end start)] is no more than
the maximum width of a fixnum.
Each pair of examples below uses the same numbers, but shows the result in
both binary and as integers.
Each pair of examples below uses the same numbers, showing the result
both in binary and as integers.
@mz-examples[(format "~b" (bitwise-bit-field (string->number "1101" 2) 1 1))
(bitwise-bit-field 13 1 1)

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

@ -48,6 +48,12 @@ that they appear as @scheme[v]s, so in the first two cases, an earlier
element that is @scheme[equal?] or @scheme[eqv?] but not @scheme[eq?]
to a later element takes precedence over the later element.}
@defproc[(set-empty? [set set?]) boolean?]{
Returns @scheme[#t] if @scheme[set] has no members, @scheme[@f]
otherwise.}
@defproc[(set-member? [set set?] [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is in @scheme[set], @scheme[#f]

2
collects/string-constants/english-string-constants.ss
View File

@ -1185,7 +1185,7 @@ please adhere to these guidelines:
(module-browser-laying-out-graph-label "Laying out graph")
(module-browser-open-file-format "Open ~a")
(module-browser "Module Browser") ;; frame title
(module-browser... "Module Browser...") ;; menu item title
(module-browser... "&Module Browser...") ;; menu item title
(module-browser-error-expanding "Error expanding the program:\n\n~a")
(module-browser-show-lib-paths "Show files loaded by (lib ..) paths")
(module-browser-progress "Module Browser: ~a") ;; prefix in the status line

2
collects/syntax/id-table.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base
(require (for-syntax scheme/base)
scheme/contract
scheme/contract/base
scheme/dict
"private/id-table.ss")
#|

2
collects/syntax/keyword.ss
View File

@ -1,5 +1,5 @@
#lang scheme/base
(require scheme/contract
(require scheme/contract/base
scheme/dict
"private/keyword.ss")

2
collects/syntax/modcollapse.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base
(require scheme/contract
(require scheme/contract/base
"private/modcollapse-noctc.ss")
(define simple-rel-to-module-path-v/c

2
collects/syntax/modresolve.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base
(require scheme/contract
(require scheme/contract/base
"private/modhelp.ss")
(define (force-relto relto dir?)

58
collects/tests/mzscheme/contract-test.ss
View File

@ -2878,7 +2878,7 @@
;
(test/spec-passed
'with-contract1
'with-contract-def-1
'(let ()
(with-contract odd-even
([oddp (-> number? boolean?)]
@ -2890,7 +2890,7 @@
(oddp 5)))
(test/spec-failed
'with-contract2
'with-contract-def-2
'(let ()
(with-contract odd-even
([oddp (-> number? boolean?)]
@ -2903,7 +2903,7 @@
"top-level")
(test/spec-failed
'with-contract3
'with-contract-def-3
'(let ()
(with-contract odd-even
([oddp (-> number? boolean?)]
@ -2920,7 +2920,7 @@
;; call odd? with a boolean, even though its contract in
;; the odd-even contract says it only takes numbers.
(test/spec-passed
'with-contract4
'with-contract-def-4
'(let ()
(with-contract odd-even
([oddp (-> number? boolean?)]
@ -2935,7 +2935,7 @@
(oddp 5)))
(test/spec-passed
'with-contract5
'with-contract-def-5
'(let ()
(with-contract region1
([x (-> number? number?)])
@ -2946,7 +2946,7 @@
(x 4)))
(test/spec-failed
'with-contract6
'with-contract-def-6
'(let ()
(with-contract region1
([x (-> number? number?)])
@ -2958,7 +2958,7 @@
"(region region1)")
(test/spec-failed
'with-contract7
'with-contract-def-7
'(let ()
(with-contract region1
([x (-> number? number?)])
@ -2970,7 +2970,7 @@
"(region region1)")
(test/spec-failed
'with-contract8
'with-contract-def-8
'(let ()
(with-contract region1
([x (-> number? number?)])
@ -2983,14 +2983,14 @@
;; make sure uncontracted exports make it out
(test/spec-passed
'with-contract9
'with-contract-def-9
'(let ()
(with-contract region1 ()
(define f 3))
f))
(test/spec-failed
'with-contract10
'with-contract-def-10
'(let ()
(with-contract r
([x number?])
@ -3001,7 +3001,7 @@
"(region r)")
(test/spec-failed
'with-contract11
'with-contract-def-11
'(let ()
(with-contract r
([x number?])
@ -3009,6 +3009,42 @@
(set! x #f)
x)
"top-level")
(test/spec-passed
'with-contract-exp-1
'(with-contract r
#:result number?
3))
(test/spec-failed
'with-contract-exp-2
'(with-contract r
#:result number?
"foo")
"(region r)")
(test/spec-passed
'with-contract-exp-3
'((with-contract r
#:result (-> number? number?)
(λ (x) 5))
3))
(test/spec-failed
'with-contract-exp-4
'((with-contract r
#:result (-> number? number?)
(λ (x) (zero? x)))
3)
"(region r)")
(test/spec-failed
'with-contract-exp-5
'((with-contract r
#:result (-> number? number?)
(λ (x) 5))
#t)
"top-level")
;
;

8
collects/tests/typed-scheme/fail/with-type1.ss Normal file
View File

@ -0,0 +1,8 @@
#;
(exn-pred exn:fail:contract?)
#lang scheme
(require typed/scheme)
((with-type (Number -> Number)
(lambda: ([x : Number]) (add1 x)))
#f)

10
collects/tests/typed-scheme/fail/with-type2.ss Normal file
View File

@ -0,0 +1,10 @@
#;
(exn-pred exn:fail:contract?)
#lang scheme
(require typed/scheme)
(let ([x 'hello])
(with-type String
#:freevars ([x String])
(string-append x ", world")))

11
collects/tests/typed-scheme/main.ss
View File

@ -48,7 +48,7 @@
#:when (scheme-file? p)
;; skip backup files
#:when (not (regexp-match #rx".*~" (path->string p))))
(test-case
(test-suite
(path->string p)
(test
(build-path path p)
@ -72,9 +72,10 @@
dr
(lambda (p thnk)
(define-values (pred info) (exn-pred p))
(with-check-info
(['predicates info])
(check-exn pred thnk)))))
(parameterize ([error-display-handler void])
(with-check-info
(['predicates info])
(check-exn pred thnk))))))
(define int-tests
(test-suite "Integration tests"
@ -86,7 +87,7 @@
unit-tests int-tests))
(define (go) (test/gui tests))
(define (go/text) (run-tests tests))
(define (go/text) (run-tests tests 'verbose))
(provide go go/text)

3
collects/tests/typed-scheme/run.ss
View File

@ -2,6 +2,5 @@
(require "main.ss")
(current-namespace (make-base-namespace))
(unless (= 0 (parameterize ([error-display-handler void])
(go/text)))
(unless (= 0 (go/text))
(error "Typed Scheme Tests did not pass."))

9
collects/tests/typed-scheme/succeed/with-type.ss Normal file
View File

@ -0,0 +1,9 @@
#lang scheme
(require typed/scheme)
(with-type Number 3)
(let ([x "hello"])
(with-type String
#:freevars ([x String])
(string-append x ", world")))

26
collects/typed-scheme/env/type-env.ss vendored
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require "../utils/utils.ss"
syntax/boundmap
syntax/id-table
(utils tc-utils)
(types utils))
@ -11,21 +11,22 @@
register-type/undefined
lookup-type
register-types
unregister-type
check-all-registered-types
type-env-map)
;; module-identifier-mapping from id -> type or Box[type]
;; free-id-table from id -> type or Box[type]
;; where id is a variable, and type is the type of the variable
;; if the result is a box, then the type has not actually been defined, just registered
(define the-mapping (make-module-identifier-mapping))
(define the-mapping (make-free-id-table))
;; add a single type to the mapping
;; identifier type -> void
(define (register-type id type)
(module-identifier-mapping-put! the-mapping id type))
(free-id-table-set! the-mapping id type))
(define (register-type-if-undefined id type)
(if (module-identifier-mapping-get the-mapping id (lambda _ #f))
(if (free-id-table-ref the-mapping id (lambda _ #f))
(tc-error/stx id "Duplicate type annotation for ~a" (syntax-e id))
(register-type id type)))
@ -33,9 +34,9 @@
;; identifier type -> void
(define (register-type/undefined id type)
;(printf "register-type/undef ~a~n" (syntax-e id))
(if (module-identifier-mapping-get the-mapping id (lambda _ #f))
(if (free-id-table-ref the-mapping id (lambda _ #f))
(tc-error/stx id "Duplicate type annotation for ~a" (syntax-e id))
(module-identifier-mapping-put! the-mapping id (box type))))
(free-id-table-set! the-mapping id (box type))))
;; add a bunch of types to the mapping
;; listof[id] listof[type] -> void
@ -46,21 +47,24 @@
;; if none found, calls lookup-fail
;; identifier -> type
(define (lookup-type id [fail-handler (lambda () (lookup-type-fail id))])
(let ([v (module-identifier-mapping-get the-mapping id fail-handler)])
(let ([v (free-id-table-ref the-mapping id fail-handler)])
(if (box? v) (unbox v) v)))
(define (maybe-finish-register-type id)
(let ([v (module-identifier-mapping-get the-mapping id)])
(let ([v (free-id-table-ref the-mapping id)])
(if (box? v)
(register-type id (unbox v))
#f)))
(define (unregister-type id)
(free-id-table-remove! the-mapping id))
(define (finish-register-type id)
(unless (maybe-finish-register-type id)
(tc-error/stx id "Duplicate defintion for ~a" (syntax-e id))))
(define (check-all-registered-types)
(module-identifier-mapping-for-each
(free-id-table-for-each
the-mapping
(lambda (id e)
(when (box? e)
@ -74,4 +78,4 @@
;; map over the-mapping, producing a list
;; (id type -> T) -> listof[T]
(define (type-env-map f)
(module-identifier-mapping-map the-mapping f))
(free-id-table-map the-mapping f))

2
collects/typed-scheme/main.ss
View File

@ -18,4 +18,4 @@
(for-syntax "private/base-types-extra.ss"))
(provide (rename-out [with-handlers: with-handlers] [real? number?])
(for-syntax (all-from-out "private/base-types-extra.ss"))
assert)
assert with-type)

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

@ -12,7 +12,8 @@
string-constants/string-constant
;(prefix-in ce: test-engine/scheme-tests)
(for-syntax
scheme/base syntax/parse mzlib/etc
scheme/base syntax/parse
(only-in unstable/syntax syntax-local-eval)
(utils tc-utils)
(env init-envs)
(except-in (rep filter-rep object-rep type-rep) make-arr)
@ -106,7 +107,8 @@
(define-syntax (define-initial-env stx)
(syntax-case stx ()
[(_ initial-env make-promise-ty language-ty qq-append-ty cl ...)
[(_ initial-env make-promise-ty language-ty qq-append-ty
[id-expr ty] ...)
(with-syntax ([(_ make-promise . _)
(local-expand #'(delay 3)
'expression
@ -118,13 +120,16 @@
[(_ qq-append . _)
(local-expand #'`(,@'() 1)
'expression
null)])
null)]
[(id ...)
(for/list ([expr (syntax->list #'(id-expr ...))])
(syntax-local-eval expr))])
#`(define-for-syntax initial-env
(make-env
[make-promise make-promise-ty]
[language language-ty]
[qq-append qq-append-ty]
cl ...)))]))
[id ty] ...)))]))
@ -140,12 +145,11 @@
(-> (-lst a) (-val '()) (-lst a))
(-> (-lst a) (-lst b) (-lst (*Un a b)))))
;; make-sequence
[(begin-lifted
(syntax-parse (local-expand #'(for ([x '()]) x) 'expression #f)
#:context #'make-sequence
#:literals (let-values quote)
[(let-values ([_ (m-s '(_) '())]) . _)
#'m-s]))
[(syntax-parse (local-expand #'(for ([x '()]) x) 'expression #f)
#:context #'make-sequence
#:literals (let-values quote)
[(let-values ([_ (m-s '(_) '())]) . _)
#'m-s])
(-poly (a)
(let ([seq-vals
(lambda ([a a])
@ -161,9 +165,9 @@
(-> Univ -String (seq-vals -Char))
(-> Univ -Bytes (seq-vals -Nat))
(-> Univ -Input-Port (seq-vals -Nat)))))])
(begin-for-syntax
(initialize-type-env initial-env/special-case)

93
collects/typed-scheme/private/with-types.ss Normal file
View File

@ -0,0 +1,93 @@
#lang scheme/base
(require (for-syntax scheme/base syntax/parse mzlib/etc scheme/match)
scheme/require
"base-env.ss"
"base-special-env.ss"
"base-env-numeric.ss"
"base-env-indexing-old.ss"
"extra-procs.ss"
"prims.ss"
"base-types.ss"
scheme/contract/regions scheme/contract/base
(for-syntax "base-types-extra.ss")
(for-syntax (except-in (path-up "utils/utils.ss") infer)
(path-up "utils/tc-utils.ss")
(except-in (combine-in (path-up "types/convenience.ss") (path-up "types/abbrev.ss")) ->)
(path-up "types/utils.ss")
(path-up "infer/infer.ss")
(path-up "env/type-env.ss")
(path-up "env/type-environments.ss")
(path-up "env/type-name-env.ss")
(path-up "env/type-alias-env.ss")
(path-up "infer/infer-dummy.ss")
(path-up "private/parse-type.ss")
(path-up "private/type-contract.ss")
(path-up "typecheck/typechecker.ss")))
(provide with-type)
(define-syntax (with-type stx)
(define-splicing-syntax-class free-vars
#:attributes ((id 1) (ty 1))
[pattern (~seq #:freevars ([id ty] ...))]
[pattern (~seq)
#:with (id ...) null
#:with (ty ...) null])
(syntax-parse stx
[(_ region-ty-stx fv:free-vars . body)
(begin-with-definitions
(define old-context (unbox typed-context?))
(set-box! typed-context? #t)
(define region-tc-result (parse-tc-results #'region-ty-stx))
(define region-cnt (match region-tc-result
[(tc-result1: t) (type->contract
t
(lambda () (tc-error/stx #'region-ty-stx "Type ~a could not be converted to a contract." t)))]))
(define fv-types (for/list ([t (syntax->list #'(fv.ty ...))])
(parse-type t)))
(define fv-cnts (for/list ([t (in-list fv-types)]
[stx (in-list (syntax->list #'(fv.ty ...)))])
(type->contract t #:typed-side #f
(lambda () (tc-error/stx stx "Type ~a could not be converted to a contract." t)))))
(for ([i (in-list (syntax->list #'(fv.id ...)))]
[ty (in-list fv-types)])
(register-type i ty))
(define expanded-body (local-expand #'(let () . body) 'expression null))
(parameterize (;; disable fancy printing?
[custom-printer #t]
;; a cheat to avoid units
[infer-param infer]
;; do we report multiple errors
[delay-errors? #t]
;; this parameter is for parsing types
[current-tvars initial-tvar-env]
;; this parameter is just for printing types
;; this is a parameter to avoid dependency issues
[current-type-names
(lambda ()
(append
(type-name-env-map (lambda (id ty)
(cons (syntax-e id) ty)))
(type-alias-env-map (lambda (id ty)
(cons (syntax-e id) ty)))))]
;; reinitialize seen type variables
[type-name-references null]
;; for error reporting
[orig-module-stx stx]
[expanded-module-stx expanded-body])
(tc-expr/check expanded-body region-tc-result))
(report-all-errors)
(set-box! typed-context? old-context)
;; then clear the new entries from the env ht
(for ([i (in-list (syntax->list #'(fv.id ...)))])
(unregister-type i))
(with-syntax ([(cnt ...) fv-cnts]
[region-cnt region-cnt]
[check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))])
(quasisyntax/loc stx
(begin check-syntax-help
(with-contract typed-region
#:result region-cnt
#:freevars ([fv.id cnt] ...)
. body)))))]))

32
collects/typed-scheme/scribblings/ts-reference.scrbl
View File

@ -6,6 +6,8 @@
scheme/list srfi/14
version/check))]
@(define the-eval (make-base-eval))
@(the-eval '(require (except-in typed/scheme #%top-interaction #%module-begin)))
@title[#:tag "top"]{The Typed Scheme Reference}
@ -330,3 +332,33 @@ Examples:
@schememod[typed-scheme/no-check
(: x Number)
(define x "not-a-number")]
@section{Typed Regions}
The @scheme[with-type] for allows for localized Typed Scheme regions in otherwise untyped code.
@defform/subs[(with-type type fv-clause body ...+)
([fv-clause code:blank
(code:line #:freevars ([id fv-type] ...))])]{
Checks that @scheme[body ...+] has the type @scheme[type]. The @scheme[id]s are assumed to
have the types ascribed to them; these types are converted to contracts and checked dynamically.
Uses of the result value are also appropriately checked by a contract generated from
@scheme[type].
@examples[#:eval the-eval
(with-type Number 3)
((with-type (Number -> Number)
(lambda: ([x : Number]) (add1 x)))
#f)
(let ([x "hello"])
(with-type String
#:freevars ([x String])
(string-append x ", world")))
(let ([x 'hello])
(with-type String
#:freevars ([x String])
(string-append x ", world")))]
}

406
collects/typed-scheme/ts-guide.scrbl
View File

@ -1,406 +0,0 @@
#lang scribble/doc
@begin[(require scribble/manual)
(require (for-label typed-scheme))]
@begin[
(define (item* header . args) (apply item @bold[header]{: } args))
(define-syntax-rule (tmod forms ...) (schememod typed-scheme forms ...))
(define (gtech . x) (apply tech x #:doc '(lib "scribblings/guide/guide.scrbl")))
(define (rtech . x) (apply tech x #:doc '(lib "scribblings/reference/reference.scrbl")))
]
@title[#:tag "top"]{@bold{Typed Scheme}: Scheme with Static Types}
@author["Sam Tobin-Hochstadt"]
@section-index["typechecking"]
Typed Scheme is a Scheme-like language, with a type system that
supports common Scheme programming idioms. Explicit type declarations
are required --- that is, there is no type inference. The language
supports a number of features from previous work on type systems that
make it easier to type Scheme programs, as well as a novel idea dubbed
@italic{occurrence typing} for case discrimination.
Typed Scheme is also designed to integrate with the rest of your PLT
Scheme system. It is possible to convert a single module to Typed
Scheme, while leaving the rest of the program unchanged. The typed
module is protected from the untyped code base via
automatically-synthesized contracts.
Further information on Typed Scheme is available from
@link["http://www.ccs.neu.edu/home/samth/typed-scheme"]{the homepage}.
@section{Starting with Typed Scheme}
If you already know PLT Scheme, or even some other Scheme, it should be
easy to start using Typed Scheme.
@subsection{A First Function}
The following program defines the Fibonacci function in PLT Scheme:
@schememod[
scheme
(define (fib n)
(cond [(= 0 n) 1]
[(= 1 n) 1]
[else (+ (fib (- n 1)) (fib (- n 2)))]))
]
This program defines the same program using Typed Scheme.
@schememod[
typed-scheme
(: fib (Number -> Number))
(define (fib n)
(cond [(= 0 n) 1]
[(= 1 n) 1]
[else (+ (fib (- n 1)) (fib (- n 2)))]))
]
There are two differences between these programs:
@itemize[
@item*[@elem{The Language}]{@schememodname[scheme] has been replaced by @schememodname[typed-scheme].}
@item*[@elem{The Type Annotation}]{We have added a type annotation
for the @scheme[fib] function, using the @scheme[:] form.} ]
In general, these are most of the changes that have to be made to a
PLT Scheme program to transform it into a Typed Scheme program.
@margin-note{Changes to uses of @scheme[require] may also be necessary
- these are described later.}
@subsection[#:tag "complex"]{Adding more complexity}
Other typed binding forms are also available. For example, we could have
rewritten our fibonacci program as follows:
@schememod[
typed-scheme
(: fib (Number -> Number))
(define (fib n)
(let ([base? (or (= 0 n) (= 1 n))])
(if base?
1
(+ (fib (- n 1)) (fib (- n 2))))))
]
This program uses the @scheme[let] binding form, but no new type
annotations are required. Typed Scheme infers the type of
@scheme[base?].
We can also define mutually-recursive functions:
@schememod[
typed-scheme
(: my-odd? (Number -> Boolean))
(define (my-odd? n)
(if (= 0 n) #f
(my-even? (- n 1))))
(: my-even? (Number -> Boolean))
(define (my-even? n)
(if (= 0 n) #t
(my-odd? (- n 1))))
(my-even? 12)
]
As expected, this program prints @schemeresult[#t].
@subsection{Defining New Datatypes}
If our program requires anything more than atomic data, we must define
new datatypes. In Typed Scheme, structures can be defined, similarly
to PLT Scheme structures. The following program defines a date
structure and a function that formats a date as a string, using PLT
Scheme's built-in @scheme[format] function.
@schememod[
typed-scheme
(define-struct: Date ([day : Number] [month : String] [year : Number]))
(: format-date (Date -> String))
(define (format-date d)
(format "Today is day ~a of ~a in the year ~a"
(Date-day d) (Date-month d) (Date-year d)))
(format-date (make-Date 28 "November" 2006))
]
Here we see the built-in type @scheme[String] as well as a definition
of the new user-defined type @scheme[Date]. To define
@scheme[Date], we provide all the information usually found in a
@scheme[define-struct], but added type annotations to the fields using
the @scheme[define-struct:] form.
Then we can use the functions that this declaration creates, just as
we would have with @scheme[define-struct].
@subsection{Recursive Datatypes and Unions}
Many data structures involve multiple variants. In Typed Scheme, we
represent these using @italic{union types}, written @scheme[(U t1 t2 ...)].
@schememod[
typed-scheme
(define-type-alias Tree (U leaf node))
(define-struct: leaf ([val : Number]))
(define-struct: node ([left : Tree] [right : Tree]))
(: tree-height (Tree -> Number))
(define (tree-height t)
(cond [(leaf? t) 1]
[else (max (+ 1 (tree-height (node-left t)))
(+ 1 (tree-height (node-right t))))]))
(: tree-sum (Tree -> Number))
(define (tree-sum t)
(cond [(leaf? t) (leaf-val t)]
[else (+ (tree-sum (node-left t))
(tree-sum (node-right t)))]))
]
In this module, we have defined two new datatypes: @scheme[leaf] and
@scheme[node]. We've also defined the type alias @scheme[Tree] to be
@scheme[(U node leaf)], which represents a binary tree of numbers. In
essence, we are saying that the @scheme[tree-height] function accepts
a @scheme[Tree], which is either a @scheme[node] or a @scheme[leaf],
and produces a number.
In order to calculate interesting facts about trees, we have to take
them apart and get at their contents. But since accessors such as
@scheme[node-left] require a @scheme[node] as input, not a
@scheme[Tree], we have to determine which kind of input we
were passed.
For this purpose, we use the predicates that come with each defined
structure. For example, the @scheme[leaf?] predicate distinguishes
@scheme[leaf]s from all other Typed Scheme values. Therefore, in the
first branch of the @scheme[cond] clause in @scheme[tree-sum], we know
that @scheme[t] is a @scheme[leaf], and therefore we can get its value
with the @scheme[leaf-val] function.
In the else clauses of both functions, we know that @scheme[t] is not
a @scheme[leaf], and since the type of @scheme[t] was @scheme[Tree] by
process of elimination we can determine that @scheme[t] must be a
@scheme[node]. Therefore, we can use accessors such as
@scheme[node-left] and @scheme[node-right] with @scheme[t] as input.
@section{Polymorphism}
Typed Scheme offers abstraction over types as well as values.
@subsection{Polymorphic Data Structures}
Virtually every Scheme program uses lists and sexpressions. Fortunately, Typed
Scheme can handle these as well. A simple list processing program can be
written like this:
@schememod[
typed-scheme
(: sum-list ((Listof Number) -> Number))
(define (sum-list l)
(cond [(null? l) 0]
[else (+ (car l) (sum-list (cdr l)))]))
]
This looks similar to our earlier programs --- except for the type
of @scheme[l], which looks like a function application. In fact, it's
a use of the @italic{type constructor} @scheme[Listof], which takes
another type as its input, here @scheme[Number]. We can use
@scheme[Listof] to construct the type of any kind of list we might
want.
We can define our own type constructors as well. For example, here is
an analog of the @tt{Maybe} type constructor from Haskell:
@schememod[
typed-scheme
(define-struct: Nothing ())
(define-struct: (a) Just ([v : a]))
(define-type-alias (Maybe a) (U Nothing (Just a)))
(: find (Number (Listof Number) -> (Maybe Number)))
(define (find v l)
(cond [(null? l) (make-Nothing)]
[(= v (car l)) (make-Just v)]
[else (find v (cdr l))]))
]
The first @scheme[define-struct:] defines @scheme[Nothing] to be
a structure with no contents.
The second definition
@schemeblock[
(define-struct: (a) Just ([v : a]))
]
creates a parameterized type, @scheme[Just], which is a structure with
one element, whose type is that of the type argument to
@scheme[Just]. Here the type parameters (only one, @scheme[a], in
this case) are written before the type name, and can be referred to in
the types of the fields.
The type alias definiton
@schemeblock[
(define-type-alias (Maybe a) (U Nothing (Just a)))
]
creates a parameterized alias --- @scheme[Maybe] is a potential
container for whatever type is supplied.
The @scheme[find] function takes a number @scheme[v] and list, and
produces @scheme[(make-Just v)] when the number is found in the list,
and @scheme[(make-Nothing)] otherwise. Therefore, it produces a
@scheme[(Maybe Number)], just as the annotation specified.
@subsection{Polymorphic Functions}
Sometimes functions over polymorphic data structures only concern
themselves with the form of the structure. For example, one might
write a function that takes the length of a list of numbers:
@schememod[
typed-scheme
(: list-number-length ((Listof Number) -> Integer))
(define (list-number-length l)
(if (null? l)
0
(add1 (list-number-length (cdr l)))))]
and also a function that takes the length of a list of strings:
@schememod[
typed-scheme
(: list-string-length ((Listof String) -> Integer))
(define (list-string-length l)
(if (null? l)
0
(add1 (list-string-length (cdr l)))))]
Notice that both of these functions have almost exactly the same
definition; the only difference is the name of the function. This
is because neither function uses the type of the elements in the
definition.
We can abstract over the type of the element as follows:
@schememod[
typed-scheme
(: list-length (All (A) ((Listof A) -> Integer)))
(define (list-length l)
(if (null? l)
0
(add1 (list-length (cdr l)))))]
The new type constructor @scheme[All] takes a list of type
variables and a body type. The type variables are allowed to
appear free in the body of the @scheme[All] form.
@section{Variable-Arity Functions: Programming with Rest Arguments}
Typed Scheme can handle some uses of rest arguments.
@subsection{Uniform Variable-Arity Functions}
In Scheme, one can write a function that takes an arbitrary
number of arguments as follows:
@schememod[
scheme
(define (sum . xs)
(if (null? xs)
0
(+ (car xs) (apply sum (cdr xs)))))
(sum)
(sum 1 2 3 4)
(sum 1 3)]
The arguments to the function that are in excess to the
non-rest arguments are converted to a list which is assigned
to the rest parameter. So the examples above evaluate to
@schemeresult[0], @schemeresult[10], and @schemeresult[4].
We can define such functions in Typed Scheme as well:
@schememod[
typed-scheme
(: sum (Number * -> Number))
(define (sum . xs)
(if (null? xs)
0
(+ (car xs) (apply sum (cdr xs)))))]
This type can be assigned to the function when each element
of the rest parameter is used at the same type.
@subsection{Non-Uniform Variable-Arity Functions}
However, the rest argument may be used as a heterogeneous list.
Take this (simplified) definition of the Scheme function @scheme[map]:
@schememod[
scheme
(define (map f as . bss)
(if (or (null? as)
(ormap null? bss))
null
(cons (apply f (car as) (map car bss))
(apply map f (cdr as) (map cdr bss)))))
(map add1 (list 1 2 3 4))
(map cons (list 1 2 3) (list (list 4) (list 5) (list 6)))
(map + (list 1 2 3) (list 2 3 4) (list 3 4 5) (list 4 5 6))]
Here the different lists that make up the rest argument @scheme[bss]
can be of different types, but the type of each list in @scheme[bss]
corresponds to the type of the corresponding argument of @scheme[f].
We also know that, in order to avoid arity errors, the length of
@scheme[bss] must be one less than the arity of @scheme[f] (as
@scheme[as] corresponds to the first argument of @scheme[f]).
The example uses of @scheme[map] evaluate to @schemeresult[(list 2 3 4 5)],
@schemeresult[(list (list 1 4) (list 2 5) (list 3 6))], and
@schemeresult[(list 10 14 18)].
In Typed Scheme, we can define @scheme[map] as follows:
@schememod[
typed-scheme
(: map
(All (C A B ...)
((A B ... B -> C) (Listof A) (Listof B) ... B
->
(Listof C))))
(define (map f as . bss)
(if (or (null? as)
(ormap null? bss))
null
(cons (apply f (car as) (map car bss))
(apply map f (cdr as) (map cdr bss)))))]
Note that the type variable @scheme[B] is followed by an
ellipsis. This denotes that B is a dotted type variable
which corresponds to a list of types, much as a rest
argument corresponds to a list of values. When the type
of @scheme[map] is instantiated at a list of types, then
each type @scheme[t] which is bound by @scheme[B] (notated by
the dotted pre-type @scheme[t ... B]) is expanded to a number
of copies of @scheme[t] equal to the length of the sequence
assigned to @scheme[B]. Then @scheme[B] in each copy is
replaced with the corresponding type from the sequence.
So the type of @scheme[(inst map Integer Boolean String Number)]
is
@scheme[((Boolean String Number -> Integer)
(Listof Boolean) (Listof String) (Listof Number)
->
(Listof Integer))].

331
collects/typed-scheme/ts-reference.scrbl
View File

@ -1,331 +0,0 @@
#lang scribble/doc
@begin[(require scribble/manual scribble/eval
scheme/sandbox)
(require (for-label typed-scheme
scheme/list srfi/14
version/check))]
@begin[
(define (item* header . args) (apply item @bold[header]{: } args))
(define-syntax-rule (tmod forms ...) (schememod typed-scheme forms ...))
(define (gtech . x) (apply tech x #:doc '(lib "scribblings/guide/guide.scrbl")))
(define (rtech . x) (apply tech x #:doc '(lib "scribblings/reference/reference.scrbl")))
]
@title[#:tag "top"]{The Typed Scheme Reference}
@author["Sam Tobin-Hochstadt"]
@(defmodulelang typed-scheme)
@section[#:tag "type-ref"]{Type Reference}
@subsubsub*section{Base Types}
@deftogether[(
@defidform[Number]
@defidform[Integer]
@defidform[Boolean]
@defidform[String]
@defidform[Keyword]
@defidform[Symbol]
@defidform[Void]
@defidform[Input-Port]
@defidform[Output-Port]
@defidform[Path]
@defidform[Regexp]
@defidform[PRegexp]
@defidform[Syntax]
@defidform[Identifier]
@defidform[Bytes]
@defidform[Namespace]
@defidform[EOF]
@defidform[Continuation-Mark-Set]
@defidform[Char])]{
These types represent primitive Scheme data. Note that @scheme[Integer] represents exact integers.}
@defidform[Any]{Any Scheme value. All other types are subtypes of @scheme[Any].}
@defidform[Nothing]{The type with no members.}
The following base types are parameteric in their type arguments.
@defform[(Listof t)]{Homogenous @rtech{lists} of @scheme[t]}
@defform[(Boxof t)]{A @rtech{box} of @scheme[t]}
@defform[(Syntaxof t)]{A @rtech{syntax object} containing a @scheme[t]}
@defform[(Vectorof t)]{Homogenous @rtech{vectors} of @scheme[t]}
@defform[(Option t)]{Either @scheme[t] of @scheme[#f]}
@defform*[[(Parameter t)
(Parameter s t)]]{A @rtech{parameter} of @scheme[t]. If two type arguments are supplied,
the first is the type the parameter accepts, and the second is the type returned.}
@defform[(Pair s t)]{is the pair containing @scheme[s] as the @scheme[car]
and @scheme[t] as the @scheme[cdr]}
@defform[(HashTable k v)]{is the type of a @rtech{hash table} with key type
@scheme[k] and value type @scheme[v].}
@subsubsub*section{Type Constructors}
@defform*[#:id -> #:literals (* ...)
[(dom ... -> rng)
(dom ... rest * -> rng)
(dom ... rest ... bound -> rng)
(dom -> rng : pred)]]{is the type of functions from the (possibly-empty)
sequence @scheme[dom ...] to the @scheme[rng] type. The second form
specifies a uniform rest argument of type @scheme[rest], and the
third form specifies a non-uniform rest argument of type
@scheme[rest] with bound @scheme[bound]. In the third form, the
second occurrence of @scheme[...] is literal, and @scheme[bound]
must be an identifier denoting a type variable. In the fourth form,
there must be only one @scheme[dom] and @scheme[pred] is the type
checked by the predicate.}
@defform[(U t ...)]{is the union of the types @scheme[t ...]}
@defform[(case-lambda fun-ty ...)]{is a function that behaves like all of
the @scheme[fun-ty]s. The @scheme[fun-ty]s must all be function
types constructed with @scheme[->].}
@defform/none[(t t1 t2 ...)]{is the instantiation of the parametric type
@scheme[t] at types @scheme[t1 t2 ...]}
@defform[(All (v ...) t)]{is a parameterization of type @scheme[t], with
type variables @scheme[v ...]}
@defform[(List t ...)]{is the type of the list with one element, in order,
for each type provided to the @scheme[List] type constructor.}
@defform[(values t ...)]{is the type of a sequence of multiple values, with
types @scheme[t ...]. This can only appear as the return type of a
function.}
@defform/none[v]{where @scheme[v] is a number, boolean or string, is the singleton type containing only that value}
@defform/none[(quote val)]{where @scheme[val] is a Scheme value, is the singleton type containing only that value}
@defform/none[i]{where @scheme[i] is an identifier can be a reference to a type
name or a type variable}
@defform[(Rec n t)]{is a recursive type where @scheme[n] is bound to the
recursive type in the body @scheme[t]}
Other types cannot be written by the programmer, but are used
internally and may appear in error messages.
@defform/none[(struct:n (t ...))]{is the type of structures named
@scheme[n] with field types @scheme[t]. There may be multiple such
types with the same printed representation.}
@defform/none[<n>]{is the printed representation of a reference to the
type variable @scheme[n]}
@section[#:tag "special-forms"]{Special Form Reference}
Typed Scheme provides a variety of special forms above and beyond
those in PLT Scheme. They are used for annotating variables with types,
creating new types, and annotating expressions.
@subsection{Binding Forms}
@scheme[_loop], @scheme[_f], @scheme[_a], and @scheme[_v] are names, @scheme[_t] is a type.
@scheme[_e] is an expression and @scheme[_body] is a block.
@defform*[[
(let: ([v : t e] ...) . body)
(let: loop : t0 ([v : t e] ...) . body)]]{
Local bindings, like @scheme[let], each with
associated types. In the second form, @scheme[_t0] is the type of the
result of @scheme[_loop] (and thus the result of the entire
expression as well as the final
expression in @scheme[body]).}
@deftogether[[
@defform[(letrec: ([v : t e] ...) . body)]
@defform[(let*: ([v : t e] ...) . body)]]]{Type-annotated versions of
@scheme[letrec] and @scheme[let*].}
@deftogether[[
@defform[(let/cc: v : t . body)]
@defform[(let/ec: v : t . body)]]]{Type-annotated versions of
@scheme[let/cc] and @scheme[let/ec]. @scheme[t] is the type that will be provided to the continuation @scheme[v].}
@subsection{Anonymous Functions}
@defform/subs[(lambda: formals . body)
([formals ([v : t] ...)
([v : t] ... . [v : t])])]{
A function of the formal arguments @scheme[v], where each formal
argument has the associated type. If a rest argument is present, then
it has type @scheme[(Listof t)].}
@defform[(λ: formals . body)]{
An alias for the same form using @scheme[lambda:].}
@defform[(plambda: (a ...) formals . body)]{
A polymorphic function, abstracted over the type variables
@scheme[a]. The type variables @scheme[a] are bound in both the types
of the formal, and in any type expressions in the @scheme[body].}
@defform[(case-lambda: [formals body] ...)]{
A function of multiple arities. Note that each @scheme[formals] must have a
different arity.}
@defform[(pcase-lambda: (a ...) [formals body] ...)]{
A polymorphic function of multiple arities.}
@subsection{Loops}
@defform/subs[(do: : u ([id : t init-expr step-expr-maybe] ...)
(stop?-expr finish-expr ...)
expr ...+)
([step-expr-maybe code:blank
step-expr])]{
Like @scheme[do], but each @scheme[id] having the associated type @scheme[t], and
the final body @scheme[expr] having the type @scheme[u].
}
@subsection{Definitions}
@defform*[[(define: v : t e)
(define: (f . formals) : t . body)
(define: (a ...) (f . formals) : t . body)]]{
These forms define variables, with annotated types. The first form
defines @scheme[v] with type @scheme[t] and value @scheme[e]. The
second and third forms defines a function @scheme[f] with appropriate
types. In most cases, use of @scheme[:] is preferred to use of @scheme[define:].}
@subsection{Structure Definitions}
@defform/subs[
(define-struct: maybe-type-vars name-spec ([f : t] ...))
([maybe-type-vars code:blank (v ...)]
[name-spec name (name parent)])]{
Defines a @rtech{structure} with the name @scheme[name], where the
fields @scheme[f] have types @scheme[t]. When @scheme[parent], the
structure is a substructure of @scheme[parent]. When
@scheme[maybe-type-vars] is present, the structure is polymorphic in the type
variables @scheme[v].}
@defform/subs[
(define-struct/exec: name-spec ([f : t] ...) [e : proc-t])
([name-spec name (name parent)])]{
Like @scheme[define-struct:], but defines an procedural structure.
The procdure @scheme[e] is used as the value for @scheme[prop:procedure], and must have type @scheme[proc-t].}
@subsection{Type Aliases}
@defform*[[(define-type-alias name t)
(define-type-alias (name v ...) t)]]{
The first form defines @scheme[name] as type, with the same meaning as
@scheme[t]. The second form is equivalent to
@scheme[(define-type-alias name (All (v ...) t))]. Type aliases may
refer to other type aliases or types defined in the same module, but
cycles among type aliases are prohibited.}
@subsection{Type Annotation and Instantiation}
@defform[(: v t)]{This declares that @scheme[v] has type @scheme[t].
The definition of @scheme[v] must appear after this declaration. This
can be used anywhere a definition form may be used.}
@defform[(provide: [v t] ...)]{This declares that the @scheme[v]s have
the types @scheme[t], and also provides all of the @scheme[v]s.}
@litchar{#{v : t}} This declares that the variable @scheme[v] has type
@scheme[t]. This is legal only for binding occurences of @scheme[_v].
@defform[(ann e t)]{Ensure that @scheme[e] has type @scheme[t], or
some subtype. The entire expression has type @scheme[t].
This is legal only in expression contexts.}
@litchar{#{e :: t}} This is identical to @scheme[(ann e t)].
@defform[(inst e t ...)]{Instantiate the type of @scheme[e] with types
@scheme[t ...]. @scheme[e] must have a polymorphic type with the
appropriate number of type variables. This is legal only in expression
contexts.}
@litchar|{#{e @ t ...}}| This is identical to @scheme[(inst e t ...)].
@subsection{Require}
Here, @scheme[_m] is a module spec, @scheme[_pred] is an identifier
naming a predicate, and @scheme[_r] is an optionally-renamed identifier.
@defform/subs[#:literals (struct opaque)
(require/typed m rt-clause ...)
([rt-clause [r t]
[struct name ([f : t] ...)]
[struct (name parent) ([f : t] ...)]
[opaque t pred]])
]{This form requires identifiers from the module @scheme[m], giving
them the specified types.
The first form requires @scheme[r], giving it type @scheme[t].
@index["struct"]{The second and third forms} require the struct with name @scheme[name]
with fields @scheme[f ...], where each field has type @scheme[t]. The
third form allows a @scheme[parent] structure type to be specified.
The parent type must already be a structure type known to Typed
Scheme, either built-in or via @scheme[require/typed]. The
structure predicate has the appropriate Typed Scheme filter type so
that it may be used as a predicate in @scheme[if] expressions in Typed
Scheme.
@index["opaque"]{The fourth case} defines a new type @scheme[t]. @scheme[pred], imported from
module @scheme[m], is a predicate for this type. The type is defined
as precisely those values to which @scheme[pred] produces
@scheme[#t]. @scheme[pred] must have type @scheme[(Any -> Boolean)].
Opaque types must be required lexically before they are used.
In all cases, the identifiers are protected with @rtech{contracts} which
enforce the specified types. If this contract fails, the module
@scheme[m] is blamed.
Some types, notably polymorphic types constructed with @scheme[All],
cannot be converted to contracts and raise a static error when used in
a @scheme[require/typed] form.}
@section{Libraries Provided With Typed Scheme}
The @schememodname[typed-scheme] language corresponds to the
@schememodname[scheme/base] language---that is, any identifier provided
by @schememodname[scheme/base], such as @scheme[modulo] is available by default in
@schememodname[typed-scheme].
@schememod[typed-scheme
(modulo 12 2)
]
Any value provided by @schememodname[scheme] is available by simply
@scheme[require]ing it; use of @scheme[require/typed] is not
neccessary.
@schememod[typed-scheme
(require scheme/list)
(display (first (list 1 2 3)))
]
Some libraries have counterparts in the @schemeidfont{typed}
collection, which provide the same exports as the untyped versions.
Such libraries include @schememodname[srfi/14],
@schememodname[net/url], and many others.
@schememod[typed-scheme
(require typed/srfi/14)
(char-set= (string->char-set "hello")
(string->char-set "olleh"))
]
To participate in making more libraries available, please visit
@link["http://www.ccs.neu.edu/home/samth/adapt/"]{here}.
Other libraries can be used with Typed Scheme via
@scheme[require/typed].
@schememod[typed-scheme
(require/typed version/check
[check-version (-> (U Symbol (Listof Any)))])
(check-version)
]
@section{Typed Scheme Syntax Without Type Checking}
@defmodulelang[typed-scheme/no-check]
On occasions where the Typed Scheme syntax is useful, but actual
typechecking is not desired, the @schememodname[typed-scheme/no-check]
language is useful. It provides the same bindings and syntax as Typed
Scheme, but does no type checking.
Examples:
@schememod[typed-scheme/no-check
(: x Number)
(define x "not-a-number")]

8
collects/typed-scheme/typed-scheme.ss
View File

@ -2,7 +2,7 @@
(require (rename-in "utils/utils.ss" [infer r:infer]))
(require (private base-types)
(require (private base-types with-types)
(for-syntax
(except-in syntax/parse id)
scheme/base
@ -19,14 +19,12 @@
syntax/kerncase
scheme/match))
(provide (rename-out [module-begin #%module-begin]
[top-interaction #%top-interaction]
[#%plain-lambda lambda]
[#%app #%app]
[require require]))
[require require])
with-type)
(define-for-syntax catch-errors? #f)

2
collects/typed-scheme/types/utils.ss
View File

@ -295,7 +295,7 @@
;; error for unbound variables
(define (lookup-fail e)
(match (identifier-binding e)
['lexical (int-err "untyped lexical variable ~a" (syntax-e e))]
['lexical (tc-error/expr "untyped lexical variable ~a" (syntax-e e))]
[#f (tc-error/expr "untyped top-level identifier ~a" (syntax-e e))]
[(list _ _ nominal-source-mod nominal-source-id _ _ _)
(let-values ([(x y) (module-path-index-split nominal-source-mod)])

2
collects/typed/scheme/base.ss
View File

@ -17,5 +17,5 @@
typed-scheme/private/extra-procs
(for-syntax typed-scheme/private/base-types-extra))
(provide (rename-out [with-handlers: with-handlers])
assert
assert with-type
(for-syntax (all-from-out typed-scheme/private/base-types-extra)))

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

@ -1928,8 +1928,8 @@ void scheme_unbound_global(Scheme_Bucket *b)
else
errmsg = "reference to an identifier before its definition: %S%_%s";
if (SCHEME_INT_VAL(((Scheme_Bucket_With_Home *)b)->home->phase)) {
sprintf(phase_buf, " phase: %ld", SCHEME_INT_VAL(((Scheme_Bucket_With_Home *)b)->home->phase));
if (((Scheme_Bucket_With_Home *)b)->home->phase) {
sprintf(phase_buf, " phase: %ld", ((Scheme_Bucket_With_Home *)b)->home->phase);
phase = phase_buf;
} else
phase = "";

2
src/mzscheme/src/fun.c
View File

@ -7399,6 +7399,8 @@ scheme_get_stack_trace(Scheme_Object *mark_set)
if (SCHEME_FALSEP(SCHEME_CDR(name)))
what = "[traversing imports]";
else if (SCHEME_VOIDP(SCHEME_CDR(name)))
what = "[running expand-time body]";
else
what = "[running body]";

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

@ -166,7 +166,7 @@ SHARED_OK static void *struct_proc_extract_code;
SHARED_OK static void *bad_app_vals_target;
SHARED_OK static void *app_values_slow_code, *app_values_multi_slow_code, *app_values_tail_slow_code;
SHARED_OK static void *finish_tail_call_code, *finish_tail_call_fixup_code;
SHARED_OK static void *module_run_start_code, *module_start_start_code;
SHARED_OK static void *module_run_start_code, *module_exprun_start_code, *module_start_start_code;
SHARED_OK static void *box_flonum_from_stack_code;
SHARED_OK static void *fl1_fail_code, *fl2rr_fail_code[2], *fl2fr_fail_code[2], *fl2rf_fail_code[2];
@ -11555,6 +11555,37 @@ static int do_generate_more_common(mz_jit_state *jitter, void *_data)
register_sub_func(jitter, module_run_start_code, scheme_eof);
}
/* *** module_exprun_start_code *** */
/* Pushes a module name onto the stack for stack traces. */
{
int in;
module_exprun_start_code = jit_get_ip().ptr;
jit_prolog(3);
in = jit_arg_p();
jit_getarg_p(JIT_R0, in); /* menv */
in = jit_arg_p();
jit_getarg_i(JIT_R1, in); /* set_ns */
in = jit_arg_p();
jit_getarg_p(JIT_R2, in); /* &name */
CHECK_LIMIT();
/* Store the name where we can find it */
mz_push_locals();
mz_set_local_p(JIT_R2, JIT_LOCAL2);
jit_prepare(2);
jit_pusharg_i(JIT_R1);
jit_pusharg_p(JIT_R0);
(void)mz_finish(scheme_module_exprun_finish);
CHECK_LIMIT();
mz_pop_locals();
jit_ret();
CHECK_LIMIT();
register_sub_func(jitter, module_exprun_start_code, scheme_eof);
}
/* *** module_start_start_code *** */
/* Pushes a module name onto the stack for stack traces. */
{
@ -12822,6 +12853,7 @@ static void release_native_code(void *fnlized, void *p)
#endif
typedef void *(*Module_Run_Proc)(Scheme_Env *menv, Scheme_Env *env, Scheme_Object **name);
typedef void *(*Module_Exprun_Proc)(Scheme_Env *menv, int set_ns, Scheme_Object **name);
typedef void *(*Module_Start_Proc)(struct Start_Module_Args *a, Scheme_Object **name);
void *scheme_module_run_start(Scheme_Env *menv, Scheme_Env *env, Scheme_Object *name)
@ -12833,6 +12865,15 @@ void *scheme_module_run_start(Scheme_Env *menv, Scheme_Env *env, Scheme_Object *
return scheme_module_run_finish(menv, env);
}
void *scheme_module_exprun_start(Scheme_Env *menv, int set_ns, Scheme_Object *name)
{
Module_Exprun_Proc proc = (Module_Exprun_Proc)module_exprun_start_code;
if (proc)
return proc(menv, set_ns, &name);
else
return scheme_module_exprun_finish(menv, set_ns);
}
void *scheme_module_start_start(struct Start_Module_Args *a, Scheme_Object *name)
{
Module_Start_Proc proc = (Module_Start_Proc)module_start_start_code;

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

@ -4164,6 +4164,15 @@ static void expstart_module(Scheme_Env *menv, Scheme_Env *env, int restart)
}
static void run_module_exptime(Scheme_Env *menv, int set_ns)
{
#ifdef MZ_USE_JIT
(void)scheme_module_exprun_start(menv, set_ns, scheme_make_pair(menv->module->modname, scheme_void));
#else
(void)scheme_module_exprun_finish(menv, set_ns);
#endif
}
void *scheme_module_exprun_finish(Scheme_Env *menv, int set_ns)
{
int let_depth, for_stx;
Scheme_Object *names, *e;
@ -4176,17 +4185,17 @@ static void run_module_exptime(Scheme_Env *menv, int set_ns)
Scheme_Config *config;
if (menv->module->primitive)
return;
return NULL;
if (!SCHEME_VEC_SIZE(menv->module->et_body))
return;
return NULL;
syntax = menv->syntax;
exp_env = menv->exp_env;
if (!exp_env)
return;
return NULL;
for_stx_globals = exp_env->toplevel;
@ -4222,6 +4231,8 @@ static void run_module_exptime(Scheme_Env *menv, int set_ns)
if (set_ns) {
scheme_pop_continuation_frame(&cframe);
}
return NULL;
}
static void do_start_module(Scheme_Module *m, Scheme_Env *menv, Scheme_Env *env, int restart)
@ -4350,12 +4361,25 @@ static void start_module(Scheme_Module *m, Scheme_Env *env, int restart,
static void do_prepare_compile_env(Scheme_Env *env, int base_phase, int pos)
{
Scheme_Object *v;
Scheme_Object *v, *prev;
Scheme_Env *menv;
v = MODCHAIN_AVAIL(env->modchain, pos);
if (!SCHEME_FALSEP(v)) {
MODCHAIN_AVAIL(env->modchain, pos) = scheme_false;
/* Reverse order of the list; if X requires Y, Y
has been pushed onto the front of the list
before X. */
prev = scheme_false;
while (SCHEME_NAMESPACEP(v)) {
menv = (Scheme_Env *)v;
v = menv->available_next[pos];
menv->available_next[pos] = prev;
prev = (Scheme_Object *)menv;
}
v = prev;
while (SCHEME_NAMESPACEP(v)) {
menv = (Scheme_Env *)v;
v = menv->available_next[pos];

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

@ -2475,9 +2475,11 @@ struct Start_Module_Args;
#ifdef MZ_USE_JIT
void *scheme_module_run_start(Scheme_Env *menv, Scheme_Env *env, Scheme_Object *name);
void *scheme_module_exprun_start(Scheme_Env *menv, int set_ns, Scheme_Object *name);
void *scheme_module_start_start(struct Start_Module_Args *a, Scheme_Object *name);
#endif
void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env);
void *scheme_module_exprun_finish(Scheme_Env *menv, int set_ns);
void *scheme_module_start_finish(struct Start_Module_Args *a);
Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Compile_Info *rec, int 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.2.4.3"
version="4.2.4.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,2,4,3
PRODUCTVERSION 4,2,4,3
FILEVERSION 4,2,4,4
PRODUCTVERSION 4,2,4,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, 2, 4, 3\0"
VALUE "FileVersion", "4, 2, 4, 4\0"
VALUE "LegalCopyright", "Copyright © 1995-2010\0"
VALUE "OriginalFilename", "MrEd.exe\0"
VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 2, 4, 3\0"
VALUE "ProductVersion", "4, 2, 4, 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,2,4,3
PRODUCTVERSION 4,2,4,3
FILEVERSION 4,2,4,4
PRODUCTVERSION 4,2,4,4
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -70,12 +70,12 @@ BEGIN
BLOCK "040904b0"
BEGIN
VALUE "FileDescription", "MzCOM Module"
VALUE "FileVersion", "4, 2, 4, 3"
VALUE "FileVersion", "4, 2, 4, 4"
VALUE "InternalName", "MzCOM"
VALUE "LegalCopyright", "Copyright 2000-2010 PLT (Paul Steckler)"
VALUE "OriginalFilename", "MzCOM.EXE"
VALUE "ProductName", "MzCOM Module"
VALUE "ProductVersion", "4, 2, 4, 3"
VALUE "ProductVersion", "4, 2, 4, 4"
END
END
BLOCK "VarFileInfo"

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

@ -1,19 +1,19 @@
HKCR
{
MzCOM.MzObj.4.2.4.3 = s 'MzObj Class'
MzCOM.MzObj.4.2.4.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.2.4.3'
CurVer = s 'MzCOM.MzObj.4.2.4.4'
}
NoRemove CLSID
{
ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class'
{
ProgID = s 'MzCOM.MzObj.4.2.4.3'
ProgID = s 'MzCOM.MzObj.4.2.4.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,2,4,3
PRODUCTVERSION 4,2,4,3
FILEVERSION 4,2,4,4
PRODUCTVERSION 4,2,4,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, 2, 4, 3\0"
VALUE "FileVersion", "4, 2, 4, 4\0"
VALUE "LegalCopyright", "Copyright <20>© 1995-2010\0"
VALUE "OriginalFilename", "mzscheme.exe\0"
VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 2, 4, 3\0"
VALUE "ProductVersion", "4, 2, 4, 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,2,4,3
PRODUCTVERSION 4,2,4,3
FILEVERSION 4,2,4,4
PRODUCTVERSION 4,2,4,4
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -45,7 +45,7 @@ BEGIN
#ifdef MZSTART
VALUE "FileDescription", "PLT Scheme Launcher\0"
#endif
VALUE "FileVersion", "4, 2, 4, 3\0"
VALUE "FileVersion", "4, 2, 4, 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, 2, 4, 3\0"
VALUE "ProductVersion", "4, 2, 4, 4\0"
END
END
BLOCK "VarFileInfo"