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

Progress on Rep.

Browse Source 
svn: r17924
This commit is contained in:
Sam Tobin-Hochstadt 2010-02-01 15:51:32 +00:00
parent 9789615ed9
commit 94029a06c9
4 changed files with 49 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/typed-scheme/rep/free-variance.ss
View File

@ -32,17 +32,17 @@
(define ((input/c tbl) val) (hash-ref tbl val #f)) (define ((input/c tbl) val) (hash-ref tbl val #f))
(define (free-idxs* t) #;
(define (free-idxs* t) #;(Type-free-idxs t)
(hash-ref index-table t (lambda _ (int-err "type ~a not in index-table" t)))) (hash-ref index-table t (lambda _ (int-err "type ~a not in index-table" t))))
(define (free-vars* t) #;
(define (free-vars* t) #;(Type-free-vars t)
(hash-ref var-table t (lambda _ (int-err "type ~a not in var-table" t)))) (hash-ref var-table t (lambda _ (int-err "type ~a not in var-table" t))))
(define empty-hash-table (make-immutable-hasheq null)) (define empty-hash-table (make-immutable-hasheq null))
(p/c [free-vars* (-> (input/c var-table) (hash/c symbol? variance?))] (provide empty-hash-table make-invariant input/c variance?)
[free-idxs* (-> (input/c index-table) (hash/c exact-nonnegative-integer? variance?))])
(provide empty-hash-table make-invariant)
;; frees = HT[Idx,Variance] where Idx is either Symbol or Number ;; frees = HT[Idx,Variance] where Idx is either Symbol or Number
;; (listof frees) -> frees ;; (listof frees) -> frees

76
collects/typed-scheme/rep/rep-utils.ss
View File

@ -25,8 +25,12 @@
(provide == defintern hash-id (for-syntax fold-target)) (provide == defintern hash-id (for-syntax fold-target))
(define-struct Rep (seq
free-vars
free-idxs))
(define-for-syntax fold-target #'fold-target) (define-for-syntax fold-target #'fold-target)
(define-for-syntax default-fields (list #'seq #;#;#'free-vars #'free-idxs)) (define-for-syntax default-fields (list #'seq #'free-vars #'free-idxs))
(define-for-syntax (mk par ht-stx key?) (define-for-syntax (mk par ht-stx key?)
(define-syntax-class opt-cnt-id (define-syntax-class opt-cnt-id
@ -57,10 +61,9 @@
#:with f2 #'empty-hash-table #:with f2 #'empty-hash-table
#:with def #'(begin)) #:with def #'(begin))
(pattern e:expr (pattern e:expr
#:with id (generate-temporary) #:with def #'(begin)
#:with def #'(define id e) #:with f1 #'(e Rep-free-vars)
#:with f1 #'(id free-vars*) #:with f2 #'(e Rep-free-idxs)))
#:with f2 #'(id free-idxs*)))
(define-syntax-class (fold-pat fold-name) (define-syntax-class (fold-pat fold-name)
#:transparent #:transparent
#:attributes (e proc) #:attributes (e proc)
@ -79,13 +82,13 @@
#:with ex (format-id #'nm "~a:" #'nm) #:with ex (format-id #'nm "~a:" #'nm)
#:with fold (format-id #f "~a-fold" #'nm) #:with fold (format-id #f "~a-fold" #'nm)
#:with kw (string->keyword (symbol->string (syntax-e #'nm))) #:with kw (string->keyword (symbol->string (syntax-e #'nm)))
#:with *maker (format-id #'nm "*~a" #'nm) #:with *maker (format-id #'nm "*~a" #'nm)))
#:with **maker (format-id #'nm "**~a" #'nm)))
(lambda (stx) (lambda (stx)
(syntax-parse stx (syntax-parse stx
[(dform nm:form-nm flds:idlist (~or [(dform nm:form-nm flds:idlist (~or
(~optional (~and (~fail #:unless key? "#:key not allowed") (~optional (~and (~fail #:unless key? "#:key not allowed")
[#:key key-expr:expr])) [#:key key-expr:expr])
#:defaults ([key-expr #'#f]))
(~optional [#:intern intern?:expr] (~optional [#:intern intern?:expr]
#:defaults #:defaults
([intern? (syntax-parse #'flds.fs ([intern? (syntax-parse #'flds.fs
@ -95,8 +98,8 @@
(~optional [#:frees frees:frees-pat] (~optional [#:frees frees:frees-pat]
#:defaults #:defaults
([frees.def #'(begin)] ([frees.def #'(begin)]
[frees.f1 (combiner #'free-vars* #'flds.fs)] [frees.f1 (combiner #'Rep-free-vars #'flds.fs)]
[frees.f2 (combiner #'free-idxs* #'flds.fs)])) [frees.f2 (combiner #'Rep-free-idxs #'flds.fs)]))
(~optional [#:fold-rhs (~var fold-rhs (fold-pat #'nm.fold))] (~optional [#:fold-rhs (~var fold-rhs (fold-pat #'nm.fold))]
#:defaults #:defaults
([fold-rhs.proc ([fold-rhs.proc
@ -108,35 +111,13 @@
(~optional no-provide?:no-provide-kw)) ...) (~optional no-provide?:no-provide-kw)) ...)
(with-syntax* (with-syntax*
([(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)] ([(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)]
[*maker-cnt (if enable-contracts? [*maker-cnt (or (attribute cnt) #'(flds.cnt ... . -> . pred))]
(or (attribute cnt) #'(flds.cnt ... . -> . pred))
#'any/c)]
[provides (if (attribute no-provide?) [provides (if (attribute no-provide?)
#'(begin) #'(begin)
#`(begin #`(begin
(provide nm.ex pred acc ...) (provide nm.ex pred acc ...)
(p/c (rename nm.*maker maker *maker-cnt))))] (p/c (rename nm.*maker maker *maker-cnt))))]
[intern [(ign-pats ...) (append (map (lambda (x) #'_) default-fields) (if key? (list #'_) (list)))])
(let ([mk (lambda (int)
(if key?
#`(defintern (nm.**maker . flds.fs) maker #,int
#:extra-args #,(attribute key-expr))
#`(defintern (nm.**maker . flds.fs) maker #,int
#:extra-args)))])
(mk #'intern?))]
[(ign-pats ...) (append (map (lambda (x) #'_) default-fields) (if key? (list #'_) (list)))]
[frees
(quasisyntax/loc stx
(w/c nm ([nm.*maker *maker-cnt])
#,(syntax/loc #'nm
(define (nm.*maker . flds.fs)
(define v (nm.**maker . flds.fs))
frees.def
(unless-in-table
var-table v
(hash-set! var-table v frees.f1)
(hash-set! index-table v frees.f2))
v))))])
#`(begin #`(begin
(define-struct (nm #,par) flds.fs #:inspector #f) (define-struct (nm #,par) flds.fs #:inspector #f)
(define-match-expander nm.ex (define-match-expander nm.ex
@ -147,10 +128,15 @@
(syntax/loc s (struct nm pat))]))) (syntax/loc s (struct nm pat))])))
(begin-for-syntax (begin-for-syntax
(hash-set! #,ht-stx 'nm.kw (list #'nm.ex #'flds.fs fold-rhs.proc #f))) (hash-set! #,ht-stx 'nm.kw (list #'nm.ex #'flds.fs fold-rhs.proc #f)))
(w/c nm () #,(quasisyntax/loc stx
intern (w/c nm ([nm.*maker *maker-cnt])
frees) #,(quasisyntax/loc #'nm
provides))]))) (defintern (nm.*maker . flds.fs) maker intern?
#:extra-args
frees.f1 frees.f2
#,@(begin
(if key? (list #'key-expr) null))))))
provides))])))
(define-for-syntax (mk-fold ht type-rec-id rec-ids kws) (define-for-syntax (mk-fold ht type-rec-id rec-ids kws)
(lambda (stx) (lambda (stx)
@ -214,9 +200,9 @@
#:transparent #:transparent
(pattern [i:id (~optional (~and #:key (pattern [i:id (~optional (~and #:key
(~bind [key? #'#t] (~bind [key? #'#t]
[(fld-names 1) (append default-fields (list #'key))])) [(fld-names 1) (list #'key)]))
#:defaults ([key? #'#f] #:defaults ([key? #'#f]
[(fld-names 1) default-fields])) [(fld-names 1) null]))
#:d d-id:id])) #:d d-id:id]))
(define-syntax-class type-name (define-syntax-class type-name
#:transparent #:transparent
@ -239,7 +225,7 @@
(for-syntax i.ht ... i.rec-id ...)) (for-syntax i.ht ... i.rec-id ...))
(define-syntax i.d-id (mk #'i.name #'i.ht i.key?)) ... (define-syntax i.d-id (mk #'i.name #'i.ht i.key?)) ...
(define-for-syntax i.ht (make-hasheq)) ... (define-for-syntax i.ht (make-hasheq)) ...
(define-struct/printer i.name (i.fld-names ...) (lambda (a b c) ((unbox i.printer) a b c))) ... (define-struct/printer (i.name Rep) (i.fld-names ...) (lambda (a b c) ((unbox i.printer) a b c))) ...
(define-for-syntax i.rec-id #'i.rec-id) ... (define-for-syntax i.rec-id #'i.rec-id) ...
(provide i.case ...) (provide i.case ...)
(define-syntaxes (i.case ...) (define-syntaxes (i.case ...)
@ -260,4 +246,10 @@
[LatentObject #:d dlo] [LatentObject #:d dlo]
[PathElem #:d dpe]) [PathElem #:d dpe])
(provide PathElem?) (provide PathElem? (rename-out [Rep-seq Type-seq]
[Rep-free-vars free-vars*]
[Rep-free-idxs free-idxs*]))
(p/c (struct Rep ([seq integer?]
[free-vars (hash/c symbol? variance?)]
[free-idxs (hash/c exact-nonnegative-integer? variance?)])))

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

@ -234,7 +234,7 @@
(for/fold ([sorted? #t] (for/fold ([sorted? #t]
[last -1]) [last -1])
([e es]) ([e es])
(let ([seq (Type-seq e)]) (let ([seq (Rep-seq e)])
(values (values
(and sorted? (and sorted?
(< last seq)) (< last seq))

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

@ -150,13 +150,14 @@ at least theoretically.
(define custom-printer (make-parameter #t)) (define custom-printer (make-parameter #t))
(define-syntax (define-struct/printer stx) (define-syntax (define-struct/printer stx)
(syntax-case stx () (syntax-parse stx
[(form name (flds ...) printer) [(form name (flds ...) printer:expr)
#`(define-struct/properties name (flds ...) #`(define-struct name (flds ...)
#:property prop:custom-write
#,(if printing? #,(if printing?
#'([prop:custom-write (lambda (a b c) (if (custom-printer) (printer a b c) (pseudo-printer a b c)))]) #'(lambda (a b c) (if (custom-printer) (printer a b c) (pseudo-printer a b c)))
#'([prop:custom-write pseudo-printer])) #'pseudo-printer)
#f)])) #:inspector #f)]))
;; turn contracts on and off - off by default for performance. ;; turn contracts on and off - off by default for performance.