Use stxclass for defintern.
Use stxclass for dt and de, and refactor/simplify. Don't use the real union for unfolding mu types. Add some descriptions to syntax classes for type parsing. svn: r13597 original commit: 345abb820bf34bf7a9e1763a964b23143c07219f
This commit is contained in:
Sam Tobin-Hochstadt
parent
b0da5d65da
commit
474f810031
|
|
@ -28,10 +28,12 @@
|
|||
(define (stx-cadr stx) (stx-car (stx-cdr stx)))
|
||||
|
||||
(define-syntax-class star
|
||||
#:description "*"
|
||||
(pattern star:id
|
||||
#:when (eq? '* #'star.datum)))
|
||||
|
||||
(define-syntax-class ddd
|
||||
#:description "..."
|
||||
(pattern ddd:id
|
||||
#:when (eq? '... #'ddd.datum)))
|
||||
|
||||
|
|
@ -140,7 +142,8 @@
|
|||
#:description "\na sequence of identifiers\n"
|
||||
(pattern (v:id ...)))
|
||||
|
||||
(define-syntax-class all-type
|
||||
(define-syntax-class all-type
|
||||
#:description "All type"
|
||||
#:transparent
|
||||
#:literals (t:All)
|
||||
(pattern (t:All :all-ddd-formals b)
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@
|
|||
(define (sb t) (substitute image name t))
|
||||
(if (hash-ref (free-vars* target) name #f)
|
||||
(type-case sb target
|
||||
;[#:Union tys (Un (map sb tys))]
|
||||
[#:Union tys (Un (map sb tys))]
|
||||
[#:F name* (if (eq? name* name) image target)]
|
||||
[#:arr dom rng rest drest kws thn-eff els-eff
|
||||
(begin
|
||||
|
|
@ -142,7 +142,7 @@
|
|||
;; must be applied to a Mu
|
||||
(define (unfold t)
|
||||
(match t
|
||||
[(Mu: name b) (substitute t name b #:Un make-Union)]
|
||||
[(Mu: name b) (substitute t name b #:Un (lambda (tys) (make-Union (sort tys < #:key Type-seq))))]
|
||||
[_ (int-err "unfold: requires Mu type, got ~a" t)]))
|
||||
|
||||
(define (instantiate-poly t types)
|
||||
|
|
|
|||
|
|
@ -1,25 +1,25 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require syntax/boundmap)
|
||||
(require syntax/boundmap (for-syntax scheme/base stxclass))
|
||||
|
||||
(provide defintern hash-id)
|
||||
|
||||
|
||||
(define-syntax defintern
|
||||
(syntax-rules ()
|
||||
[(_ name+args make-name key)
|
||||
(defintern name+args (lambda () (make-hash #;'weak)) make-name key)]
|
||||
[(_ (*name arg ...) make-ht make-name key-expr)
|
||||
(define *name
|
||||
(let ([table (make-ht)])
|
||||
(lambda (arg ...)
|
||||
#;(all-count!)
|
||||
(let ([key key-expr])
|
||||
(hash-ref table key
|
||||
(lambda ()
|
||||
(let ([new (make-name (count!) arg ...)])
|
||||
(hash-set! table key new)
|
||||
new)))))))]))
|
||||
(define-syntax (defintern stx)
|
||||
(syntax-parse stx
|
||||
[(_ name+args make-name key ([#:extra-arg e:expr]) ...*)
|
||||
#'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e ...)]
|
||||
[(_ (*name:id arg:id ...) make-ht make-name key-expr ([#:extra-arg e:expr]) ...*)
|
||||
#'(define *name
|
||||
(let ([table (make-ht)])
|
||||
(lambda (arg ...)
|
||||
#;(all-count!)
|
||||
(let ([key key-expr])
|
||||
(hash-ref table key
|
||||
(lambda ()
|
||||
(let ([new (make-name (count!) e ... arg ...)])
|
||||
(hash-set! table key new)
|
||||
new)))))))]))
|
||||
|
||||
(define (make-count!)
|
||||
|
||||
|
|
|
|||
|
|
@ -8,10 +8,11 @@
|
|||
"interning.ss"
|
||||
mzlib/etc
|
||||
(for-syntax
|
||||
stxclass
|
||||
scheme/base
|
||||
syntax/struct
|
||||
syntax/stx
|
||||
(utils utils)))
|
||||
(rename-in (utils utils) [id mk-id])))
|
||||
|
||||
(provide == dt de print-type* print-effect* Type Type? Effect Effect? defintern hash-id Type-seq Effect-seq Type-key)
|
||||
|
||||
|
|
@ -43,123 +44,88 @@
|
|||
|
||||
(define-syntaxes (dt de)
|
||||
(let ()
|
||||
(define (parse-opts opts stx)
|
||||
(let loop ([provide? #t] [intern? #f] [frees #t] [fold-rhs #f] [key '(#f)] [opts opts])
|
||||
(cond
|
||||
[(null? opts) (values provide? intern? frees fold-rhs key)]
|
||||
[(eq? '#:no-provide (syntax-e (stx-car opts)))
|
||||
(loop #f intern? frees fold-rhs key (cdr opts))]
|
||||
[(eq? '#:no-frees (syntax-e (stx-car opts)))
|
||||
(loop #f intern? #f fold-rhs key (cdr opts))]
|
||||
[(not (and (stx-pair? opts) (stx-pair? (stx-car opts))))
|
||||
(raise-syntax-error #f "bad options" stx)]
|
||||
[(eq? '#:intern (syntax-e (stx-car (car opts))))
|
||||
(loop provide? (stx-car (stx-cdr (car opts))) frees fold-rhs key (cdr opts))]
|
||||
[(eq? '#:frees (syntax-e (stx-car (car opts))))
|
||||
(loop provide? intern? (stx-cdr (car opts)) fold-rhs key (cdr opts))]
|
||||
[(eq? '#:fold-rhs (syntax-e (stx-car (car opts))))
|
||||
(loop provide? intern? frees (stx-cdr (car opts)) key (cdr opts))]
|
||||
[(eq? '#:key (syntax-e (stx-car (car opts))))
|
||||
(loop provide? intern? frees fold-rhs (stx-cdr (car opts)) (cdr opts))]
|
||||
[else (raise-syntax-error #f "bad options" stx)])))
|
||||
(define-syntax-class no-provide-kw
|
||||
(pattern #:no-provide))
|
||||
(define-syntax-class idlist
|
||||
(pattern (i:id ...)))
|
||||
(define (combiner f flds)
|
||||
(syntax-parse flds
|
||||
[() #'empty-hash-table]
|
||||
[(e) #`(#,f e)]
|
||||
[(e ...) #`(combine-frees (list (#,f e) ...))]))
|
||||
(define-syntax-class frees-pat
|
||||
#:transparent
|
||||
#:attributes (f1 f2)
|
||||
(pattern (f1:expr f2:expr))
|
||||
(pattern (#f)
|
||||
#:with f1 #'empty-hash-table
|
||||
#:with f2 #'empty-hash-table))
|
||||
(define-syntax-class fold-pat
|
||||
#:transparent
|
||||
#:attributes (e)
|
||||
(pattern #:base
|
||||
#:with e fold-target)
|
||||
(pattern ex:expr
|
||||
#:with e #'#'ex))
|
||||
(define (mk par ht-stx)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(dform nm flds . opts)
|
||||
(let*-values ([(provide? intern? frees fold-rhs key-expr) (parse-opts (syntax->list #'opts) #'opts)]
|
||||
[(kw) (string->keyword (symbol->string (syntax-e #'nm)))])
|
||||
(with-syntax*
|
||||
([ex (id #'nm #'nm ":")]
|
||||
[kw-stx kw]
|
||||
[(key-expr) key-expr]
|
||||
[parent par]
|
||||
[(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds) #f #t #'nm)]
|
||||
[(flds* ...) #'flds]
|
||||
[*maker (id #'nm "*" #'nm)]
|
||||
[**maker (id #'nm "**" #'nm)]
|
||||
[ht-stx ht-stx]
|
||||
[bfs-fold-rhs (cond [(and fold-rhs (eq? (syntax-e (stx-car fold-rhs)) '#:base))
|
||||
#`(lambda (tr er) #,fold-target)]
|
||||
[(and fold-rhs (stx-pair? fold-rhs))
|
||||
(with-syntax ([fr (stx-car fold-rhs)])
|
||||
#'(lambda (tr er)
|
||||
#'fr))]
|
||||
[fold-rhs (raise-syntax-error fold-rhs "something went wrong")]
|
||||
[else #'(lambda (type-rec-id effect-rec-id)
|
||||
#;
|
||||
(printf "about to call ~a with ~a args~n"
|
||||
'*maker
|
||||
(length '(flds* ...)))
|
||||
#`(*maker (#,type-rec-id flds*) ...))])]
|
||||
[provides (if provide?
|
||||
#`(begin
|
||||
(provide ex pred acc ...)
|
||||
(provide (rename-out [*maker maker])))
|
||||
#'(begin))]
|
||||
[intern (cond
|
||||
[(syntax? intern?)
|
||||
#`(defintern (**maker key . flds) maker #,intern?)]
|
||||
[(null? (syntax-e #'flds))
|
||||
#'(defintern (**maker key . flds) maker #f)]
|
||||
[(stx-null? (stx-cdr #'flds)) #'(defintern (**maker key . flds) maker . flds)]
|
||||
[else #'(defintern (**maker key . flds) maker (list . flds))])]
|
||||
[frees (cond
|
||||
[(not frees) #'(begin)]
|
||||
;; we know that this has no free vars
|
||||
[(and (pair? frees) (syntax? (car frees)) (not (syntax-e (car frees))))
|
||||
(syntax/loc stx
|
||||
(define (*maker . flds)
|
||||
(define v (**maker key-expr . flds))
|
||||
(unless-in-table
|
||||
var-table v
|
||||
(hash-set! var-table v empty-hash-table)
|
||||
(hash-set! index-table v empty-hash-table))
|
||||
v))]
|
||||
;; we provided an expression each for calculating the free vars and free idxs
|
||||
;; this should really be 2 expressions, one for each kind
|
||||
[(and (pair? frees) (pair? (cdr frees)))
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(define (*maker . flds)
|
||||
(define v (**maker key-expr . flds))
|
||||
#,
|
||||
(quasisyntax/loc (car frees)
|
||||
(unless-in-table
|
||||
var-table v
|
||||
(hash-set! var-table v #,(car frees))
|
||||
(hash-set! index-table v #,(cadr frees))))
|
||||
v))]
|
||||
[else
|
||||
(let
|
||||
([combiner
|
||||
(lambda (f flds)
|
||||
(syntax-case flds ()
|
||||
[() #'empty-hash-table]
|
||||
[(e) #`(#,f e)]
|
||||
[(e ...) #`(combine-frees (list (#,f e) ...))]))])
|
||||
(quasisyntax/loc stx
|
||||
(define (*maker . flds)
|
||||
(define v (**maker key-expr . flds))
|
||||
(unless-in-table
|
||||
var-table v
|
||||
(define fvs #,(combiner #'free-vars* #'flds))
|
||||
(define fis #,(combiner #'free-idxs* #'flds))
|
||||
(hash-set! var-table v fvs)
|
||||
(hash-set! index-table v fis))
|
||||
v)))])])
|
||||
#`(begin
|
||||
(define-struct (nm parent) flds #:inspector #f)
|
||||
(define-match-expander ex
|
||||
(lambda (s)
|
||||
(...
|
||||
(syntax-case s ()
|
||||
[(__ . fs)
|
||||
(with-syntax ([flds** (syntax/loc s (_ _ . fs))])
|
||||
(quasisyntax/loc s (struct nm flds**)))]))))
|
||||
(begin-for-syntax
|
||||
(hash-set! ht-stx 'kw-stx (list #'ex #'flds bfs-fold-rhs #'#,stx)))
|
||||
intern
|
||||
provides
|
||||
frees)))])))
|
||||
(values (mk #'Type #'type-name-ht) (mk #'Effect #'effect-name-ht))))
|
||||
(syntax-parse stx
|
||||
[(dform nm:id flds:idlist ([[#:key key-expr:expr]] #:opt
|
||||
[[#:intern intern?:expr]] #:opt
|
||||
[[#:frees . frees:frees-pat]] #:opt
|
||||
[[#:fold-rhs fold-rhs:fold-pat]] #:opt
|
||||
[no-provide?:no-provide-kw] #:opt) ...*)
|
||||
(with-syntax*
|
||||
([ex (mk-id #'nm #'nm ":")]
|
||||
[kw-stx (string->keyword (symbol->string #'nm.datum))]
|
||||
[parent par]
|
||||
[(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds) #f #t #'nm)]
|
||||
[*maker (mk-id #'nm "*" #'nm)]
|
||||
[**maker (mk-id #'nm "**" #'nm)]
|
||||
[ht-stx ht-stx]
|
||||
[bfs-fold-rhs (cond [#'fold-rhs #`(lambda (tr er) #,#'fold-rhs.e)]
|
||||
[else #'(lambda (type-rec-id effect-rec-id)
|
||||
#`(*maker (#,type-rec-id flds.i) ...))])]
|
||||
[provides (if #'no-provide?
|
||||
#'(begin)
|
||||
#`(begin
|
||||
(provide ex pred acc ...)
|
||||
(provide (rename-out [*maker maker]))))]
|
||||
[intern
|
||||
(let ([mk (lambda (int) #`(defintern (**maker . flds) maker #,int #:extra-arg key-expr))])
|
||||
(syntax-parse #'flds
|
||||
[_ #:when #'intern?
|
||||
(mk #'intern?)]
|
||||
[() (mk #'#f)]
|
||||
[(f) (mk #'f)]
|
||||
[_ (mk #'(list . flds))]))]
|
||||
[frees
|
||||
(with-syntax ([(f1 f2) (if #'frees
|
||||
#'(frees.f1 frees.f2)
|
||||
(list (combiner #'free-vars* #'flds)
|
||||
(combiner #'free-idxs* #'flds)))])
|
||||
(quasisyntax/loc stx
|
||||
(define (*maker . flds)
|
||||
(define v (**maker . flds))
|
||||
(unless-in-table
|
||||
var-table v
|
||||
(define fvs f1)
|
||||
(define fis f2)
|
||||
(hash-set! var-table v fvs)
|
||||
(hash-set! index-table v fis))
|
||||
v)))])
|
||||
#`(begin
|
||||
(define-struct (nm parent) flds #:inspector #f)
|
||||
(define-match-expander ex
|
||||
(lambda (s)
|
||||
(syntax-parse s
|
||||
[(_ . fs)
|
||||
#:with pat (syntax/loc s (_ _ . fs))
|
||||
(syntax/loc s (struct nm pat))])))
|
||||
(begin-for-syntax
|
||||
(hash-set! ht-stx 'kw-stx (list #'ex #'flds bfs-fold-rhs #'#,stx)))
|
||||
intern
|
||||
provides
|
||||
frees))])))
|
||||
(values (mk #'Type #'type-name-ht) (mk #'Effect #'effect-name-ht))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user