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 "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])
;; v is an identifier
(de Var-True-Effect ([v identifier?]) [#:intern (hash-id v)] [#:frees #f] [#:fold-rhs #:base])
;; 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
|#
(dlf LNotTypeFilter ([t Type?] [p (listof PathElem?)])
[#:frees (combine-frees (map free-vars* (cons t p)))
(combine-frees (map free-idxs* (cons t p)))]
[#:fold-rhs (*LNotTypeFilter (type-rec-id t) (map pathelem-rec-id p))])

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")
(dpe CarPE () [#:frees #f] [#:fold-rhs #:base])
(dpe CdrPE () [#:frees #f] [#:fold-rhs #:base])
(dpe CarPE () [#:fold-rhs #:base])
(dpe CdrPE () [#:fold-rhs #:base])
(dpe StructPE ([t Type?] [idx natural-number/c])
[#:frees (free-vars* t) (free-idxs* t)]
[#: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?])
[#:intern (list p (hash-id v))]
[#: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])
[#: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 (mk par ht-stx)
(define-for-syntax (mk par ht-stx key?)
(define-syntax-class opt-cnt-id
#:attributes (i cnt)
(pattern i:id
@ -80,7 +80,10 @@
(provide ex pred acc ...)
(p/c (rename *maker maker *maker-cnt))))]
[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
[_ #:when #'intern?
(mk #'intern?)]
@ -121,20 +124,25 @@
(define-syntax (make-prim-type stx)
(define default-flds #'(seq))
(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
(pattern i:id
#:with lower-s (string-downcase (symbol->string #'i.datum))
#:when (printf "loc1: ~a~n" #'lower-s)
#:with (fld-names ...) default-flds
#:with key? #'#f
#:with first-letter (string-ref #'lower-s 0))
(pattern [i:id #:d d-name:id]
#:with (fld-names ...) default-flds
#:with lower-s (string-downcase (symbol->string #'i.datum))
#:with key? #'#f
#: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)
(syntax->list #'(extra-fld-names ...))))
(syntax->list #'(key))))
#: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)))
(define-syntax-class type-name
#:transparent
@ -151,10 +159,10 @@
#'(begin
(provide i.d-id ... i.printer ... i.name ... i.pred? ... i.accs ... ...
(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-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) ...)]))
(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])