diff --git a/collects/typed-scheme/no-check.ss b/collects/typed-scheme/no-check.ss index bd104f61..a1a7601c 100644 --- a/collects/typed-scheme/no-check.ss +++ b/collects/typed-scheme/no-check.ss @@ -1,5 +1,30 @@ #lang scheme/base -(require "private/prims.ss") +#;(require "private/prims.ss") (provide (all-from-out scheme/base) - (all-from-out "private/prims.ss")) + (all-defined-out) + #;(all-from-out "private/prims.ss")) + +(define-syntax-rule (define-type-alias . _) (begin)) + +(define-syntax-rule (define: nm _ _ . body) + (define nm . body)) + +(define-syntax-rule (ann e . rest) e) + +(define-syntax-rule (require/typed mod [id . _] ...) + (require (only-in mod id ...))) + +(define-syntax-rule (: . args) (begin)) + +(define-syntax let: + (syntax-rules () + [(_ ([id _ _ . rest] ...) . b) + (let ([id . rest] ...) . b)] + [(_ id _ _ ([ids _ _ e] ...) . b) + (let id ([ids e] ...) . b)])) + +(define-syntax-rule (lambda: ([id . rest] ...) . b) + (lambda (id ...) . b)) + +(define-syntax-rule (λ: . arg) (lambda: . arg)) diff --git a/collects/typed-scheme/rep/interning.ss b/collects/typed-scheme/rep/interning.ss index 151b9769..68b393b8 100644 --- a/collects/typed-scheme/rep/interning.ss +++ b/collects/typed-scheme/rep/interning.ss @@ -1,14 +1,17 @@ #lang scheme/base -(require syntax/boundmap (for-syntax scheme/base stxclass)) +(require syntax/boundmap (for-syntax scheme/base stxclass) + macro-debugger/stepper) (provide defintern hash-id) (define-syntax (defintern stx) (syntax-parse stx - [(_ name+args make-name key (~or [#:extra-arg e:expr] #:opt) ...) - #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e)] - [(_ (*name:id arg:id ...) make-ht make-name key-expr (~or [#:extra-arg e:expr] #:opt) ...) + [(_ name+args make-name key (~or [#:extra-arg e:expr] #:opt) ...) + (if #'e + #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e) + #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key))] + [(_ (*name:id arg:id ...) make-ht make-name key-expr (~or [#:extra-arg e:expr]) ...) #'(define *name (let ([table (make-ht)]) (lambda (arg ...) @@ -16,7 +19,7 @@ (let ([key key-expr]) (hash-ref table key (lambda () - (let ([new (make-name (count!) e arg ...)]) + (let ([new (make-name (count!) e ... arg ...)]) (hash-set! table key new) new)))))))])) diff --git a/collects/typed-scheme/private/type-effect-printer.ss b/collects/typed-scheme/rep/type-effect-printer.ss similarity index 85% rename from collects/typed-scheme/private/type-effect-printer.ss rename to collects/typed-scheme/rep/type-effect-printer.ss index fc51ae36..c63b650a 100644 --- a/collects/typed-scheme/private/type-effect-printer.ss +++ b/collects/typed-scheme/rep/type-effect-printer.ss @@ -1,7 +1,7 @@ #lang scheme/base (require "../utils/utils.ss") -(require (rep type-rep filter-rep rep-utils) +(require (rep type-rep filter-rep object-rep rep-utils) (utils tc-utils) scheme/match) @@ -30,7 +30,10 @@ (define (print-latentfilter c port write?) (define (fp . args) (apply fprintf port args)) (match c - [(LFilterSet: thn els) (fp "(~a | ~a)") thn els] + [(LFilterSet: thn els) (fp "(") + (for ([i thn]) (fp "~a " i)) (fp "|") + (for ([i els]) (fp " ~a" i)) + (fp")")] [(LNotTypeFilter: type path idx) (fp "(! ~a @ ~a ~a)" type path idx)] [(LTypeFilter: type path idx) (fp "(~a @ ~a ~a)" type path idx)] [(LBot:) (fp "LBot")])) @@ -38,11 +41,26 @@ (define (print-filter c port write?) (define (fp . args) (apply fprintf port args)) (match c - [(FilterSet: thn els) (fp "(~a | ~a)") thn els] + [(FilterSet: thn els) (fp "(") + (for ([i thn]) (fp "~a " i)) (fp "|") + (for ([i els]) (fp " ~a" i)) + (fp")")] [(NotTypeFilter: type path id) (fp "(! ~a @ ~a ~a)" type path (syntax-e id))] [(TypeFilter: type path id) (fp "(~a @ ~a ~a)" type path (syntax-e id))] [(Bot:) (fp "Bot")])) +(define (print-pathelem c port write?) + (define (fp . args) (apply fprintf port args)) + (match c + [(CarPE:) (fp "car")] + [(CdrPE:) (fp "cdr")] + [(StructPE: t i) (fp "(~a ~a)" t i)])) + +(define (print-latentobject c port write?) + (define (fp . args) (apply fprintf port args)) + (match c + [(LEmpty:) (fp "")] + [(LPath: pes i) (fp "~a" (append pes (list i)))])) ;; print out a type ;; print-type : Type Port Boolean -> Void @@ -145,7 +163,7 @@ (Vector: (F: x)) (Box: (F: x)))))) (fp "SyntaxObject")] - [(Mu-name: name body) (fp "(mu ~a ~a ~a)" (Type-seq c) name body)] + [(Mu-name: name body) (fp "(Rec ~a ~a)" name body)] ;; FIXME - this should not be used #; [(Scope: sc) (fp "(Scope ~a)" sc)] @@ -160,3 +178,5 @@ (set-box! print-type* print-type) (set-box! print-filter* print-filter) (set-box! print-latentfilter* print-latentfilter) +(set-box! print-latentobject* print-latentobject) +(set-box! print-pathelem* print-pathelem) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index e6cdd5c5..e791defb 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -122,7 +122,6 @@ ;; types : Listof[Type] (dt Values ([rs (listof Result?)]) - #:no-provide [#:frees (λ (f) (combine-frees (map f rs)))] [#:fold-rhs (*Values (map type-rec-id rs))]) @@ -315,11 +314,6 @@ [(type