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

Syncing up to trunk before I go to bed, so setup-plt can run while I

Browse Source 
sleep.

svn: r18220
This commit is contained in:
Stevie Strickland 2010-02-20 10:59:49 +00:00
commit c59805ab9e
25 changed files with 508 additions and 185 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

136
collects/compiler/zo-marshal.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require compiler/zo-structs
scheme/match
scheme/local
scheme/list
scheme/dict)
@ -10,14 +11,9 @@
Less sharing occurs than in the C implementation, creating much larger files
encode-all-from-module only handles one case
What is the purpose of protect-quote? It was making it so certain things (like paths) weren't being encoded correctly.
protect-quote caused some things to be sent to write. But there are some things (like paths) that can be read and passed to protect-quote that cannot be 'read' in after 'write', so we turned it off
|#
;; Doesn't write as compactly as MzScheme, since list and pair sequences
;; are not compacted, and symbols are not written in short form
(define current-wrapped-ht (make-parameter #f))
(define (zo-marshal top)
(match top
@ -318,11 +314,30 @@
APPVALS_EXPD
SPLICE_EXPD)
(define CPT_SMALL_NUMBER_START 35)
(define CPT_SMALL_NUMBER_END 60)
(define CPT_SMALL_SYMBOL_START 60)
(define CPT_SMALL_SYMBOL_END 80)
(define CPT_SMALL_MARSHALLED_START 80)
(define CPT_SMALL_MARSHALLED_END 92)
(define CPT_SMALL_LIST_MAX 65)
(define CPT_SMALL_PROPER_LIST_START 92)
(define CPT_SMALL_PROPER_LIST_END (+ CPT_SMALL_PROPER_LIST_START CPT_SMALL_LIST_MAX))
(define CPT_SMALL_LIST_START CPT_SMALL_PROPER_LIST_END)
(define CPT_SMALL_LIST_END 192)
(define CPT_SMALL_LOCAL_START 192)
(define CPT_SMALL_LOCAL_END 207)
(define CPT_SMALL_LOCAL_UNBOX_START 207)
(define CPT_SMALL_LOCAL_UNBOX_END 222)
(define CPT_SMALL_SVECTOR_START 222)
(define CPT_SMALL_SVECTOR_END 247)
(define CPT_SMALL_APPLICATION_START 247)
(define CPT_SMALL_APPLICATION_END 255)
@ -385,8 +400,11 @@
(out-marshaled syntax-type-num (list* key val) out))
(define (out-marshaled type-num val out)
(out-byte CPT_MARSHALLED out)
(out-number type-num out)
(if (type-num . < . (- CPT_SMALL_MARSHALLED_END CPT_SMALL_MARSHALLED_START))
(out-byte (+ CPT_SMALL_MARSHALLED_START type-num) out)
(begin
(out-byte CPT_MARSHALLED out)
(out-number type-num out)))
(out-data val out))
(define (out-anything v out)
@ -537,7 +555,9 @@
(define (encode-all-from-module all)
(match all
[(struct all-from-module (path phase src-phase exceptions prefix))
(list* path phase src-phase)]))
(if (and (empty? exceptions) (not prefix))
(list* path phase src-phase)
(list* path phase src-phase (append exceptions prefix)))]))
(define (encode-wraps wraps)
(for/list ([wrap (in-list wraps)])
@ -592,7 +612,7 @@
[(struct stx (encoded))
(out-byte CPT_STX out)
(out-wrapped encoded out)]))))
(define (out-form form out)
(match form
[(? mod?)
@ -734,13 +754,14 @@
(out-expr (protect-quote then) out)
(out-expr (protect-quote else) out)]
[(struct application (rator rands))
(if ((length rands) . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START))
(out-byte (+ CPT_SMALL_APPLICATION_START (length rands)) out)
(begin
(out-byte CPT_APPLICATION out)
(out-number (length rands) out)))
(for-each (lambda (e) (out-expr (protect-quote e) out))
(cons rator rands))]
(let ([len (length rands)])
(if (len . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START))
(out-byte (+ CPT_SMALL_APPLICATION_START (length rands)) out)
(begin
(out-byte CPT_APPLICATION out)
(out-number len out)))
(for-each (lambda (e) (out-expr (protect-quote e) out))
(cons rator rands)))]
[(struct apply-values (proc args-expr))
(out-syntax APPVALS_EXPD
(cons (protect-quote proc)
@ -852,11 +873,15 @@
#f
out)]
[(symbol? expr)
(out-as-bytes expr
(compose string->bytes/utf-8 symbol->string)
CPT_SYMBOL
#f
out)]
(out-shared expr out
(lambda ()
(define bs (string->bytes/utf-8 (symbol->string expr)))
(define len (bytes-length bs))
(if (len . < . (- CPT_SMALL_SYMBOL_END CPT_SMALL_SYMBOL_START))
(out-byte (+ CPT_SMALL_SYMBOL_START len) out)
(begin (out-byte CPT_SYMBOL out)
(out-number len out)))
(out-bytes bs out)))]
[(keyword? expr)
(out-as-bytes expr
(compose string->bytes/utf-8 keyword->string)
@ -886,8 +911,12 @@
(out-number (char->integer expr) out)]
[(and (exact-integer? expr)
(and (expr . >= . -1073741824) (expr . <= . 1073741823)))
(out-byte CPT_INT out)
(out-number expr out)]
(if (and (expr . >= . 0)
(expr . < . (- CPT_SMALL_NUMBER_END CPT_SMALL_NUMBER_START)))
(out-byte (+ CPT_SMALL_NUMBER_START expr) out)
(begin
(out-byte CPT_INT out)
(out-number expr out)))]
[(null? expr)
(out-byte CPT_NULL out)]
[(eq? expr #t)
@ -900,10 +929,46 @@
(out-byte CPT_BOX out)
(out-data (unbox expr) out)]
[(pair? expr)
(out-byte CPT_LIST out)
(out-number 1 out)
(out-data (car expr) out)
(out-data (cdr expr) out)]
(local [(define seen? (make-hasheq)) ; XXX Maybe this should be global?
(define (list-length-before-cycle/improper-end l)
(if (hash-has-key? seen? l)
(begin (values 0 #f))
(begin (hash-set! seen? l #t)
(cond
[(null? l)
(values 0 #t)]
[(pair? l)
(let-values ([(len proper?)
(list-length-before-cycle/improper-end (cdr l))])
(values (add1 len) proper?))]
[else
(values 0 #f)]))))
(define-values (len proper?) (list-length-before-cycle/improper-end expr))
(define (print-contents-as-proper)
(for ([e (in-list expr)])
(out-data e out)))
(define (print-contents-as-improper)
(let loop ([l expr] [i len])
(cond
[(zero? i)
(out-data l out)]
[else
(out-data (car l) out)
(loop (cdr l) (sub1 i))])))]
(if proper?
(if (len . < . (- CPT_SMALL_PROPER_LIST_END CPT_SMALL_PROPER_LIST_START))
(begin (out-byte (+ CPT_SMALL_PROPER_LIST_START len) out)
(print-contents-as-proper))
(begin (out-byte CPT_LIST out)
(out-number len out)
(print-contents-as-proper)
(out-data null out)))
(if (len . < . (- CPT_SMALL_LIST_END CPT_SMALL_LIST_START))
(begin (out-byte (+ CPT_SMALL_LIST_START len) out)
(print-contents-as-improper))
(begin (out-byte CPT_LIST out)
(out-number len out)
(print-contents-as-improper)))))]
[(vector? expr)
(out-byte CPT_VECTOR out)
(out-number (vector-length expr) out)
@ -921,10 +986,13 @@
(out-data k out)
(out-data v out))]
[(svector? expr)
(out-byte CPT_SVECTOR out)
(out-number (vector-length (svector-vec expr)) out)
(let ([vec (svector-vec expr)])
(for ([n (in-range (sub1 (vector-length vec)) -1 -1)])
(let* ([vec (svector-vec expr)]
[len (vector-length vec)])
(if (len . < . (- CPT_SMALL_SVECTOR_END CPT_SMALL_SVECTOR_START))
(out-byte (+ CPT_SMALL_SVECTOR_START len) out)
(begin (out-byte CPT_SVECTOR out)
(out-number len out)))
(for ([n (in-range (sub1 len) -1 -1)])
(out-number (vector-ref vec n) out)))]
[(module-path-index? expr)
(out-shared expr out
@ -958,8 +1026,8 @@
(define (protect-quote v)
v
#;(if (or (list? v) (vector? v) (box? v) (hash? v))
(make-quoted v)
v))
(make-quoted v)
v))
(define-struct svector (vec))

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

@ -27,6 +27,10 @@
I think parse-module-path-index was only used for debugging, so it is short-circuited now
collects/browser/compiled/browser_scrbl.zo (eg) contains a all-from-module that looks like: (#<module-path-index> 0 (1363072) . #f) --- that doesn't seem to match the spec
We seem to leave placeholders for hash-tables in the structs
|#
;; ----------------------------------------
;; Bytecode unmarshalers for various forms
@ -598,6 +602,8 @@
(if kind 'marked 'normal)
set-id
(let ([results (map (lambda (u)
; u = (list path phase . src-phase)
; or u = (list path phase src-phase exn ... . prefix)
(let ([just-phase? (let ([v (cddr u)])
(or (number? v) (not v)))])
(let-values ([(exns prefix)

21
collects/drscheme/private/rep.ss
View File

@ -262,7 +262,18 @@ TODO
[add-drs-function
(λ (name f)
(send drs-bindings-keymap add-function name
(λ (obj evt) (cond [(get-frame obj) => f]))))])
(λ (obj evt) (cond [(get-frame obj) => f]))))]
[show-tab
(λ (i)
(λ (obj evt)
(let ([fr (get-frame obj)])
(and fr
(is-a? fr drscheme:unit:frame<%>)
(< i (send fr get-tab-count))
(begin (send fr change-to-nth-tab i)
#t)))))])
(for ([i (in-range 1 10)])
(send drs-bindings-keymap add-function (format "show-tab-~a" i) (show-tab (- i 1))))
(send drs-bindings-keymap add-function "search-help-desk"
(λ (obj evt)
(if (not (and (is-a? obj text%) (get-frame obj))) ; is `get-frame' needed?
@ -300,6 +311,14 @@ TODO
(send drs-bindings-keymap map-function "c:x;0" "collapse")
(send drs-bindings-keymap map-function "c:x;2" "split")
(for ([i (in-range 1 10)])
(send drs-bindings-keymap map-function
(format "a:~a" i)
(format "show-tab-~a" i))
(send drs-bindings-keymap map-function
(format "m:~a" i)
(format "show-tab-~a" i)))
(define (get-drs-bindings-keymap) drs-bindings-keymap)

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

@ -2081,12 +2081,20 @@ module browser threading seems wrong.
(send tabs-panel set-item-label (send tab get-i) label))))
(define/private (get-defs-tab-label defs tab)
(let ([fn (send defs get-filename)])
(add-modified-flag
defs
(if fn
(get-tab-label-from-filename fn)
(send defs get-filename/untitled-name)))))
(let ([fn (send defs get-filename)]
[i-prefix (or (for/or ([i (in-list tabs)]
[n (in-naturals 1)]
#:when (<= n 9))
(and (eq? i tab)
(format "~a: " n)))
"")])
(string-append
i-prefix
(add-modified-flag
defs
(if fn
(get-tab-label-from-filename fn)
(send defs get-filename/untitled-name))))))
(define/private (get-tab-label-from-filename fn)
(let* ([take-n
@ -2909,7 +2917,8 @@ module browser threading seems wrong.
(define/public (open-in-new-tab filename)
(create-new-tab filename))
(define/private (change-to-nth-tab n)
(define/public (get-tab-count) (length tabs))
(define/public (change-to-nth-tab n)
(unless (< n (length tabs))
(error 'change-to-nth-tab "number too big ~s" n))
(change-to-tab (list-ref tabs n)))

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

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

6
collects/scheme/contract/private/provide.ss
View File

@ -17,7 +17,7 @@
[(_ name x) (a:known-good-contract? #'x) #'x]
[(_ name x) #'(coerce-contract name x)]))
(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
(define-for-syntax (make-provide/contract-transformer contract-id id external-id pos-module-source)
(make-set!-transformer
(let ([saved-id-table (make-hasheq)])
(λ (stx)
@ -30,6 +30,7 @@
;; No: lift the contract creation:
(with-syntax ([contract-id contract-id]
[id id]
[external-id external-id]
[pos-module-source pos-module-source]
[id-ref (syntax-case stx (set!)
[(set! whatever e)
@ -45,7 +46,7 @@
id
pos-module-source
(quote-module-path)
'id
'external-id
(quote-syntax id))))))])
(when key
(hash-set! saved-id-table key lifted-id))
@ -655,6 +656,7 @@
(define-syntax id-rename
(make-provide/contract-transformer (quote-syntax contract-id)
(quote-syntax id)
(quote-syntax external-name)
(quote-syntax pos-module-source)))
(provide (rename-out [id-rename external-name]))))])

2
collects/scribblings/mzc/zo-parse.scrbl
View File

@ -564,7 +564,7 @@ Represents a set of module and import bindings.}
[phase (or/c exact-integer? #f)]
[src-phase (or/c exact-integer? #f)]
[exceptions (listof symbol?)]
[prefix symbol?])]{
[prefix (or/c symbol? #f)])]{
Represents a set of simple imports from one module within a
@scheme[module-rename].}

51
collects/tests/compiler/zo-test.ss
View File

@ -29,6 +29,9 @@
(hash-update! ht phase (curry list* file) empty))
(define (equal?/why-not v1 v2)
(define v1->v2 (make-hasheq))
(define (interned-symbol=? s1 s2)
(symbol=? (hash-ref! v1->v2 s1 s2) s2))
(define (yield p m v1 v2)
(error 'equal?/why-not "~a in ~a: ~S ~S"
m (reverse p) v1 v2))
@ -93,6 +96,13 @@
(yield p "Unequal strings" v1 v2))]
[_
(yield p "Not a string on right" v1 v2)])]
[(? bytes?)
(match v2
[(? bytes?)
(unless (bytes=? v1 v2)
(yield p "Unequal bytes" v1 v2))]
[_
(yield p "Not a bytes on right" v1 v2)])]
[(? path?)
(match v2
[(? path?)
@ -107,30 +117,39 @@
(yield p "Unequal numbers" v1 v2))]
[_
(yield p "Not a number on right" v1 v2)])]
[(? regexp?)
(match v2
[(? regexp?)
(unless (string=? (object-name v1) (object-name v2))
(yield p "Unequal regexp" v1 v2))]
[_
(yield p "Not a regexp on right" v1 v2)])]
[(? symbol?)
(match v2
[(? symbol?)
(do-compare (symbol-interned?
symbol-unreadable?)
yield p v1 v2
symbol=?)]
(unless (symbol=? v1 v2)
(cond
[(and (symbol-interned? v1) (not (symbol-interned? v1)))
(yield p "Not interned symbol on right" v1 v2)]
[(and (symbol-unreadable? v1) (not (symbol-unreadable? v1)))
(yield p "Not unreadable symbol on right" v1 v2)]
[(and (symbol-uninterned? v1) (not (symbol-uninterned? v1)))
(yield p "Not uninterned symbol on right" v1 v2)]
[(and (symbol-uninterned? v1) (symbol-uninterned? v2))
(unless (interned-symbol=? v1 v2)
(yield p "Uninterned symbols don't align" v1 v2))]
[else
(yield p "Other symbol-related problem" v1 v2)]))]
[_
(yield p "Not a symbol on right" v1 v2)])]
(yield p "Not a symbol on right" v1 v2)])]
[(? empty?)
(yield p "Not empty on right" v1 v2)]
[_
(yield p "Cannot inspect values deeper" v1 v2)])))
(inner empty v1 v2))
(define-syntax do-compare
(syntax-rules ()
[(_ () yield p v1 v2 =)
(unless (= v1 v2)
(yield p (format "Not ~a" '=) v1 v2))]
[(_ (?1 ? ...) yield p v1 v2 =)
(if (?1 v1)
(if (?1 v2)
(do-compare () yield (list* '?1 p) v1 v2 =)
(yield p (format "Not ~a or right" '?1) v1 v2))
(do-compare (? ...) yield p v1 v2 =))]))
(define (symbol-uninterned? s)
(not (or (symbol-interned? s) (symbol-unreadable? s))))
;; Parameters
(define stop-on-first-error (make-parameter #f))

10
collects/tests/mzscheme/future.ss → collects/tests/future/future.ss
View File

@ -3,6 +3,16 @@
(Section 'future)
(require scheme/future)
#|Need to add expressions which raise exceptions inside a
future thunk which can be caught at the touch site
(as opposed to using with-handlers).
Both future and touch should be called from within a future thunk.
We should also test deep continuations.
|#
;; ----------------------------------------
(test 2

0
collects/scheme/future/test/random-future.ss → collects/tests/future/random-future.ss
View File

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

@ -8003,7 +8003,8 @@ so that propagation occurs.
(eval '(require 'provide/contract34-m2))
(eval 'provide/contract34-x))
10)
(contract-error-test
#'(begin
(eval '(module pce1-bug scheme/base
@ -8104,7 +8105,33 @@ so that propagation occurs.
(printf ">> ~s\n" (exn-message x))
(and (exn? x)
(regexp-match #rx"pce8-bug" (exn-message x)))))
(contract-error-test
#'(begin
(eval '(module pce9-bug scheme
(define (f x) "wrong")
(provide/contract
[rename f g
(-> number? number?)])))
(eval '(require 'pce9-bug))
(eval '(g 12)))
(λ (x)
(and (exn? x)
(regexp-match #rx"broke the contract.*on g" (exn-message x)))))
(contract-error-test
#'(begin
(eval '(module pce10-bug scheme
(define (f x) "wrong")
(provide/contract
[rename f g
(-> number? number?)])))
(eval '(require 'pce10-bug))
(eval '(g 'a)))
(λ (x)
(and (exn? x)
(regexp-match #rx"broke the contract.*on g" (exn-message x)))))
(contract-eval
`(,test
'pos

18
collects/tests/typed-scheme/fail/cnt-struct-err.ss Normal file
View File

@ -0,0 +1,18 @@
#;
(exn-pred exn:fail:contract?)
#lang scheme/load
(module m typed-scheme
(define-struct: x ([f : (Number -> Number)]))
(: my-x x)
(define my-x (make-x (lambda: ([z : Number]) z)))
(provide (all-defined-out)))
(module n2 scheme/base
(require 'm scheme/match)
(match my-x
[(struct x (f)) (f #f)]))
(require 'n2)

3
collects/tests/typed-scheme/fail/struct-provide.ss
View File

@ -3,7 +3,8 @@
#lang scheme/load
(module m typed-scheme
(define-struct: q ())
(require (for-syntax scheme/base))
(define-syntax (q stx) #'#f)
(provide (all-defined-out)))
(module n scheme

16
collects/tests/typed-scheme/succeed/provide-struct-untyped.ss Normal file
View File

@ -0,0 +1,16 @@
#lang scheme/load
(module m typed-scheme
(define-struct: x ([f : (Number -> Number)]))
(: my-x x)
(define my-x (make-x (lambda: ([z : Number]) z)))
(provide (all-defined-out)))
(module n2 scheme/base
(require 'm scheme/match)
(match my-x
[(struct x (f)) (f 7)]))
(require 'n2)

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

@ -241,6 +241,25 @@ This file defines two sorts of primitives. All of them are provided into any mod
'typechecker:with-handlers
#t))]))
(define-syntax (dtsi* stx)
(define-syntax-class struct-name
#:description "struct name (with optional super-struct name)"
#:attributes (name super value)
(pattern ((~var name (static struct-info? "struct name")) super:id)
#:attr value (attribute name.value))
(pattern (~var name (static struct-info? "struct name"))
#:attr value (attribute name.value)
#:with super #f))
(syntax-parse stx
[(_ () nm:struct-name . rest)
(internal (quasisyntax/loc stx
(define-typed-struct-internal
#,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))]
[(_ (vars:id ...) nm:struct-name . rest)
(internal (quasisyntax/loc stx
(define-typed-struct-internal (vars ...)
#,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))]))
(define-syntax (define-typed-struct stx)
(define-syntax-class fld-spec
#:literals (:)
@ -259,12 +278,12 @@ This file defines two sorts of primitives. All of them are provided into any mod
'())])
(with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
'typechecker:ignore #t)]
[dtsi (internal (quasisyntax/loc stx (define-typed-struct-internal nm (fs ...) #,@mutable)))])
[dtsi (quasisyntax/loc stx (dtsi* () nm (fs ...) #,@mutable))])
#'(begin d-s dtsi)))]
[(_ (vars:id ...) nm:struct-name (fs:fld-spec ...) . opts)
(with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
'typechecker:ignore #t)]
[dtsi (internal (syntax/loc stx (define-typed-struct-internal (vars ...) nm (fs ...))))])
[dtsi (syntax/loc stx (dtsi* (vars ...) nm (fs ...)))])
#'(begin d-s dtsi))]))
(define-syntax (require-typed-struct stx)
@ -283,7 +302,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(reverse (list #'sel ...))
(list mut ...)
#f))))
#,(internal #'(define-typed-struct-internal nm ([fld : ty] ...) #:type-only))
(dtsi* () 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)
@ -304,7 +323,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(list #'sel ...)
(list mut ...)
#f))))
#,(internal #'(define-typed-struct-internal (nm parent) ([fld : ty] ...) #:type-only))
(dtsi* () (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)

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

@ -13,7 +13,8 @@
(private parse-type)
scheme/match syntax/struct syntax/stx mzlib/trace unstable/syntax scheme/list
(only-in scheme/contract -> ->* case-> cons/c flat-rec-contract provide/contract any/c)
(for-template scheme/base scheme/contract unstable/poly-c (utils any-wrap) (only-in scheme/class object% is-a?/c subclass?/c)))
(for-template scheme/base scheme/contract unstable/poly-c (utils any-wrap)
(only-in scheme/class object% is-a?/c subclass?/c object-contract)))
(define (define/fixup-contract? stx)
(or (syntax-property stx 'typechecker:contract-def)
@ -135,7 +136,10 @@
(parameterize ([vars (cons (list n #'n* #'n*) (vars))])
#`(flat-rec-contract n* #,(t->c b)))))]
[(Value: #f) #'false/c]
[(Instance: _) #'(is-a?/c object%)]
[(Instance: (Class: _ _ (list (list name fcn) ...)))
(with-syntax ([(fcn-cnts ...) (map t->c fcn)]
[(names ...) name])
#'(object-contract (names fcn-cnts) ...))]
[(Class: _ _ _) #'(subclass?/c object%)]
[(Value: '()) #'null?]
[(Struct: nm par flds proc poly? pred? cert acc-ids)

4
collects/typed-scheme/rep/type-rep.ss
View File

@ -222,6 +222,10 @@
acc-ids)]
[#:key #f])
;; A structure type descriptor
;; s : struct
(dt StructType ([s Struct?]) [#:key 'struct-type])
;; the supertype of all of these values
(dt BoxTop () [#:fold-rhs #:base] [#:key 'box])
(dt VectorTop () [#:fold-rhs #:base] [#:key 'vector])

10
collects/typed-scheme/typecheck/def-binding.ss
View File

@ -1,11 +1,13 @@
#lang scheme/base
(require scheme/contract)
(require scheme/contract "../utils/utils.ss" scheme/struct-info)
(define-struct binding (name) #:transparent)
(define-struct (def-binding binding) (ty) #:transparent)
(define-struct (def-stx-binding binding) () #:transparent)
(define-struct (def-struct-stx-binding def-stx-binding) (static-info) #:transparent)
(provide/contract (struct binding ([name identifier?]))
(struct (def-binding binding) ([name identifier?] [ty any/c]))
(struct (def-stx-binding binding) ([name identifier?])))
(p/c (struct binding ([name identifier?]))
(struct (def-binding binding) ([name identifier?] [ty any/c]))
(struct (def-stx-binding binding) ([name identifier?]))
(struct (def-struct-stx-binding binding) ([name identifier?] [static-info (or/c #f struct-info?)])))

217
collects/typed-scheme/typecheck/provide-handling.ss
View File

@ -9,9 +9,10 @@
(private typed-renaming)
(rep type-rep)
(utils tc-utils)
scheme/contract/private/provide
unstable/syntax
"def-binding.ss")
scheme/contract/private/provide unstable/list
unstable/debug
unstable/syntax scheme/struct-info scheme/match
"def-binding.ss" syntax/parse)
(require (for-template scheme/base
scheme/contract))
@ -20,104 +21,136 @@
get-alternate)
(define (provide? form)
(kernel-syntax-case form #f
(syntax-parse form
#:literals (#%provide)
[(#%provide . rest) form]
[_ #f]))
(define (remove-provides forms)
(filter (lambda (e) (not (provide? e))) (syntax->list forms)))
(define (renamer id #:alt [alt #f])
(if alt
(make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt)
(make-rename-transformer (syntax-property id 'not-free-identifier=? #t))))
(define (generate-prov stx-defs val-defs pos-blame-id)
(define mapping (make-free-identifier-mapping))
(lambda (form)
(define (mem? i vd)
(cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car]
[else #f]))
(define (lookup-id i vd)
(def-binding-ty (mem? i vd)))
(define (mk internal-id external-id)
(cond
;; if it's already done, do nothing
[(free-identifier-mapping-get mapping internal-id
;; if it wasn't there, put it in, and skip this case
(lambda ()
(free-identifier-mapping-put! mapping internal-id #t)
#f))
#'(begin)]
[(mem? internal-id val-defs)
=>
(lambda (b)
(with-syntax ([id internal-id]
[out-id external-id])
(cond [(type->contract (def-binding-ty b) (lambda () #f) #:out #t)
=>
(lambda (cnt)
(with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))]
[module-source pos-blame-id]
[the-contract (generate-temporary 'generated-contract)])
#`(begin
(define the-contract #,cnt)
(define-syntax cnt-id
(make-provide/contract-transformer
(quote-syntax the-contract)
(quote-syntax id)
(quote-syntax module-source)))
(define-syntax export-id
(if (unbox typed-context?)
(renamer #'id #:alt #'cnt-id)
(renamer #'cnt-id)))
(#%provide (rename export-id out-id)))))]
[else
(with-syntax ([(export-id error-id) (generate-temporaries #'(id id))])
#`(begin
(define-syntax error-id
(lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id))))
(define-syntax export-id
(if (unbox typed-context?)
(renamer #'id #:alt #'error-id)
(renamer #'error-id)))
(provide (rename-out [export-id out-id]))))])))]
[(mem? internal-id stx-defs)
=>
(lambda (b)
(with-syntax ([id internal-id]
[out-id external-id])
(with-syntax ([(export-id error-id) (generate-temporaries #'(id id))])
#`(begin
(define-syntax error-id
(lambda (stx)
(tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'out-id))))
(define-syntax export-id
(if (unbox typed-context?)
(begin
(add-alias #'export-id #'id)
(renamer #'id #:alt #'error-id))
(renamer #'error-id)))
(provide (rename-out [export-id out-id]))))))]
[(eq? (syntax-e internal-id) (syntax-e external-id))
#`(provide #,internal-id)]
[else #`(provide (rename-out [#,internal-id #,external-id]))]))
(kernel-syntax-case form #f
;; maps ids defined in this module to an identifier which is the possibly-contracted version of the key
(define mapping (make-free-identifier-mapping))
(define (mem? i vd)
(cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car]
[else #f]))
;; generate-contract-defs : listof[def-binding] listof[def-binding] id -> syntax -> syntax
;; val-defs: define-values in this module
;; stx-defs: define-syntaxes in this module
;; pos-blame-id: a #%variable-reference for the module
;; internal-id : the id being provided
;; if `internal-id' is defined in this module, we will produce a (begin def ... provide) block
;; and a name to provide instead of internal-id
;; anything already recorded in the mapping is given an empty (begin) and the already-recorded id
;; otherwise, we will map internal-id to the fresh id in `mapping'
(define ((generate-prov stx-defs val-defs pos-blame-id) form)
;; mk : id [id] -> (values syntax id)
(define (mk internal-id [new-id (generate-temporary internal-id)])
(cond
;; if it's already done, do nothing
[(free-identifier-mapping-get mapping internal-id
;; if it wasn't there, put it in, and skip this case
(lambda ()
(free-identifier-mapping-put! mapping internal-id new-id)
#f))
=> (lambda (mapped-id)
(values #'(begin) mapped-id))]
[(mem? internal-id val-defs)
=>
(lambda (b)
(values
(with-syntax ([id internal-id])
(cond [(type->contract (def-binding-ty b) (lambda () #f) #:out #t)
=>
(lambda (cnt)
(with-syntax ([(cnt-id) (generate-temporaries #'(id))]
[export-id new-id]
[module-source pos-blame-id]
[the-contract (generate-temporary 'generated-contract)])
#`(begin
(define the-contract #,cnt)
(define-syntax cnt-id
(make-provide/contract-transformer
(quote-syntax the-contract)
(quote-syntax id)
(quote-syntax out-id)
(quote-syntax module-source)))
(define-syntax export-id
(if (unbox typed-context?)
(renamer #'id #:alt #'cnt-id)
(renamer #'cnt-id))))))]
[else
(with-syntax ([(error-id) (generate-temporaries #'(id))]
[export-id new-id])
#`(begin
(define-syntax error-id
(lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id))))
(define-syntax export-id
(if (unbox typed-context?)
(renamer #'id #:alt #'error-id)
(renamer #'error-id)))))]))
new-id))]
[(mem? internal-id stx-defs)
=>
(lambda (b)
(define (mk-untyped-syntax defn-id internal-id)
(match b
[(struct def-struct-stx-binding (_ (? struct-info? si)))
(match-let ([(list type-desc constr pred (list accs ...) muts super) (extract-struct-info si)])
(let-values ([(defns new-ids) (map/values 2 (lambda (e) (if (identifier? e)
(mk e)
(values #'(begin) e)))
(list* type-desc constr pred super accs))])
(with-syntax ([(type-desc* constr* pred* super* accs* ...) (for/list ([i new-ids])
(if (identifier? i)
#`(syntax #,i)
i))])
#`(begin
#,@defns
(define-syntax #,defn-id
(list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*))))))]
[_
#`(define-syntax #,defn-id
(lambda (stx)
(tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'#,internal-id))))]))
(with-syntax* ([id internal-id]
[export-id new-id]
[(untyped-id) (generate-temporaries #'(id))])
(values
#`(begin
#,(mk-untyped-syntax #'untyped-id internal-id)
(define-syntax export-id
(if (unbox typed-context?)
(begin
(add-alias #'export-id #'id)
(renamer #'id #:alt #'untyped-id))
(renamer #'untyped-id))))
new-id)))]
;; otherwise, not defined in this module, not our problem
[else (values #'(begin) internal-id)]))
;; do-one : id [id] -> syntax
(define (do-one internal-id [external-id internal-id])
(define-values (defs id) (mk internal-id))
#`(begin #,defs (provide (rename-out [#,id #,external-id]))))
(syntax-parse form #:literals (#%provide)
[(#%provide form ...)
(map
(lambda (f)
(parameterize ([current-orig-stx f])
(syntax-case* f (struct rename all-defined protect all-defined-except all-from all-from-except)
(lambda (a b) (eq? (syntax-e a) (syntax-e b)))
[id
(identifier? #'id)
(mk #'id #'id)]
[(rename in out)
(mk #'in #'out)]
[(protect . _)
(tc-error "provide: protect not supported by Typed Scheme")]
[_ (int-err "unknown provide form")])))
(syntax->list #'(form ...)))]
[_ (int-err "non-provide form! ~a" (syntax->datum form))])))
(for/list ([f (syntax->list #'(form ...))])
(parameterize ([current-orig-stx f])
(syntax-parse f
[i:id
(do-one #'i)]
[((~datum rename) in out)
(do-one #'in #'out)]
[((~datum protect) . _)
(tc-error "provide: protect not supported by Typed Scheme")]
[_ (int-err "unknown provide form")])))]
[_ (int-err "non-provide form! ~a" (syntax->datum form))]))

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

@ -66,11 +66,11 @@
(values (reverse getters) (reverse setters))
(loop (cddr l) (cons (car l) getters) (cons (cadr l) setters)))))
(match (build-struct-names nm flds #f (not setters?) nm)
[(list _ maker pred getters/setters ...)
[(list sty maker pred getters/setters ...)
(if setters?
(let-values ([(getters setters) (split getters/setters)])
(values maker pred getters setters))
(values maker pred getters/setters #f))]))
(values sty maker pred getters setters))
(values sty maker pred getters/setters #f))]))
;; gets the fields of the parent type, if they exist
;; Option[Struct-Ty] -> Listof[Type]
@ -88,6 +88,7 @@
#:type-wrapper [type-wrapper values]
#:pred-wrapper [pred-wrapper values]
#:mutable [setters? #f]
#:struct-info [si #f]
#:proc-ty [proc-ty #f]
#:maker [maker* #f]
#:predicate [pred* #f]
@ -95,7 +96,7 @@
#: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?))
(define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?))
(let* ([name (syntax-e nm)]
[fld-types (append parent-field-types types)]
[sty (make-Struct name parent fld-types proc-ty poly? pred (syntax-local-certifier) getters)]
@ -109,6 +110,7 @@
#:pred-wrapper pred-wrapper
#:maker (or maker* maker)
#:predicate (or pred* pred)
#:struct-info si
#:constructor-return cret))))
;; generate names, and register the approriate types give field types and structure type
@ -116,24 +118,28 @@
;; 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 values]
#:struct-info [si #f]
#:type-wrapper [type-wrapper values]
#:pred-wrapper [pred-wrapper values]
#:maker [maker* #f]
#:predicate [pred* #f]
#:constructor-return [cret #f])
;; create the approriate names that define-struct will bind
(define-values (maker pred getters setters) (struct-names nm flds setters?))
(define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?))
;; the type name that is used in all the types
(define name (type-wrapper (make-Name nm)))
;; the list of names w/ types
(define bindings
(append
(list (cons (or maker* maker)
(wrapper (->* external-fld-types (if cret cret name))))
(cons (or pred* pred)
(make-pred-ty (if setters?
(make-StructTop sty)
(pred-wrapper name)))))
(list
(cons struct-type-id
(make-StructType sty))
(cons (or maker* maker)
(wrapper (->* external-fld-types (if cret cret name))))
(cons (or pred* pred)
(make-pred-ty (if setters?
(make-StructTop sty)
(pred-wrapper name)))))
(for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)])
(let ([func (if setters?
(->* (list name) t)
@ -146,7 +152,7 @@
null)))
(register-type-name nm (wrapper sty))
(cons
(make-def-stx-binding nm)
(make-def-struct-stx-binding nm si)
(for/list ([e bindings])
(let ([nm (car e)]
[t (cdr e)])
@ -207,6 +213,7 @@
#:proc-ty proc-ty-parsed
#:maker maker
#:predicate pred
#:struct-info (syntax-property nm/par 'struct-info)
#:constructor-return (and cret (parse-type cret))
#:mutable mutable
#:type-only type-only))

6
collects/typed-scheme/types/subtype.ss
View File

@ -333,6 +333,12 @@
(subtype* A0 t t*)]
[((Instance: t) (Instance: t*))
(subtype* A0 t t*)]
[((Class: '() '() (list (and s (list names meths )) ...))
(Class: '() '() (list (and s* (list names* meths*)) ...)))
(for/fold ([A A0])
([n names*] [m meths*])
(cond [(assq n s) => (lambda (spec) (subtype* A (cadr spec) m))]
[else (fail! s t)]))]
;; otherwise, not a subtype
[(_ _) (fail! s t) #;(printf "failed")])))]))))

6
collects/typed-scheme/utils/utils.ss
View File

@ -172,11 +172,9 @@ at least theoretically.
(define-syntax-class clause
#:literals ()
#:attributes (i)
(pattern [struct nm:id (flds ...)]
#:fail-unless (eq? (syntax-e #'struct) 'struct) #f
(pattern [(~datum struct) (~or nm:id (nm:id super:id)) (flds ...)]
#:with i #'(struct-out nm))
(pattern [rename out:id in:id cnt:expr]
#:fail-unless (eq? (syntax-e #'rename) 'rename) #f
(pattern [(~datum rename) out:id in:id cnt:expr]
#:with i #'(rename-out [out in]))
(pattern [i:id cnt:expr]))
(syntax-parse stx

7
collects/unstable/debug.ss
View File

@ -12,7 +12,10 @@
(for/list ([arg 'args]
[val l])
(printf "\t~a: ~a~n" arg val))
(let ([e (apply f l)])
(printf "result was ~a~n" e)
(let ([e (with-handlers ([values (lambda (exn)
(printf "~a raised exception ~a~n" 'f exn)
(raise exn))])
(apply f l))])
(printf "~a result was ~a~n" 'f e)
e)))]
[(_ f . args) (debug (f . args))]))

30
collects/unstable/list.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/contract
scheme/dict)
scheme/dict
(for-syntax scheme/base))
; list-prefix : list? list? -> boolean?
; Is l a prefix or r?
@ -84,3 +85,30 @@
(same? key-item prev))
(car items)
(loop (cdr items) (cons key-item sofar)))))))
;; sam added from carl
(define-syntax (values->list stx)
(syntax-case stx ()
[(vl expr)
(syntax/loc stx
(call-with-values (lambda () expr) list))]))
(define (map/list n f ls)
(cond
[(andmap null? ls) (build-list n (lambda (i) null))]
[(andmap pair? ls)
(let* ([vs (values->list (apply f (map car ls)))]
[k (length vs)])
(unless (= k n)
(error 'map/values
"~a produced ~a values, not ~a: ~e"
f k n vs))
(map cons vs (map/list n f (map cdr ls))))]
[else (error 'map/values "list lengths differ")]))
(define (map/values n f . ls)
(apply values (map/list n f ls)))
(provide map/values)

24
collects/unstable/scribblings/list.scrbl
View File

@ -79,3 +79,27 @@ true value. The procedures @scheme[equal?], @scheme[eqv?], and
(dict-map id-t list)
]
}
@addition{Carl Eastlund}
@defproc[(map/values [n natural-number/c]
[f (-> A ... (values B_1 ... B_n))]
[lst (listof A)]
...)
(values (listof B_1) ... (listof B_n))]{
Produces lists of the respective values of @scheme[f] applied to the elements in
@scheme[lst ...] sequentially.
@defexamples[
#:eval the-eval
(map/values
3
(lambda (x)
(values (+ x 1) x (- x 1)))
(list 1 2 3))
]
}