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

Added mutable lists to Typed Scheme.

Browse Source
This commit is contained in:
Vincent St-Amour 2010-06-15 17:41:32 -04:00
parent bb0747f589
commit a31a7b0718
5 changed files with 37 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/typed-scheme/private/base-env.rkt
View File

@ -889,8 +889,20 @@
((a b . -> . c) . -> . (a . -> . (b . -> . c)))))]
;; mutable pairs
[mcons (-poly (a b) (-> a b (-mpair a b)))]
[mcar (-poly (a b) (-> (-mpair a b) a))]
[mcdr (-poly (a b) (-> (-mpair a b) b))]
[set-mcar! (-poly (a b) (-> (-mpair a b) a -Void))]
[set-mcdr! (-poly (a b) (-> (-mpair a b) b -Void))]
[mcar (-poly (a b)
(cl->* (-> (-mpair a b) a)
(-> (-mlst a) a)))]
[mcdr (-poly (a b)
(cl->* (-> (-mpair a b) b)
(-> (-mlst a) (-mlst a))))]
[set-mcar! (-poly (a b)
(cl->* (-> (-mpair a b) a -Void)
(-> (-mlst a) a -Void)))]
[set-mcdr! (-poly (a b)
(cl->* (-> (-mpair a b) b -Void)
(-> (-mlst a) (-mlst a) -Void)))]
[mpair? (make-pred-ty (make-MPairTop))]
[mlist (-poly (a) (->* (list) a (-mlst a)))]
[mlength (-poly (a) (-> (-mlst a) -Nat))]
[mreverse! (-poly (a) (-> (-mlst a) (-mlst a)))]
[mappend (-poly (a) (->* (list) (-mlst a) (-mlst a)))]

1
collects/typed-scheme/private/base-types-new.rkt
View File

@ -55,5 +55,6 @@
[Nothing (Un)]
[Pairof (-poly (a b) (-pair a b))]
[MPairof (-poly (a b) (-mpair a b))]
[MListof (-poly (a) (-mlst a))]
[Sequenceof (-poly (a) (-seq a))]

10
collects/typed-scheme/types/abbrev.rkt
View File

@ -15,7 +15,8 @@
(for-template scheme/base scheme/contract scheme/promise scheme/tcp scheme/flonum))
(provide (all-defined-out)
(rename-out [make-Listof -lst]))
(rename-out [make-Listof -lst]
[make-MListof -mlst]))
;; convenient constructors
@ -36,6 +37,7 @@
(define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec))))
(define (make-MListof elem) (-mu mlist-rec (*Un (-val null) (-mpair elem mlist-rec))))
(define (-lst* #:tail [tail (-val null)] . args)
(for/fold ([tl tail]) ([a (reverse args)]) (-pair a tl)))
@ -62,6 +64,12 @@
[(_ elem-pats)
#'(app untuple (? values elem-pats))])))
(define-match-expander MListof:
(lambda (stx)
(syntax-parse stx
[(_ elem-pat)
#'(Mu: var (Union: (list (Value: '()) (MPair: elem-pat (F: var)))))])))
(d/c (-result t [f -no-filter] [o -no-obj])
(c:->* (Type/c) (FilterSet? Object?) Result?)

9
collects/typed-scheme/types/convenience.rkt
View File

@ -35,9 +35,14 @@
[(Value: 0) -Nat]
[(Mu: var (Union: (list (Value: '()) (Pair: _ (F: var))))) t*]
[(Pair: t1 (Value: '())) (-lst t1)]
[(Pair: t1 t2)
[(MPair: t1 (Value: '())) (-mlst t1)]
[(or (Pair: t1 t2) (MPair: t1 t2))
(let ([t-new (loop t2)])
(if (type-equal? (-lst t1) t-new)
(if (type-equal? ((match t*
[(Pair: _ _) -lst]
[(MPair: _ _) -mlst])
t1)
t-new)
t-new
(exit t)))]
[_ (exit t)]))))

4
collects/typed-scheme/types/printer.rkt
View File

@ -133,6 +133,10 @@
(fp "(Listof ~a)" elem-ty)]
[(Mu: var (Union: (list (Pair: elem-ty (F: var)) (Value: '()))))
(fp "(Listof ~a)" elem-ty)]
[(Mu: var (Union: (list (Value: '()) (MPair: elem-ty (F: var)))))
(fp "(MListof ~a)" elem-ty)]
[(Mu: var (Union: (list (MPair: elem-ty (F: var)) (Value: '()))))
(fp "(MListof ~a)" elem-ty)]
[(Value: v) (cond [(or (symbol? v) (null? v))
(fp "'~a" v)]
[else (fp "~a" v)])]