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

checkpoint again

Browse Source 
svn: r13718
This commit is contained in:
Sam Tobin-Hochstadt 2009-02-18 02:58:47 +00:00
parent 7d5581b06f
commit c0861fd39b
3 changed files with 43 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
collects/typed-scheme/rep/filter-rep.ss
View File

@ -4,43 +4,29 @@
(require mzlib/etc) (require mzlib/etc)
(require "rep-utils.ss" "free-variance.ss") (require "rep-utils.ss" "free-variance.ss")
(df Bot () [#:fold-rhs #:base])
(df TypeFilter ([t Type?] [p (listof PathElem?)] [v identifier?])
[#:intern (list t p (hash-id v))]
[#:frees (combine-frees (map free-vars* (cons t p)))
(combine-frees (map free-idxs* (cons t p)))]
[#:fold-rhs (*TypeFilter (type-rec-id t) (map pathelem-rec-id p) v)])
(df NotTypeFilter ([t Type?] [p (listof PathElem?)] [v identifier?])
[#:intern (list t p (hash-id v))]
[#:frees (combine-frees (map free-vars* (cons t p)))
(combine-frees (map free-idxs* (cons t p)))]
[#:fold-rhs (*NotTypeFilter (type-rec-id t) (map pathelem-rec-id p) v)])
#| (dlf LBot () [#:fold-rhs #:base])
(de True-Effect () [#:frees #f] [#:fold-rhs #:base]) (dlf LTypeFilter ([t Type?] [p (listof PathElem?)])
[#:frees (combine-frees (map free-vars* (cons t p)))
(combine-frees (map free-idxs* (cons t p)))]
[#:fold-rhs (*LTypeFilter (type-rec-id t) (map pathelem-rec-id p))])
(de False-Effect () [#:frees #f] [#:fold-rhs #:base]) (dlf LNotTypeFilter ([t Type?] [p (listof PathElem?)])
[#:frees (combine-frees (map free-vars* (cons t p)))
;; v is an identifier (combine-frees (map free-idxs* (cons t p)))]
(de Var-True-Effect ([v identifier?]) [#:intern (hash-id v)] [#:frees #f] [#:fold-rhs #:base]) [#:fold-rhs (*LNotTypeFilter (type-rec-id t) (map pathelem-rec-id p))])
;; v is an identifier
(de Var-False-Effect ([v identifier?]) [#:intern (hash-id v)] [#:frees #f] [#:fold-rhs #:base])
;; t is a Type
;; v is an identifier
(de Restrict-Effect ([t Type?] [v identifier?]) [#:intern (list t (hash-id v))] [#:frees (free-vars* t) (free-idxs* t)]
[#:fold-rhs (*Restrict-Effect (type-rec-id t) v)])
;; t is a Type
;; v is an identifier
(de Remove-Effect ([t Type?] [v identifier?])
[#:intern (list t (hash-id v))]
[#:frees (free-vars* t) (free-idxs* t)]
[#:fold-rhs (*Remove-Effect (type-rec-id t) v)])
;; t is a Type
(de Latent-Restrict-Effect ([t Type?]) [#:frees (free-vars* t) (free-idxs* t)]
[#:fold-rhs (*Latent-Restrict-Effect (type-rec-id t))])
;; t is a Type
(de Latent-Remove-Effect ([t Type?]) [#:frees (free-vars* t) (free-idxs* t)]
[#:fold-rhs (*Latent-Remove-Effect (type-rec-id t))])
(de Latent-Var-True-Effect () [#:frees #f] [#:fold-rhs #:base])
(de Latent-Var-False-Effect () [#:frees #f] [#:fold-rhs #:base])
;; could also have latent true/false effects, but seems pointless
|#

12
collects/typed-scheme/rep/object-rep.ss
View File

@ -2,21 +2,21 @@
(require scheme/match scheme/contract "rep-utils.ss" "free-variance.ss") (require scheme/match scheme/contract "rep-utils.ss" "free-variance.ss")
(dpe CarPE () [#:frees #f] [#:fold-rhs #:base]) (dpe CarPE () [#:fold-rhs #:base])
(dpe CdrPE () [#:frees #f] [#:fold-rhs #:base]) (dpe CdrPE () [#:fold-rhs #:base])
(dpe StructPE ([t Type?] [idx natural-number/c]) (dpe StructPE ([t Type?] [idx natural-number/c])
[#:frees (free-vars* t) (free-idxs* t)] [#:frees (free-vars* t) (free-idxs* t)]
[#:fold-rhs (*StructPE (type-rec-id t) idx)]) [#:fold-rhs (*StructPE (type-rec-id t) idx)])
(do Bot () [#:frees #f] [#:fold-rhs #:base]) (do Empty () [#:fold-rhs #:base])
(do Path ([p (listof PathElem?)] [v identifier?]) (do Path ([p (listof PathElem?)] [v identifier?])
[#:intern (list p (hash-id v))] [#:intern (list p (hash-id v))]
[#:frees (combine-frees (map free-vars* p)) (combine-frees (map free-idxs* p))] [#:frees (combine-frees (map free-vars* p)) (combine-frees (map free-idxs* p))]
[#:fold-rhs (*Path (map pathelem-rec-id t) v)]) [#:fold-rhs (*Path (map pathelem-rec-id p) v)])
(dlo LBot () [#:frees #f] [#:fold-rhs #:base]) (dlo LEmpty () [#:fold-rhs #:base])
(dlo LPath ([p (listof PathElem?)] [idx natural-number/c]) (dlo LPath ([p (listof PathElem?)] [idx natural-number/c])
[#:frees (combine-frees (map free-vars* p)) (combine-frees (map free-idxs* p))] [#:frees (combine-frees (map free-vars* p)) (combine-frees (map free-idxs* p))]
[#:fold-rhs (*LPath (map pathelem-rec-id t) idx)]) [#:fold-rhs (*LPath (map pathelem-rec-id p) idx)])

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

@ -19,7 +19,7 @@
(define-for-syntax fold-target #'fold-target) (define-for-syntax fold-target #'fold-target)
(define-for-syntax (mk par ht-stx) (define-for-syntax (mk par ht-stx key?)
(define-syntax-class opt-cnt-id (define-syntax-class opt-cnt-id
#:attributes (i cnt) #:attributes (i cnt)
(pattern i:id (pattern i:id
@ -80,7 +80,10 @@
(provide ex pred acc ...) (provide ex pred acc ...)
(p/c (rename *maker maker *maker-cnt))))] (p/c (rename *maker maker *maker-cnt))))]
[intern [intern
(let ([mk (lambda (int) #`(defintern (**maker . flds.fs) maker #,int #:extra-arg key-expr))]) (let ([mk (lambda (int) #`(defintern (**maker . flds.fs) maker #,int
#,@(if key?
#'(#:extra-arg key-expr)
#'())))])
(syntax-parse #'flds.fs (syntax-parse #'flds.fs
[_ #:when #'intern? [_ #:when #'intern?
(mk #'intern?)] (mk #'intern?)]
@ -121,20 +124,25 @@
(define-syntax (make-prim-type stx) (define-syntax (make-prim-type stx)
(define default-flds #'(seq)) (define default-flds #'(seq))
(define-syntax-class type-name-base (define-syntax-class type-name-base
#:attributes (i lower-s first-letter (fld-names 1)) #:attributes (i lower-s first-letter key? (fld-names 1))
#:transparent #:transparent
(pattern i:id (pattern i:id
#:with lower-s (string-downcase (symbol->string #'i.datum)) #:with lower-s (string-downcase (symbol->string #'i.datum))
#:when (printf "loc1: ~a~n" #'lower-s)
#:with (fld-names ...) default-flds #:with (fld-names ...) default-flds
#:with key? #'#f
#:with first-letter (string-ref #'lower-s 0)) #:with first-letter (string-ref #'lower-s 0))
(pattern [i:id #:d d-name:id] (pattern [i:id #:d d-name:id]
#:with (fld-names ...) default-flds #:with (fld-names ...) default-flds
#:with lower-s (string-downcase (symbol->string #'i.datum)) #:with lower-s (string-downcase (symbol->string #'i.datum))
#:with key? #'#f
#:with first-letter (symbol->string #'d-name.datum)) #:with first-letter (symbol->string #'d-name.datum))
(pattern [i:id #:fields extra-fld-names:id ...] (pattern [i:id #:key]
#:with (fld-names ...) (datum->syntax #f (append (syntax->list default-flds) #:with (fld-names ...) (datum->syntax #f (append (syntax->list default-flds)
(syntax->list #'(extra-fld-names ...)))) (syntax->list #'(key))))
#:with lower-s (string-downcase (symbol->string #'i.datum)) #:with lower-s (string-downcase (symbol->string #'i.datum))
#:when (printf "loc2: ~v~n" (syntax->datum #'lower-s))
#:with key? #'#t
#:with first-letter (string-ref #'lower-s 0))) #:with first-letter (string-ref #'lower-s 0)))
(define-syntax-class type-name (define-syntax-class type-name
#:transparent #:transparent
@ -151,10 +159,10 @@
#'(begin #'(begin
(provide i.d-id ... i.printer ... i.name ... i.pred? ... i.accs ... ... (provide i.d-id ... i.printer ... i.name ... i.pred? ... i.accs ... ...
(for-syntax i.ht ... i.rec-id ...)) (for-syntax i.ht ... i.rec-id ...))
(define-syntax i.d-id (mk #'i.name #'i.ht)) ... (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 (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) ...)]))
(make-prim-type [Type #:fields key] Filter [LatentFilter #:d lf] Object [LatentObject #:d lo] (make-prim-type [Type #:key] Filter [LatentFilter #:d lf] Object [LatentObject #:d lo]
[PathElem #:d pe]) [PathElem #:d pe])