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

Add `current-continuation-marks'

Browse Source 
Add some exns
Test require substructs

svn: r12726

original commit: 238b248ad5304189396008634e8a62780fb8fb7f
This commit is contained in:
Sam Tobin-Hochstadt 2008-12-08 03:10:12 +00:00
parent df8d714918
commit f168aa06c3
4 changed files with 31 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

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

@ -558,3 +558,5 @@
;; string.ss
[real->decimal-string (N [-Nat] . ->opt . -String)]
[current-continuation-marks (-> -Cont-Mark-Set)]

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

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

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

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