123 lines
5.4 KiB
Scheme
123 lines
5.4 KiB
Scheme
(module types mzscheme
|
|
(provide (all-defined))
|
|
|
|
(define-struct type () (make-inspector))
|
|
|
|
; (make-type-empty) is the same as (make-type-cst 'bottom) for now. The reason we
|
|
; *never* use (make-type-cst 'bottom) is because it would trigger the propagation of
|
|
; bottom everywhere, thus slowing down the analysis. There's two solutions to that:
|
|
; - not use initialize-label-set-for-value-source when using (make-type-cst 'bottom)
|
|
; - use a separate (make-type-empty), which is more correct anyway (note that there's
|
|
; currently no way to define the type for a primitive that returns the symbol 'bottom
|
|
; (or 'number, or 'null, etc...))
|
|
(define-struct (type-empty type) () (make-inspector))
|
|
|
|
(define-struct (type-cst type) (type) (make-inspector))
|
|
(define-struct (type-cons type) (car cdr) (make-inspector))
|
|
(define-struct (type-vector type) (element) (make-inspector))
|
|
(define-struct (type-case-lambda type) (rest-arg?s req-args argss exps) (make-inspector))
|
|
(define-struct (type-var type) (name reach handle) (make-inspector))
|
|
(define-struct (type-union type) (elements) (make-inspector))
|
|
(define-struct (type-rec type) (vars types body) (make-inspector))
|
|
(define-struct (type-values type) (type) (make-inspector))
|
|
(define-struct (type-promise type) (value) (make-inspector))
|
|
|
|
; note: we have to keep the type label around, because that's the only thing
|
|
; that allows us to differentiate structurally equivalent structure that have
|
|
; the same name (i.e. the only way to have subtyping work in the presence of generative
|
|
; structures). The reason for type-struct-type is because structure types are first
|
|
; class values in mzscheme. Also, by keeping the type-label around, we avoid the need
|
|
; to duplicate the type hierarchy all the way up to the root each time we compute the
|
|
; type of a structure.
|
|
(define-struct (type-struct-value type) (type-label types) (make-inspector))
|
|
(define-struct (type-struct-type type) (type-label) (make-inspector))
|
|
|
|
(define-struct (type-flow-var type) (name) (make-inspector))
|
|
(define-struct (type-scheme type) (flow-vars type^cs type) (make-inspector))
|
|
|
|
|
|
;;
|
|
;; Printing
|
|
;;
|
|
|
|
(require (lib "match.ss")
|
|
(prefix string: (lib "string.ss"))
|
|
"util.ss"
|
|
"labels.ss")
|
|
|
|
(define type->list
|
|
(lambda (type)
|
|
(letrec
|
|
([loop (lambda (type)
|
|
(match type
|
|
[($ type-empty) '_]
|
|
[($ type-cst type)
|
|
(if (null? type)
|
|
'null
|
|
(string->symbol (string:expr->string type)))]
|
|
[($ type-struct-type label)
|
|
(string->symbol (string-append "#<struct-type:"
|
|
(symbol->string (label-struct-type-name label))
|
|
">"))]
|
|
[($ type-cons hd tl)
|
|
(list 'cons (loop hd) (loop tl))]
|
|
[($ type-case-lambda rest-arg?s req-args argss exps)
|
|
(list 'case-lambda
|
|
(foldr-case-lambda-vector
|
|
(lambda (rest-arg? req-arg args exp acc)
|
|
(cons (list args (if rest-arg? '*-> '->) exp) acc))
|
|
null
|
|
rest-arg?s req-args argss exps))]
|
|
[($ type-promise value)
|
|
(list 'promise (loop value))]
|
|
[($ type-struct-value label types)
|
|
(list (string->symbol
|
|
(string-append "#(struct:"
|
|
(symbol->string (if (label-struct-type? label)
|
|
(label-struct-type-name label)
|
|
label))))
|
|
(map loop types))]
|
|
[($ type-values values-type)
|
|
(cond
|
|
[(type-empty? values-type)
|
|
(loop values-type)]
|
|
[(and (type-cst? values-type) (eq? (type-cst-type values-type) 'top))
|
|
(loop values-type)]
|
|
[else
|
|
(list 'values (loop values-type))])]
|
|
[($ type-vector element)
|
|
(list 'vector (loop element))]
|
|
[($ type-union elements)
|
|
(list 'union (map loop elements))]
|
|
[($ type-rec vars binders body)
|
|
(list 'rec-type
|
|
(map (lambda (v b)
|
|
(list (loop v) (loop b)))
|
|
vars binders)
|
|
(loop body))]
|
|
[($ type-var name r h)
|
|
name]
|
|
[(? natural?) (string->symbol (string-append "h:" (number->string type)))]))])
|
|
(loop type))))
|
|
|
|
(define handle? natural?)
|
|
|
|
;; Is there a better place for this?
|
|
(define foldr-case-lambda-vector
|
|
(lambda (f init rest-arg?s req-args argss exps)
|
|
(let* ([v-to-l (lambda (x) (if (list? x) (list->vector x) x))]
|
|
[rest-arg?s (v-to-l rest-arg?s)]
|
|
[req-args (v-to-l req-args)]
|
|
[argss (if (list? argss) (lol->vov argss) argss)]
|
|
[exps (v-to-l exps)]
|
|
[len (vector-length rest-arg?s)])
|
|
(let loop ([i 0])
|
|
(if (= i len) init
|
|
(f (vector-ref rest-arg?s i)
|
|
(vector-ref req-args i)
|
|
(vector-ref argss i)
|
|
(vector-ref exps i)
|
|
(loop (add1 i))))))))
|
|
|
|
)
|