You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1470 lines
59 KiB
Scheme
1470 lines
59 KiB
Scheme
27 years ago
|
; ASSUME DEFINED VARIABLES NEVER ASSIGNED
|
||
|
|
|
||
|
|
; traverse.ss
|
||
|
|
; Traverses source program and produces constraints.
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
; Copyright (C) 1995-97 Cormac Flanagan
|
||
|
|
;
|
||
|
|
; This program is free software; you can redistribute it and/or
|
||
|
|
; modify it under the terms of the GNU General Public License
|
||
|
|
; version 2 as published by the Free Software Foundation.
|
||
|
|
;
|
||
|
|
; This program is distributed in the hope that it will be useful,
|
||
|
|
; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
|
|
; GNU General Public License for more details.
|
||
|
|
;
|
||
|
|
; You should have received a copy of the GNU General Public License
|
||
|
|
; along with this program; if not, write to the Free Software
|
||
|
|
; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
;; ------------------------------------------------------------
|
||
|
|
|
||
|
|
;; Environments are:
|
||
|
|
;; (Name -> (or FlowType mutable-binding))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (top-level-traverse-defs defs env)
|
||
|
|
;;(assert (atenv:ok? env) 'top-level-traverse-defs)
|
||
|
|
(begin0
|
||
|
|
(traverse-defs defs env)
|
||
|
|
(unless (null? defs)
|
||
|
|
(mrspidey:zprogress "Analyzing" (zodiac:zodiac-finish (rac defs))))
|
||
|
|
))
|
||
|
|
|
||
|
|
(define traverse:bad-expr (void))
|
||
|
|
|
||
|
|
(define (traverse-defs defs env)
|
||
|
|
;;(assert (atenv:ok? env) 'traverse-defs)
|
||
|
|
;; returns (values env refs result)
|
||
|
|
(pretty-debug-traverse `(->traverse-defs))
|
||
|
|
;; First alloc void for all defines
|
||
|
|
(let* ( [lvrs (apply append
|
||
|
|
(map (match-lambda
|
||
|
|
[($ zodiac:define-values-form _ _ _ _ vars) vars]
|
||
|
|
[_ '()])
|
||
|
|
defs))]
|
||
|
|
[names (map zodiac:varref-binding lvrs)]
|
||
|
|
[nuenv (atenv:extend-undefineds env names)]
|
||
|
|
;; bubble define-struct stuff to top
|
||
|
|
[defs
|
||
|
|
(append
|
||
|
|
(filter
|
||
|
|
(match-lambda
|
||
|
|
[($ zodiac:define-values-form _ _ _ _ _
|
||
|
|
($ zodiac:struct-form))
|
||
|
|
#t]
|
||
|
|
[_ #f])
|
||
|
|
defs)
|
||
|
|
(filter
|
||
|
|
(match-lambda
|
||
|
|
[($ zodiac:define-values-form _ _ _ _ _
|
||
|
|
($ zodiac:struct-form))
|
||
|
|
#f]
|
||
|
|
[_ #t])
|
||
|
|
defs))])
|
||
|
|
(recur loop ([defs defs]
|
||
|
|
[env nuenv]
|
||
|
|
[refs '()]
|
||
|
|
[result (wrap-value (mk-tvar-void))])
|
||
|
|
(match defs
|
||
|
|
[() (atenv:flush! env)
|
||
|
|
(values env refs result)]
|
||
|
|
[(first . rest)
|
||
|
|
(let-values
|
||
|
|
([(env nu-refs result) (traverse-def first env)])
|
||
|
|
(loop rest env (append nu-refs refs) result))]))))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (traverse-def def env)
|
||
|
|
;; returns (values env refs result)
|
||
|
|
;; (: env (listof (cons Name FlowType)))
|
||
|
|
;; (: refs (listof (cons Name Tvar)))
|
||
|
|
;; (: result FlowType) -- multiple value list
|
||
|
|
|
||
|
|
(pretty-debug-traverse-small
|
||
|
|
`(->traverse-def
|
||
|
|
,(zodiac:location-offset (zodiac:zodiac-start def))
|
||
|
|
,(zodiac:stripper def)))
|
||
|
|
|
||
|
|
(mrspidey:zprogress "Analyzing" (zodiac:zodiac-start def))
|
||
|
|
|
||
|
|
(let* ([tvar-E (mk-Tvar 'def)])
|
||
|
|
(link-parsed-ftype! def tvar-E)
|
||
|
|
(new-AV! tvar-E AV-void)
|
||
|
|
(match def
|
||
|
|
;; --- define
|
||
|
|
[($ zodiac:define-values-form _ _ _ _ lvrs exp)
|
||
|
|
(let*-vals ([(ftype env refs) (traverse-exp exp env)]
|
||
|
|
[ftypes (multiple-value-components ftype (length lvrs))]
|
||
|
|
[ftypes (map link-parsed-ftype! lvrs ftypes)]
|
||
|
|
[names (map zodiac:varref-binding lvrs)]
|
||
|
|
[env (atenv:change-bindings env names ftypes)])
|
||
|
|
(values env refs (wrap-value (mk-tvar-void))))]
|
||
|
|
;; --- define-type
|
||
|
|
[($ zodiac:define-type-form _ s _ _ sym type)
|
||
|
|
(let ([tvar (mk-Tvar 'define-type)])
|
||
|
|
(schema->con
|
||
|
|
(expand-input-type-err type def)
|
||
|
|
tvar 'define-type '())
|
||
|
|
(add-global-tdef! sym tvar)
|
||
|
|
(values env '() (wrap-value (mk-tvar-void))))]
|
||
|
|
;; --- define-constructor
|
||
|
|
[($ zodiac:define-constructor-form _ _ _ _ name modes)
|
||
|
|
(apply add-constructor! name modes)
|
||
|
|
(values env '() (wrap-value (mk-tvar-void)))]
|
||
|
|
;; --- Exp
|
||
|
|
[exp
|
||
|
|
(let-values ([(result env refs) (traverse-exp exp env)])
|
||
|
|
(values env refs result))])))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define values-trap-pt (void))
|
||
|
|
|
||
|
|
(define (traverse-exp E env)
|
||
|
|
(: env (listof (cons Name (or mutable-binding FlowType))))
|
||
|
|
|
||
|
|
;; returns (values FlowType env refs)
|
||
|
|
;; (: refs (listof (cons Name Tvar)))
|
||
|
|
;; FlowType is annotated type for list of results
|
||
|
|
|
||
|
|
(letrec*
|
||
|
|
([refs '()]
|
||
|
|
[extend-ref!
|
||
|
|
(lambda (name tvar) (set! refs (cons (cons name tvar) refs)))]
|
||
|
|
[extend-refs!
|
||
|
|
(lambda (refs)
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[(name . tvar) (extend-ref! name tvar)])
|
||
|
|
refs))]
|
||
|
|
;; ---
|
||
|
|
[pattern-match (lambda (tvar-formal tvars-actuals)
|
||
|
|
(match tvars-actuals
|
||
|
|
[(? Tvar?) (new-edge! tvar-formal tvars-actuals)]
|
||
|
|
[(tvar1 . rest)
|
||
|
|
(let ([tvar-cdr (mk-Tvar 'arg-cdr)])
|
||
|
|
(new-con! tvar-formal (make-con-car tvar1))
|
||
|
|
(new-con! tvar-formal (make-con-cdr tvar-cdr))
|
||
|
|
(pattern-match tvar-cdr rest))]
|
||
|
|
[() (void)]))]
|
||
|
|
[handle-lambda-form
|
||
|
|
(lambda (args body env1)
|
||
|
|
(: args zodiac:arglist)
|
||
|
|
|
||
|
|
(let*-vals
|
||
|
|
( [env2 (atenv:unflush env1)]
|
||
|
|
[tvar-arg (mk-Tvar 'args)]
|
||
|
|
[improper?
|
||
|
|
(or (zodiac:sym-arglist? args) (zodiac:ilist-arglist? args))]
|
||
|
|
;;[_ (pretty-print `(improper ,improper? ,args))]
|
||
|
|
[args (zodiac:arglist-vars args)]
|
||
|
|
[env3
|
||
|
|
(recur loop ([env env2][args args][tvar tvar-arg])
|
||
|
|
(cond
|
||
|
|
[(null? args) env]
|
||
|
|
[(and improper? (null? (cdr args)))
|
||
|
|
(atenv:extend env (car args) tvar)]
|
||
|
|
[else
|
||
|
|
(let ( [tvar-car (mk-Tvar 'arg-car)]
|
||
|
|
[tvar-cdr (mk-Tvar 'arg-cdr)])
|
||
|
|
(new-con! tvar (make-con-car tvar-car))
|
||
|
|
(new-con! tvar (make-con-cdr tvar-cdr))
|
||
|
|
(loop (atenv:extend env (car args) tvar-car)
|
||
|
|
(cdr args)
|
||
|
|
tvar-cdr))]))]
|
||
|
|
[(ftype-rv env4) (traverse body env3)]
|
||
|
|
[AV (make-AV-lam tvar-arg (FlowType->Tvar ftype-rv)
|
||
|
|
(if improper? (sub1 (length args)) (length args))
|
||
|
|
improper?)]
|
||
|
|
[tvar-E (mk-Tvar 'lam)])
|
||
|
|
(atenv:flush! env4)
|
||
|
|
(new-AV! tvar-E AV)
|
||
|
|
tvar-E))]
|
||
|
|
|
||
|
|
[handle-application
|
||
|
|
(lambda (E env flush?)
|
||
|
|
(match E
|
||
|
|
[($ zodiac:app _ _ _ _ fn args)
|
||
|
|
(set! values-trap-pt "|")
|
||
|
|
(let*-vals
|
||
|
|
( [(ftype-fn env1 pi)
|
||
|
|
;; Traverse fn specially if fo prim ref
|
||
|
|
;; don't instantiate yet, wait till have # args
|
||
|
|
(match fn
|
||
|
|
[($ zodiac:varref)
|
||
|
|
(=> fail)
|
||
|
|
(if (st:special-fo-prims)
|
||
|
|
(match (atenv:lookup env (zodiac:varref-binding fn))
|
||
|
|
[#f
|
||
|
|
(set! values-trap-pt "A")
|
||
|
|
(fail)]
|
||
|
|
[ftype
|
||
|
|
(set! values-trap-pt "B")
|
||
|
|
(match (FlowType->Atype ftype)
|
||
|
|
[(and pi ($ atprim sym tschema))
|
||
|
|
(set! values-trap-pt "C")
|
||
|
|
(zodiac:set-parsed-atprim! fn pi)
|
||
|
|
(let ([tvar-fn (mk-Tvar sym)])
|
||
|
|
(tschema->con-for-nargs tschema
|
||
|
|
tvar-fn sym '() (length args))
|
||
|
|
(link-parsed-ftype! fn (wrap-value tvar-fn))
|
||
|
|
(set! values-trap-pt "D")
|
||
|
|
(values tvar-fn env pi))]
|
||
|
|
[_
|
||
|
|
(set! values-trap-pt "E")
|
||
|
|
(fail)])])
|
||
|
|
(begin (set! values-trap-pt "F") (fail)))]
|
||
|
|
[_
|
||
|
|
(set! values-trap-pt "G")
|
||
|
|
(let-values ([(ftype env) (traverse1 fn env)])
|
||
|
|
(set! values-trap-pt "H")
|
||
|
|
(values ftype env #f))])]
|
||
|
|
[_ (set! values-trap-pt "K")]
|
||
|
|
[(ftype-arg* env2) (traverse* args env1)]
|
||
|
|
[ftype-arg* (map extract-1st-value ftype-arg*)]
|
||
|
|
[env3 (if (and flush? (not pi))
|
||
|
|
(atenv:unflush (atenv:flush! env2))
|
||
|
|
env2)]
|
||
|
|
|
||
|
|
[tvar-fn (FlowType->Tvar ftype-fn)]
|
||
|
|
[tvar-arg* (map FlowType->Tvar ftype-arg*)]
|
||
|
|
[tvar-arg
|
||
|
|
(foldr
|
||
|
|
(lambda (tvar-arg tvar-rest-args)
|
||
|
|
(let* ([tvar (mk-Tvar 'arg)])
|
||
|
|
(new-AV! tvar
|
||
|
|
(make-AV-cons tvar-arg tvar-rest-args))
|
||
|
|
tvar))
|
||
|
|
(mk-tvar-nil)
|
||
|
|
tvar-arg*)]
|
||
|
|
[tvar-E (mk-Tvar 'expr)])
|
||
|
|
;;(link-parsed-ftype! fn (wrap-value tvar-fn))
|
||
|
|
(pretty-debug-traverse
|
||
|
|
`(tvar-fn ,(Tvar-name tvar-fn)
|
||
|
|
tvar-arg ,(Tvar-name tvar-arg)))
|
||
|
|
(zodiac:set-app-tvar-args! E tvar-arg)
|
||
|
|
(new-con! tvar-fn (make-con-dom tvar-arg))
|
||
|
|
(new-con! tvar-fn (make-con-rng tvar-E))
|
||
|
|
(values tvar-E
|
||
|
|
(if (and (st:flow-sensitive) pi)
|
||
|
|
(flow-sensitive-env pi args env3)
|
||
|
|
env3)))]))]
|
||
|
|
|
||
|
|
;; ---
|
||
|
|
[traverse*
|
||
|
|
(lambda (E* env)
|
||
|
|
;; Returns (values (listof FlowType) env)
|
||
|
|
(pretty-debug-traverse `(->traverse* ,(length E*)))
|
||
|
|
(match
|
||
|
|
(foldl
|
||
|
|
(match-lambda*
|
||
|
|
[(E (ftype* . env))
|
||
|
|
(let-values ([(ftype nuenv) (traverse E env)])
|
||
|
|
(cons (cons ftype ftype*) nuenv))])
|
||
|
|
(cons '() env)
|
||
|
|
E*)
|
||
|
|
[(ftype* . env)
|
||
|
|
(pretty-debug-traverse
|
||
|
|
`(<-traverse* ,(map FlowType->pretty (reverse ftype*))))
|
||
|
|
(values (reverse ftype*) env)]))]
|
||
|
|
;; ---
|
||
|
|
[made-unit (lambda (atype)
|
||
|
|
(cond
|
||
|
|
[(not (st:fo-units)) (Atype->Tvar atype)]
|
||
|
|
[(not (st:lazy-fo-units)) (atlunit->atunit atype)]
|
||
|
|
[else atype]))]
|
||
|
|
[traverse1 (lambda (E env)
|
||
|
|
(let*-vals ([(ftype env) (traverse E env)]
|
||
|
|
[ftype (extract-1st-value ftype)])
|
||
|
|
(values ftype env)))]
|
||
|
|
[traverse
|
||
|
|
(lambda (E env)
|
||
|
|
;;(assert (atenv:ok? env) 'traverse)
|
||
|
|
|
||
|
|
(pretty-debug-traverse-small
|
||
|
|
`(->traverse
|
||
|
|
,(zodiac:location-offset (zodiac:zodiac-start E))
|
||
|
|
,(zodiac:stripper E)
|
||
|
|
,(atenv->pretty env)))
|
||
|
|
(let*-vals
|
||
|
|
([trav (lambda (E) (traverse E env))]
|
||
|
|
[(result env-result)
|
||
|
|
(match E
|
||
|
|
;; (: result (union Tvar fo-FlowType fo-Atype))
|
||
|
|
|
||
|
|
[($ zodiac:varref)
|
||
|
|
(let ([name (zodiac:varref-binding E)])
|
||
|
|
(match (atenv:lookup env name)
|
||
|
|
[#f (let ([tvar (mk-Tvar 'import-var)])
|
||
|
|
(extend-ref! name tvar)
|
||
|
|
(values (wrap-value tvar) env))]
|
||
|
|
[ftype
|
||
|
|
;; Instantiate schemas and atprims here
|
||
|
|
(let* ( [atype (FlowType->Atype ftype)]
|
||
|
|
[ftype
|
||
|
|
(if (or (atprim? atype) (schema? atype))
|
||
|
|
(FlowType->Tvar ftype)
|
||
|
|
ftype)])
|
||
|
|
(when (atprim? atype)
|
||
|
|
(zodiac:set-parsed-atprim! E atype))
|
||
|
|
(values (wrap-value ftype) env))]))]
|
||
|
|
|
||
|
|
[($ zodiac:quote-form _ _ _ _
|
||
|
|
(or ($ zodiac:boolean _ _ _ c)
|
||
|
|
($ zodiac:number _ _ _ c)))
|
||
|
|
(values (wrap-value (make-atconst c)) env)]
|
||
|
|
|
||
|
|
[($ zodiac:quote-form _ _ _ _ c)
|
||
|
|
(values (wrap-value (traverse-const c)) env)]
|
||
|
|
|
||
|
|
;; --- local set!
|
||
|
|
[($ zodiac:set!-form _ _ _ _ lvr exp)
|
||
|
|
(let*-vals ([(ftype env1) (trav exp)]
|
||
|
|
[ftype (extract-1st-value ftype)]
|
||
|
|
[ftype (link-parsed-ftype! lvr ftype)]
|
||
|
|
[name (zodiac:varref-binding lvr)]
|
||
|
|
[env2 (atenv:change-binding env1 name ftype)])
|
||
|
|
(values (wrap-value (mk-tvar-void)) env2))]
|
||
|
|
|
||
|
|
[($ zodiac:if-form _ _ _ _ test then else)
|
||
|
|
;; old version
|
||
|
|
'(let*-vals
|
||
|
|
([(ftype env1) (trav test)]
|
||
|
|
[env2 (atenv:capture-locs env1
|
||
|
|
(zodiac:free-vars E (atenv:domain env1)))]
|
||
|
|
[(env-then env-else)
|
||
|
|
(if (st:if-split)
|
||
|
|
(if-splitting-env test env2)
|
||
|
|
(values env2 env2))]
|
||
|
|
[tvar-E (mk-Tvar 'expr)]
|
||
|
|
[do-branch
|
||
|
|
(lambda (exp env)
|
||
|
|
(let-values ([(ftype env2) (traverse exp env)])
|
||
|
|
(atenv:flush! env2)
|
||
|
|
(new-edge! (FlowType->Tvar ftype) tvar-E)))])
|
||
|
|
(when (or (not (st:if-split))
|
||
|
|
(match (FlowType->Atype ftype)
|
||
|
|
[($ atconst #f) #f]
|
||
|
|
[_ #t]))
|
||
|
|
(do-branch then env-then))
|
||
|
|
(when (or (not (st:if-split))
|
||
|
|
(match (FlowType->Atype ftype)
|
||
|
|
[($ atconst #f) #t]
|
||
|
|
[($ atconst _) #f]
|
||
|
|
[_ #t]))
|
||
|
|
(do-branch else env-else))
|
||
|
|
|
||
|
|
(values tvar-E (atenv:unflush env2)))
|
||
|
|
|
||
|
|
;; new version
|
||
|
|
(let*-vals
|
||
|
|
( [(ftype env1) (trav test)]
|
||
|
|
[env-dom (atenv:domain env1)]
|
||
|
|
[env1 (atenv:capture-locs env1
|
||
|
|
(zodiac:free-vars then env-dom))]
|
||
|
|
[env1 (atenv:capture-locs env1
|
||
|
|
(zodiac:free-vars else env-dom))]
|
||
|
|
[(env-then env-else)
|
||
|
|
(if (st:if-split)
|
||
|
|
(if-splitting-env test env1)
|
||
|
|
(values env1 env1))]
|
||
|
|
[tvar-E (mk-Tvar 'expr)]
|
||
|
|
[do-branch
|
||
|
|
(lambda (exp env)
|
||
|
|
(let-values ([(ftype env2) (traverse exp env)])
|
||
|
|
(new-edge! (FlowType->Tvar ftype) tvar-E)
|
||
|
|
env2))]
|
||
|
|
[env-then-done
|
||
|
|
(and (or (not (st:if-split))
|
||
|
|
(match (FlowType->Atype ftype)
|
||
|
|
[($ atconst #f) #f]
|
||
|
|
[_ #t]))
|
||
|
|
(do-branch then env-then))]
|
||
|
|
[env-else-done
|
||
|
|
(and (or (not (st:if-split))
|
||
|
|
(match (FlowType->Atype ftype)
|
||
|
|
[($ atconst #f) #t]
|
||
|
|
[($ atconst _) #f]
|
||
|
|
[_ #t]))
|
||
|
|
(do-branch else env-else))])
|
||
|
|
|
||
|
|
(values tvar-E
|
||
|
|
(cond
|
||
|
|
[(and
|
||
|
|
(eq? env-then env-then-done)
|
||
|
|
(eq? env-else env-else-done))
|
||
|
|
env1]
|
||
|
|
[(not env-else-done) env-then-done]
|
||
|
|
[(not env-then-done) env-else-done]
|
||
|
|
[else
|
||
|
|
(atenv:flush! env-then-done)
|
||
|
|
(atenv:flush! env-else-done)
|
||
|
|
(atenv:unflush env1)])))]
|
||
|
|
|
||
|
|
;; ### SPECIAL CODE FOR STRUCT-REF
|
||
|
|
[($ zodiac:app _ _ _ _
|
||
|
|
($ zodiac:varref _ _ _ _ '#%struct-ref)
|
||
|
|
( struct-exp
|
||
|
|
($ zodiac:quote-form _ _ _ _ ($ zodiac:number _ _ _ n))))
|
||
|
|
(assert (and (integer? n) (>= n 0)))
|
||
|
|
;;(printf "Special struct-ref~n")
|
||
|
|
(let*-vals
|
||
|
|
( [(ftype-struct env1) (traverse1 struct-exp env)]
|
||
|
|
[tvar-struct (FlowType->Tvar ftype-struct)]
|
||
|
|
[tvar-elem (mk-Tvar 'struct-ref)])
|
||
|
|
(new-con! tvar-struct
|
||
|
|
(create-con template-structure n tvar-elem #t))
|
||
|
|
(values (wrap-value tvar-elem) env1))]
|
||
|
|
|
||
|
|
;; ### SPECIAL CODE FOR ivar
|
||
|
|
[($ zodiac:app _ _ _ _
|
||
|
|
(and ref ($ zodiac:varref _ _ _ _ (or '#%uq-ivar 'uq-ivar)))
|
||
|
|
( obj-exp
|
||
|
|
(and sym-exp
|
||
|
|
($ zodiac:quote-form _ _ _ _ ($ zodiac:symbol _ _ _ sym)))))
|
||
|
|
;;(printf "Special uq-ivar~n")
|
||
|
|
(let*-vals
|
||
|
|
( [(ftype-obj env1) (traverse1 obj-exp env)]
|
||
|
|
[tvar-obj (FlowType->Tvar ftype-obj)]
|
||
|
|
[tvar-ivar (mk-Tvar 'ivar-ref)])
|
||
|
|
(new-con! tvar-obj
|
||
|
|
(create-con (get-ivar-template sym) 0 tvar-ivar #t))
|
||
|
|
;(trav ref)
|
||
|
|
;(trav sym-exp)
|
||
|
|
(values (wrap-value tvar-ivar) env1))]
|
||
|
|
|
||
|
|
;; ### SPECIAL CODE FOR UNIT/SIG
|
||
|
|
[($ zodiac:app _ _ _ _
|
||
|
|
(and ref ($ zodiac:varref _ _ _ _ '#%make-unit-with-signature))
|
||
|
|
(unit-exp _ _))
|
||
|
|
(traverse unit-exp env)]
|
||
|
|
[($ zodiac:app _ _ _ _
|
||
|
|
(and ref
|
||
|
|
($ zodiac:varref _ _ _ _ '#%verify-linkage-signature-match))
|
||
|
|
args)
|
||
|
|
(values (wrap-value (mk-tvar-void)) env)]
|
||
|
|
[($ zodiac:app _ _ _ _
|
||
|
|
(and ref
|
||
|
|
($ zodiac:varref _ _ _ _ '#%unit-with-signature-unit))
|
||
|
|
(unit-exp))
|
||
|
|
(traverse unit-exp env)]
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
[($ zodiac:app _ _ _ _ fn args)
|
||
|
|
(handle-application E env #t)]
|
||
|
|
|
||
|
|
[($ zodiac:letrec*-values-form _ _ _ _ varss exps body)
|
||
|
|
;; First init each new var
|
||
|
|
(recur loop
|
||
|
|
([env (atenv:extend-undefineds env (apply append varss))]
|
||
|
|
[varss varss]
|
||
|
|
[exps exps])
|
||
|
|
(if (null? exps)
|
||
|
|
(traverse body env)
|
||
|
|
(let*-vals
|
||
|
|
([(ftype nuenv) (traverse (car exps) env)]
|
||
|
|
[vars (car varss)]
|
||
|
|
[ftypes (multiple-value-components ftype (length vars))]
|
||
|
|
;; overwrite void binding
|
||
|
|
[ftypes (map link-parsed-ftype! vars ftypes)]
|
||
|
|
[nuenv2 (atenv:change-bindings nuenv vars ftypes)])
|
||
|
|
(loop nuenv2 (cdr varss) (cdr exps)))))]
|
||
|
|
|
||
|
|
[($ zodiac:let-values-form _ _ _ _ varss exps body)
|
||
|
|
(let*-vals
|
||
|
|
([(ftype* nuenv) (traverse* exps env)]
|
||
|
|
[nuenv2
|
||
|
|
(foldr2
|
||
|
|
(lambda (vars ftype env)
|
||
|
|
(assert (list? vars) 'let-valeus-form)
|
||
|
|
(atenv:extend*
|
||
|
|
env vars
|
||
|
|
(multiple-value-components ftype (length vars))))
|
||
|
|
nuenv varss ftype*)])
|
||
|
|
(traverse body nuenv2))]
|
||
|
|
|
||
|
|
[($ zodiac:case-lambda-form _ _ _ _ args bodies)
|
||
|
|
(let ( [tvar-E (mk-Tvar 'expr)]
|
||
|
|
[env1 (atenv:capture-locs env
|
||
|
|
(zodiac:free-vars E (atenv:domain env)))])
|
||
|
|
(for-each
|
||
|
|
(lambda (args body)
|
||
|
|
(new-edge!
|
||
|
|
(FlowType->Tvar (handle-lambda-form args body env1))
|
||
|
|
tvar-E))
|
||
|
|
args bodies)
|
||
|
|
(values (wrap-value tvar-E) env1))]
|
||
|
|
|
||
|
|
;;[($ zodiac:delay-form _ _ _ _ expr)
|
||
|
|
;; (let*-vals
|
||
|
|
;; ([env1 (atenv:capture-locs env (zodiac:free-vars E))]
|
||
|
|
;; [env2 (atenv:unflush env1)]
|
||
|
|
;; [(ftype-expr env3) (traverse1 expr env2)]
|
||
|
|
;; [AV (make-constructed-AV-template
|
||
|
|
;; template-promise (FlowType->Tvar ftype-expr))]
|
||
|
|
;; [tvar-E (mk-Tvar 'expr)])
|
||
|
|
;; (atenv:flush! env3)
|
||
|
|
;; (new-AV! tvar-E AV)
|
||
|
|
;; (values (wrap-value tvar-E) env1))]
|
||
|
|
|
||
|
|
[($ zodiac:begin-form _ _ _ _ bodies)
|
||
|
|
(recur loop ([env env][bodies bodies])
|
||
|
|
(match bodies
|
||
|
|
;;[() (values (wrap-value (mk-tvar-void)) env)]
|
||
|
|
[(a . d)
|
||
|
|
(let*-vals ([(ftype nuenv) (traverse a env)])
|
||
|
|
(if (null? d)
|
||
|
|
(values ftype nuenv)
|
||
|
|
(loop nuenv d)))]))]
|
||
|
|
[($ zodiac:begin0-form _ _ _ _ (start . rest))
|
||
|
|
(let*-vals ([(ftype nuenv) (traverse start env)])
|
||
|
|
(recur loop ([env nuenv][rest rest])
|
||
|
|
(match rest
|
||
|
|
[() (values ftype env)]
|
||
|
|
[(a . d)
|
||
|
|
(let*-vals ([(ftype nuenv) (traverse a env)])
|
||
|
|
(loop nuenv d))])))]
|
||
|
|
|
||
|
|
;; --------------------------------------------------------
|
||
|
|
;; MzScheme special forms
|
||
|
|
|
||
|
|
[($ zodiac:unit-form)
|
||
|
|
(let* ([env1 (atenv:unflush env)])
|
||
|
|
;; Assume no refs inside unit to imports of enclosing unit
|
||
|
|
(values (wrap-value (made-unit (create-atlunit-unit env1 E)))
|
||
|
|
env))]
|
||
|
|
|
||
|
|
[($ zodiac:compound-unit-form _ s _ _ imports links exports)
|
||
|
|
(let*-vals
|
||
|
|
([time-E (zodiac-time E)]
|
||
|
|
[exprs (map cadr links)]
|
||
|
|
[(ftype* env) (traverse* exprs env)]
|
||
|
|
[time* (map (lambda (e) (max time-E (zodiac-time* e)))
|
||
|
|
exprs)]
|
||
|
|
;; Assume E is closed
|
||
|
|
[ftype* (mapLR extract-1st-value ftype*)])
|
||
|
|
(values
|
||
|
|
(wrap-value (made-unit (create-atlunit-cmpd E time* ftype*)))
|
||
|
|
env))]
|
||
|
|
|
||
|
|
;; ### Doesn't deal in first-order fashion
|
||
|
|
[($ zodiac:invoke-unit-form _ _ _ _ exp vars)
|
||
|
|
(let*-vals ( [(ftype env1) (traverse1 exp env)]
|
||
|
|
;;[tvar (FlowType->Tvar ftype)]
|
||
|
|
[(ftype* env2) (traverse* vars env1)]
|
||
|
|
[ftypes.times
|
||
|
|
(map (lambda (f) (cons f (current-seconds)))
|
||
|
|
ftype*)]
|
||
|
|
[env1 (atenv:flush! env1)]
|
||
|
|
[env2 (atenv:unflush env1)]
|
||
|
|
[atype-U (apply-unit ftype ftypes.times)]
|
||
|
|
[tvar-E
|
||
|
|
(match atype-U
|
||
|
|
[($ atunit _ _ result) result]
|
||
|
|
[(? Tvar? tvar-u)
|
||
|
|
(let ([tvar (mk-Tvar 'invoke-unit-result)])
|
||
|
|
(new-con! tvar-u
|
||
|
|
(create-con template-unit 0 tvar #t))
|
||
|
|
tvar)])])
|
||
|
|
(values tvar-E env2))]
|
||
|
|
|
||
|
|
;; --------------------------------------------------------
|
||
|
|
;; MzScheme special forms
|
||
|
|
|
||
|
|
[($ zodiac:class*/names-form)
|
||
|
|
(handle-class*/names-form E env
|
||
|
|
traverse traverse* handle-application)]
|
||
|
|
|
||
|
|
;; --------------------
|
||
|
|
|
||
|
|
[($ zodiac:poly-form _ _ _ _ exp)
|
||
|
|
(unless (zodiac:parsed-value? exp)
|
||
|
|
(mrspidey:error "poly annotation on non-value" exp))
|
||
|
|
(let*-vals
|
||
|
|
( [name-for-edge
|
||
|
|
(match-lambda
|
||
|
|
[(f . t) (cons (Tvar-name f) (Tvar-name t))])]
|
||
|
|
[analyze
|
||
|
|
(lambda ()
|
||
|
|
(let*-vals
|
||
|
|
( [l1 list-ftype]
|
||
|
|
[base-num num-ftype]
|
||
|
|
;; Capture edges from external mono AVSs
|
||
|
|
[edges '()]
|
||
|
|
[orig-new-edge! (new-edge-para)]
|
||
|
|
[capture-edge!
|
||
|
|
(lambda (from to)
|
||
|
|
(unless (eq? from to)
|
||
|
|
(if (< (FlowType-num from) base-num)
|
||
|
|
;; Edge from outside constraint set
|
||
|
|
(set! edges (cons (cons from to) edges))
|
||
|
|
(orig-new-edge! from to))))]
|
||
|
|
[(env refs tvar)
|
||
|
|
(dynamic-let
|
||
|
|
([new-edge-para capture-edge!])
|
||
|
|
(let*-vals
|
||
|
|
( [(ftype env refs) (traverse-exp exp env)]
|
||
|
|
[ftype1 (extract-1st-value ftype)]
|
||
|
|
[tvar (FlowType->Tvar ftype1)])
|
||
|
|
(values env refs tvar)))]
|
||
|
|
[l2 list-ftype])
|
||
|
|
|
||
|
|
(pretty-debug
|
||
|
|
`(Poly-def-result
|
||
|
|
,(FlowType-name tvar)
|
||
|
|
num-AVS
|
||
|
|
,(- (FlowType-num (car l2))
|
||
|
|
(FlowType-num (car l1)))
|
||
|
|
,(FlowType-name (car l2))
|
||
|
|
,(FlowType-name (car l1))
|
||
|
|
external-edges
|
||
|
|
,(map name-for-edge edges)))
|
||
|
|
(values env refs tvar l1 l2 edges)))]
|
||
|
|
[handle-edges! (lambda (edges)
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[(from . to) (new-edge! from to)])
|
||
|
|
edges))]
|
||
|
|
[(def env)
|
||
|
|
(case (st:polymorphism)
|
||
|
|
[(reanalyze)
|
||
|
|
(mrspidey:error "Reanalyze does not work - env problem")
|
||
|
|
(make-atthunk
|
||
|
|
(lambda ()
|
||
|
|
(let*-vals
|
||
|
|
([(env refs tvar l1 l2 edges) (analyze)])
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[(binding . _)
|
||
|
|
(mrspidey:warning "Reference to ~s inside poly form with (st:polymorphism 'reanalyze)" exp 3)])
|
||
|
|
refs)
|
||
|
|
(handle-edges! edges)
|
||
|
|
tvar)))]
|
||
|
|
[(copy-con)
|
||
|
|
(let*-vals ([(env refs tvar l1 l2 edges) (analyze)])
|
||
|
|
(extend-refs! refs)
|
||
|
|
(values
|
||
|
|
(make-schema tvar
|
||
|
|
(filter Tvar? (get-prefix l2 l1))
|
||
|
|
edges)
|
||
|
|
env))]
|
||
|
|
[(compress)
|
||
|
|
(let*-vals
|
||
|
|
( [(env refs tvar l1 l2 edges) (analyze)]
|
||
|
|
[_ (extend-refs! refs)]
|
||
|
|
;; Tracked all incoming edges in edges
|
||
|
|
;; These correspond to upper bindings
|
||
|
|
[U-tvar* (list tvar)]
|
||
|
|
[L-tvar* (map cdr edges)]
|
||
|
|
[old-num-ftype num-ftype]
|
||
|
|
[old-num-AV num-AV]
|
||
|
|
[old-num-edge num-edge]
|
||
|
|
[old-num-con num-con]
|
||
|
|
[(rep-tvar tvar->nu)
|
||
|
|
(minimize-constraints-&-compare
|
||
|
|
(st:constraint-simplification-poly)
|
||
|
|
L-tvar* U-tvar*
|
||
|
|
l2 l1)]
|
||
|
|
;; Update edges to point to the compressed set
|
||
|
|
[nu-edges
|
||
|
|
(filter-map
|
||
|
|
(match-lambda
|
||
|
|
[(and edge (from . to))
|
||
|
|
(let ([nu-to (tvar->nu to)])
|
||
|
|
(if nu-to
|
||
|
|
(cons from (tvar->nu to))
|
||
|
|
(begin
|
||
|
|
'(pretty-debug-traverse
|
||
|
|
`(dropping ,(name-for-edge edge)))
|
||
|
|
#f)))])
|
||
|
|
edges)])
|
||
|
|
|
||
|
|
(when (> (- num-ftype old-num-ftype) 250)
|
||
|
|
(printf "Poly def AVS ~s AV ~s edge ~s con ~s~n"
|
||
|
|
(- num-ftype old-num-ftype)
|
||
|
|
(- num-AV old-num-AV)
|
||
|
|
(- num-edge old-num-edge)
|
||
|
|
(- num-con old-num-con)))
|
||
|
|
|
||
|
|
(values
|
||
|
|
(make-schema (tvar->nu tvar) rep-tvar nu-edges)
|
||
|
|
env))]
|
||
|
|
[(none)
|
||
|
|
(let*-vals ([(env refs tvar l1 l2 edges) (analyze)])
|
||
|
|
(extend-refs! refs)
|
||
|
|
(handle-edges! edges)
|
||
|
|
(values tvar env))])])
|
||
|
|
(values (wrap-value def) env))]
|
||
|
|
|
||
|
|
[($ zodiac:struct-form _ s _ _
|
||
|
|
($ zodiac:symbol _ _ _ tag)
|
||
|
|
parent
|
||
|
|
(($ zodiac:symbol _ _ _ fields) ...))
|
||
|
|
(let*-vals
|
||
|
|
([(parent-ftype env1)
|
||
|
|
(match parent
|
||
|
|
[#f (values
|
||
|
|
(create-fo-FlowType
|
||
|
|
(make-atstruct 'tag '(structure:)
|
||
|
|
'() '() '() '()))
|
||
|
|
env)]
|
||
|
|
[exp (traverse1 parent env)])])
|
||
|
|
(match (FlowType->Atype parent-ftype)
|
||
|
|
[(and atstruct ($ atstruct))
|
||
|
|
(values (handle-struct-form tag #f atstruct fields)
|
||
|
|
env)]
|
||
|
|
[_
|
||
|
|
(pretty-debug-traverse `(FlowType->pretty parent-ftype))
|
||
|
|
(mrspidey:warning
|
||
|
|
(format
|
||
|
|
"Expression does not analyze to a first-order struct")
|
||
|
|
(zodiac:zodiac-start parent)
|
||
|
|
0)
|
||
|
|
(values (mk-Tvar 'empty) env)]))]
|
||
|
|
|
||
|
|
;; --------------------------------------------------------
|
||
|
|
;; MrSpidey special forms
|
||
|
|
|
||
|
|
[($ zodiac::-form _ _ _ _ exp type)
|
||
|
|
(let*-vals
|
||
|
|
([(ftype nuenv) (traverse1 exp env)])
|
||
|
|
(pretty-debug `(:: ,ftype ,nuenv))
|
||
|
|
(match exp
|
||
|
|
[($ zodiac:varref _ _ _ _ sym)
|
||
|
|
(let ([name (zodiac:varref-binding exp)])
|
||
|
|
(if (and (st:flow-sensitive) (Tvar? ftype))
|
||
|
|
(let* ( [type type]
|
||
|
|
[type (match type
|
||
|
|
[('exact type) type]
|
||
|
|
[type type])]
|
||
|
|
[etype (expand-input-type type)]
|
||
|
|
[templates (type->templates etype)]
|
||
|
|
[sym (zodiac:binding-var name)])
|
||
|
|
(if templates
|
||
|
|
(let* ( [filter (create-filter #t templates)]
|
||
|
|
[nutvar (mk-Tvar sym)])
|
||
|
|
(new-con! ftype (create-con-filter filter nutvar))
|
||
|
|
(values (wrap-value nutvar)
|
||
|
|
(atenv:change-binding nuenv name nutvar)))
|
||
|
|
(values (wrap-value ftype) nuenv)))
|
||
|
|
(values (wrap-value ftype) nuenv)))]
|
||
|
|
[_ (values (wrap-value ftype) nuenv)]))]
|
||
|
|
|
||
|
|
[($ zodiac:st:control-form _ _ _ _ para val)
|
||
|
|
(mrspidey:control-fn para val)
|
||
|
|
(values (wrap-value (mk-tvar-void)) env)]
|
||
|
|
|
||
|
|
[($ zodiac:type:-form _ s _ _ type attrs)
|
||
|
|
(let ([type (expand-input-type-err type E)])
|
||
|
|
(values
|
||
|
|
(wrap-value (apply primitive->atprim 'user type attrs))
|
||
|
|
env))]
|
||
|
|
|
||
|
|
[($ zodiac:reference-unit-form)
|
||
|
|
(values
|
||
|
|
(wrap-value (made-unit (create-atlunit-reference E)))
|
||
|
|
env)]
|
||
|
|
|
||
|
|
[($ zodiac:invoke-open-unit-form)
|
||
|
|
(mrspidey:error
|
||
|
|
"MrSpidey does not support invoke-open-unit" E)]
|
||
|
|
|
||
|
|
[($ zodiac:define-values-form)
|
||
|
|
(mrspidey:error
|
||
|
|
"MrSpidey does not support internal defines" E)]
|
||
|
|
|
||
|
|
[E
|
||
|
|
(set! traverse:bad-expr E)
|
||
|
|
(mrspidey:error "Bad expr in traverse" E)])]
|
||
|
|
|
||
|
|
;; --------------------
|
||
|
|
|
||
|
|
;; env-result may contain extra bindings,
|
||
|
|
;; but they have no effect
|
||
|
|
|
||
|
|
[_ (: result (union Tvar fo-FlowType fo-Atype))]
|
||
|
|
[_ (pretty-debug-traverse
|
||
|
|
`(traverse result ,(FlowType->pretty result)))]
|
||
|
|
[ftype (link-parsed-ftype! E result)])
|
||
|
|
|
||
|
|
(pretty-debug-traverse-small
|
||
|
|
`(<-traverse
|
||
|
|
,(zodiac:location-offset (zodiac:zodiac-start E))
|
||
|
|
,(zodiac:stripper E)
|
||
|
|
,(atenv->pretty env-result)
|
||
|
|
,(FlowType->pretty ftype)))
|
||
|
|
|
||
|
|
(assert (FlowType? ftype) 'end-traverse ftype)
|
||
|
|
(values ftype env-result)))])
|
||
|
|
|
||
|
|
(let-values ([(ftype env) (traverse E env)])
|
||
|
|
(values ftype env refs))))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (handle-class*/names-form E start-env
|
||
|
|
traverse traverse* handle-application)
|
||
|
|
(let ([handle-paroptarglist
|
||
|
|
(lambda (env init-arglist tvar-arg)
|
||
|
|
(pretty-debug-object
|
||
|
|
`(handle-paroptarglist ,(atenv->pretty env)
|
||
|
|
,init-arglist
|
||
|
|
,(Tvar-name tvar-arg)))
|
||
|
|
;; Bindings are already in atlist
|
||
|
|
(let*
|
||
|
|
( [improper?
|
||
|
|
(or (zodiac:sym-paroptarglist? init-arglist)
|
||
|
|
(zodiac:ilist-paroptarglist? init-arglist))]
|
||
|
|
[args (zodiac:paroptarglist-vars init-arglist)]
|
||
|
|
[initialize-arg
|
||
|
|
(lambda (env arg tvar)
|
||
|
|
(match arg
|
||
|
|
[(and bind ($ zodiac:binding))
|
||
|
|
(atenv:change-binding env bind tvar)]
|
||
|
|
[((and bind ($ zodiac:binding)) . exp)
|
||
|
|
(let*-vals
|
||
|
|
( [(ftype env) (traverse exp env)]
|
||
|
|
[ftype (extract-1st-value ftype)])
|
||
|
|
(new-edge! (FlowType->Tvar ftype) tvar)
|
||
|
|
(atenv:change-binding env bind tvar))]))])
|
||
|
|
(recur loop ([env env][args args][tvar tvar-arg])
|
||
|
|
(cond
|
||
|
|
[(null? args) env]
|
||
|
|
[(and improper? (null? (cdr args)))
|
||
|
|
(initialize-arg env (car args) tvar)]
|
||
|
|
[else
|
||
|
|
(let ( [tvar-car (mk-Tvar 'arg-car)]
|
||
|
|
[tvar-cdr (mk-Tvar 'arg-cdr)])
|
||
|
|
(new-con! tvar (make-con-car tvar-car))
|
||
|
|
(new-con! tvar (make-con-cdr tvar-cdr))
|
||
|
|
(loop
|
||
|
|
(initialize-arg env (car args) tvar-car)
|
||
|
|
(cdr args)
|
||
|
|
tvar-cdr))]))))])
|
||
|
|
|
||
|
|
(match E
|
||
|
|
[($ zodiac:class*/names-form _ _ _ _
|
||
|
|
this-name
|
||
|
|
super-init-name
|
||
|
|
super-expr
|
||
|
|
_
|
||
|
|
(and init-arglist ($ zodiac:paroptarglist init-vars))
|
||
|
|
clauses)
|
||
|
|
|
||
|
|
(pretty-debug-object `(init-arglist ,init-arglist))
|
||
|
|
|
||
|
|
(let*-vals
|
||
|
|
( ;; --- Work from top down according to class.dvi
|
||
|
|
;; --- Traverse super-exprs
|
||
|
|
[(super-ftype env-after-super) (traverse super-expr start-env)]
|
||
|
|
[tvar-super (FlowType->Tvar (extract-1st-value super-ftype))]
|
||
|
|
|
||
|
|
;; extract portions of tvar-super
|
||
|
|
[f (lambda (sign)
|
||
|
|
(lambda (ndx)
|
||
|
|
(let ([tvar (mk-Tvar 'class-field)])
|
||
|
|
(new-con! tvar-super
|
||
|
|
(create-con template-internal-class
|
||
|
|
ndx tvar sign))
|
||
|
|
tvar)))]
|
||
|
|
[super-u ((f #t) 0)]
|
||
|
|
[super-o ((f #t) 1)]
|
||
|
|
[super-i ((f #t) 2)]
|
||
|
|
[super-f ((f #t) 3)]
|
||
|
|
[super-b ((f #f) 0)]
|
||
|
|
[super-a ((f #f) 1)]
|
||
|
|
[super-g ((f #f) 2)]
|
||
|
|
[super-t ((f #f) 3)]
|
||
|
|
[super-v ((f #t) 4)]
|
||
|
|
|
||
|
|
;; Transfers control just like lambdas, capture it here
|
||
|
|
[captured-env
|
||
|
|
(atenv:capture-locs env-after-super
|
||
|
|
(zodiac:free-vars E (atenv:domain env-after-super)))]
|
||
|
|
[env (atenv:extend captured-env super-init-name super-i)]
|
||
|
|
[env (atenv:unflush env)]
|
||
|
|
|
||
|
|
[super-init-name?
|
||
|
|
(lambda (var)
|
||
|
|
(and (zodiac:varref? var)
|
||
|
|
(eq? (zodiac:varref-binding var)
|
||
|
|
super-init-name)))]
|
||
|
|
|
||
|
|
;; Fields for class
|
||
|
|
|
||
|
|
[this-u (mk-Tvar 'this-u)]
|
||
|
|
[this-o (mk-Tvar 'this-o)]
|
||
|
|
[tvar-args (mk-Tvar 'this-tvar-args)]
|
||
|
|
[this-i (mk-Tvar-init-AV 'this-i
|
||
|
|
(make-AV-lam tvar-args (mk-tvar-void) 0 #t))]
|
||
|
|
[this-b (mk-Tvar 'this-b)]
|
||
|
|
[this-a (mk-Tvar 'this-a)]
|
||
|
|
[this-f (mk-Tvar 'this-f)]
|
||
|
|
[this-g (mk-Tvar 'this-g)]
|
||
|
|
[this-t (mk-Tvar 'this-t)]
|
||
|
|
[this-v (mk-Tvar 'this-v)]
|
||
|
|
[tvar-class
|
||
|
|
(mk-Tvar-init-AV 'class
|
||
|
|
(create-AV template-internal-class '()
|
||
|
|
(vector this-u this-o this-i this-f this-v)
|
||
|
|
(vector this-b this-a this-g this-t)))]
|
||
|
|
|
||
|
|
;; Anything not clause dependant
|
||
|
|
|
||
|
|
[_ (new-edge! super-u this-u)]
|
||
|
|
[_ (new-edge! this-t super-t)]
|
||
|
|
|
||
|
|
;; Now to do the init args and clauses
|
||
|
|
|
||
|
|
;; --- Build up environment
|
||
|
|
[env (atenv:extend env this-name this-t)]
|
||
|
|
;; args
|
||
|
|
[env (foldr
|
||
|
|
(lambda (var env)
|
||
|
|
(atenv:extend env
|
||
|
|
(if (zodiac:binding? var)
|
||
|
|
var
|
||
|
|
(car var))
|
||
|
|
(mk-Tvar 'init-var)))
|
||
|
|
env
|
||
|
|
init-vars)]
|
||
|
|
|
||
|
|
;; --- helper stuff
|
||
|
|
[tvar-undef (mk-Tvar-init-AV 'delta AV-undefined)]
|
||
|
|
[ivar-put
|
||
|
|
(lambda (to sym tvar)
|
||
|
|
(new-AV! to
|
||
|
|
(create-AV
|
||
|
|
(get-ivar-template sym)
|
||
|
|
'() (vector tvar) (vector))))]
|
||
|
|
[ivar-get
|
||
|
|
(lambda (from sym tvar)
|
||
|
|
(new-con! from
|
||
|
|
(create-con
|
||
|
|
(get-ivar-template sym)
|
||
|
|
0 tvar #t)))]
|
||
|
|
|
||
|
|
;; Traverse clauses, alloc a-j etc, extend env
|
||
|
|
;; and find super-init call
|
||
|
|
|
||
|
|
[super-init-expr #f]
|
||
|
|
[_ (pretty-debug-object `(calc clause-info))]
|
||
|
|
[clause-info
|
||
|
|
(map-clause
|
||
|
|
(lambda (public? define? override?
|
||
|
|
export internal expr import)
|
||
|
|
(let* ( [a-j (mk-Tvar 'a-j)]
|
||
|
|
[b-j (mk-Tvar 'b-j)]
|
||
|
|
[r-j (mk-Tvar 'r-j)]
|
||
|
|
[g-j (mk-Tvar 'g-j)])
|
||
|
|
(match expr
|
||
|
|
;; straight application
|
||
|
|
[($ zodiac:app _ _ _ _ (? super-init-name?) _)
|
||
|
|
(set! super-init-expr expr)]
|
||
|
|
;; apply
|
||
|
|
[($ zodiac:app _ _ _ _
|
||
|
|
(and fn ($ zodiac:varref _ _ _ _ 'apply))
|
||
|
|
((? super-init-name?) . _))
|
||
|
|
(match (FlowType->Atype
|
||
|
|
(atenv:lookup env (zodiac:varref-binding fn)))
|
||
|
|
[($ atprim 'apply)
|
||
|
|
(set! super-init-expr expr)]
|
||
|
|
[_ (void)])]
|
||
|
|
[_ (void)])
|
||
|
|
(when internal
|
||
|
|
(zodiac:set-binding-mutated! internal #t)
|
||
|
|
(set! env (atenv:extend-mutated env internal b-j g-j))
|
||
|
|
(link-parsed-ftype! internal r-j))
|
||
|
|
(list
|
||
|
|
public? define? override?
|
||
|
|
export internal expr import
|
||
|
|
a-j b-j r-j g-j)))
|
||
|
|
clauses)]
|
||
|
|
[_ (pretty-debug-object `(got clause-info))]
|
||
|
|
|
||
|
|
|
||
|
|
;; Ok, we have the full environment
|
||
|
|
;; Handle the argument list
|
||
|
|
|
||
|
|
[env (handle-paroptarglist env init-arglist tvar-args)]
|
||
|
|
|
||
|
|
;; --- create constraints for each clause
|
||
|
|
[super-init-called #f]
|
||
|
|
[public-templates '()]
|
||
|
|
[keyw-local-templates '()]
|
||
|
|
[before-not-flow-templates '()]
|
||
|
|
[after-not-flow-templates '()]
|
||
|
|
|
||
|
|
[extend-before-not-flow-templates!
|
||
|
|
(lambda (sym)
|
||
|
|
(set! before-not-flow-templates
|
||
|
|
(cons (get-ivar-template sym)
|
||
|
|
before-not-flow-templates)))]
|
||
|
|
[extend-after-not-flow-templates!
|
||
|
|
(lambda (sym)
|
||
|
|
(set! after-not-flow-templates
|
||
|
|
(cons (get-ivar-template sym)
|
||
|
|
after-not-flow-templates)))]
|
||
|
|
|
||
|
|
[_
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[( public? define? override?
|
||
|
|
export internal expr import
|
||
|
|
a-j b-j r-j g-j)
|
||
|
|
(pretty-debug-object
|
||
|
|
`(clause (,public? ,define? ,override?)
|
||
|
|
,export ,internal ,expr ,import
|
||
|
|
,(map FlowType->pretty (list a-j b-j r-j g-j))))
|
||
|
|
(new-edge! a-j b-j)
|
||
|
|
(when public?
|
||
|
|
(ivar-put this-u export tvar-undef)
|
||
|
|
(ivar-put this-o export r-j)
|
||
|
|
(ivar-get this-b export b-j)
|
||
|
|
(ivar-get this-a export a-j)
|
||
|
|
(ivar-get this-g export g-j)
|
||
|
|
(ivar-put this-f export g-j)
|
||
|
|
(set! public-templates
|
||
|
|
(cons (get-ivar-template export)
|
||
|
|
public-templates)))
|
||
|
|
(when (not public?)
|
||
|
|
(new-edge! tvar-undef b-j)
|
||
|
|
(new-edge! r-j a-j))
|
||
|
|
(when (not define?)
|
||
|
|
(ivar-get super-o import r-j))
|
||
|
|
(when override?
|
||
|
|
(extend-after-not-flow-templates! export)
|
||
|
|
(if (and super-init-expr (not super-init-called))
|
||
|
|
(begin
|
||
|
|
;; super-init will be called after this init
|
||
|
|
(ivar-put super-b export a-j)
|
||
|
|
(ivar-put super-a export a-j)
|
||
|
|
(extend-before-not-flow-templates! export))
|
||
|
|
(begin
|
||
|
|
;; super-init may be called before this init
|
||
|
|
(ivar-put super-a export b-j))))
|
||
|
|
(when (and public? (not override?))
|
||
|
|
(when define?
|
||
|
|
;; Prev value hidden, but define super-b, super-a
|
||
|
|
(ivar-put super-b export tvar-undef)
|
||
|
|
(let ([t (mk-Tvar 't)])
|
||
|
|
(ivar-get super-o export t)
|
||
|
|
(ivar-put super-a export t))
|
||
|
|
(extend-before-not-flow-templates! export)
|
||
|
|
(extend-after-not-flow-templates! export)
|
||
|
|
(set! keyw-local-templates
|
||
|
|
(cons (get-ivar-template export)
|
||
|
|
keyw-local-templates))))
|
||
|
|
(when define?
|
||
|
|
(if (eq? expr super-init-expr)
|
||
|
|
|
||
|
|
(let*-vals
|
||
|
|
([(ftype nu-env) (handle-application expr env #f)])
|
||
|
|
(link-parsed-ftype! expr (wrap-value (mk-tvar-void)))
|
||
|
|
(pretty-debug-object '(super-init called))
|
||
|
|
(set! super-init-called #t)
|
||
|
|
(set! env nu-env)
|
||
|
|
(new-AV! r-j AV-void)
|
||
|
|
|
||
|
|
;; Update env that super-init called
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[( _ #f _ _ internal _ import a-j b-j r-j g-j)
|
||
|
|
(set! env
|
||
|
|
(atenv:change-binding env internal a-j))]
|
||
|
|
[_ (void)])
|
||
|
|
clause-info))
|
||
|
|
|
||
|
|
(let*-vals
|
||
|
|
( [(ftype nu-env) (traverse expr env)]
|
||
|
|
[ftype (extract-1st-value ftype)])
|
||
|
|
(pretty-debug-atenv
|
||
|
|
`(env-before-traverse ,(atenv->pretty env)))
|
||
|
|
(set! env nu-env)
|
||
|
|
(pretty-debug-atenv
|
||
|
|
`(env-after-traverse ,(atenv->pretty env)))
|
||
|
|
(new-edge! (FlowType->Tvar ftype) r-j)
|
||
|
|
(when internal
|
||
|
|
(set! env
|
||
|
|
(atenv:change-binding env internal a-j))))))
|
||
|
|
|
||
|
|
(pretty-debug-atenv
|
||
|
|
`(end-clause ,(atenv->pretty env)))
|
||
|
|
])
|
||
|
|
|
||
|
|
clause-info)]
|
||
|
|
|
||
|
|
;; record ivarset
|
||
|
|
[public-ivars
|
||
|
|
(filter-map
|
||
|
|
(match-lambda
|
||
|
|
[( public? define? override?
|
||
|
|
export internal expr import
|
||
|
|
a-j b-j r-j g-j)
|
||
|
|
(and public? export)])
|
||
|
|
clause-info)]
|
||
|
|
[_ (new-AV! this-v
|
||
|
|
(create-AV
|
||
|
|
template-ivarset public-ivars
|
||
|
|
(vector super-v) mt-vector))]
|
||
|
|
|
||
|
|
[_ (begin
|
||
|
|
(new-con! super-o
|
||
|
|
(create-con-filter
|
||
|
|
(create-filter #f public-templates)
|
||
|
|
this-o))
|
||
|
|
(new-con! super-f
|
||
|
|
(create-con-filter
|
||
|
|
(create-filter #f public-templates)
|
||
|
|
this-f))
|
||
|
|
(new-con! this-b
|
||
|
|
(create-con-filter
|
||
|
|
(create-filter #f before-not-flow-templates)
|
||
|
|
super-b))
|
||
|
|
(new-con! this-a
|
||
|
|
(create-con-filter
|
||
|
|
(create-filter #f after-not-flow-templates)
|
||
|
|
super-a))
|
||
|
|
(new-con! this-g
|
||
|
|
(create-con-filter
|
||
|
|
(create-filter #f keyw-local-templates)
|
||
|
|
super-g)))])
|
||
|
|
|
||
|
|
(pretty-debug-object `(keyw-local-templates ,keyw-local-templates))
|
||
|
|
(pretty-debug-object `(tvar-class ,(FlowType->pretty tvar-class)))
|
||
|
|
|
||
|
|
(atenv:flush! env)
|
||
|
|
|
||
|
|
(values (wrap-value tvar-class) captured-env))])))
|
||
|
|
|
||
|
|
;; ----------------------------------------
|
||
|
|
|
||
|
|
(define (map-clause fn clauses)
|
||
|
|
(apply append
|
||
|
|
(map
|
||
|
|
(match-lambda
|
||
|
|
[($ zodiac:public-clause exports internals exprs)
|
||
|
|
(map
|
||
|
|
(lambda (export internal expr)
|
||
|
|
(fn #t #t #t (zodiac:read-object export) internal expr #f))
|
||
|
|
exports internals exprs)]
|
||
|
|
[($ zodiac:private-clause internals exprs)
|
||
|
|
(map
|
||
|
|
(lambda (internal expr)
|
||
|
|
(fn #f #t #f #f internal expr #f))
|
||
|
|
internals exprs)]
|
||
|
|
[($ zodiac:inherit-clause internals imports)
|
||
|
|
(map
|
||
|
|
(lambda (internal import)
|
||
|
|
(fn #t #f #f
|
||
|
|
(zodiac:read-object import) internal #f
|
||
|
|
(zodiac:read-object import)))
|
||
|
|
internals imports)]
|
||
|
|
[($ zodiac:rename-clause internals imports)
|
||
|
|
(map
|
||
|
|
(lambda (internal import)
|
||
|
|
(fn #f #f #f #f internal #f (zodiac:read-object import)))
|
||
|
|
internals imports)]
|
||
|
|
[($ zodiac:sequence-clause exprs)
|
||
|
|
(map
|
||
|
|
(lambda (expr)
|
||
|
|
(fn #f #t #f #f #f expr #f))
|
||
|
|
exprs)])
|
||
|
|
clauses)))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (handle-struct-form tag const atstruct fields)
|
||
|
|
(match atstruct
|
||
|
|
[($ atstruct
|
||
|
|
parent-struct:sym
|
||
|
|
super-constructors
|
||
|
|
parent-gen-args
|
||
|
|
parent-match-args
|
||
|
|
parent-field-types
|
||
|
|
parent-list-mutable)
|
||
|
|
(match-let*
|
||
|
|
([constructor (symbol-append 'structure: tag)]
|
||
|
|
[gen-args (map (lambda (_) (gensym)) fields)]
|
||
|
|
[match-args
|
||
|
|
(map (lambda (field gen-arg)
|
||
|
|
(match field
|
||
|
|
[((or '! ':) _ type) `(intersect ,gen-arg ,type)]
|
||
|
|
[_ gen-arg]))
|
||
|
|
fields gen-args)]
|
||
|
|
[field-names
|
||
|
|
(map (lambda (field)
|
||
|
|
(match field
|
||
|
|
[((or ': '!) (? symbol? name) _) name]
|
||
|
|
[(? symbol? name) name]
|
||
|
|
[_ (mrspidey:error
|
||
|
|
(format "Bad define-typed-structure field ~s"
|
||
|
|
field))]))
|
||
|
|
fields)]
|
||
|
|
[list-mutable
|
||
|
|
(map (lambda (field)
|
||
|
|
(match field
|
||
|
|
[('! (? symbol? name)) #t]
|
||
|
|
[_ (not const)]))
|
||
|
|
fields)]
|
||
|
|
[field-types
|
||
|
|
(map
|
||
|
|
(match-lambda [((or '! ':) _ type) (expand-input-type type)]
|
||
|
|
[_ 'top])
|
||
|
|
fields)]
|
||
|
|
|
||
|
|
[all-gen-args (append parent-gen-args gen-args)]
|
||
|
|
[all-match-args (append parent-match-args match-args)]
|
||
|
|
[all-field-types (append parent-field-types field-types)]
|
||
|
|
[all-list-mutable (append parent-list-mutable list-mutable)]
|
||
|
|
[_-parent-args (map (lambda (_) '_) parent-gen-args)]
|
||
|
|
|
||
|
|
[gen-arg (gensym)]
|
||
|
|
[defs `()]
|
||
|
|
[add-def!
|
||
|
|
(lambda (fo-Atype)
|
||
|
|
(set! defs (cons (create-fo-FlowType fo-Atype) defs)))]
|
||
|
|
[add!
|
||
|
|
(lambda (type . attrs)
|
||
|
|
(add-def!
|
||
|
|
(apply primitive->atprim 'define-struct type attrs)))])
|
||
|
|
|
||
|
|
;; (pretty-print match-args)
|
||
|
|
;; (pretty-print gen-args)
|
||
|
|
|
||
|
|
(add-def! (make-atstruct
|
||
|
|
(symbol-append 'struct: tag)
|
||
|
|
(cons constructor super-constructors)
|
||
|
|
all-gen-args all-match-args
|
||
|
|
all-field-types all-list-mutable))
|
||
|
|
|
||
|
|
(let ([template
|
||
|
|
(apply constructor->template constructor all-list-mutable)])
|
||
|
|
(for-each
|
||
|
|
(lambda (sc) (record-super-constructor-of-template! sc template))
|
||
|
|
super-constructors)
|
||
|
|
(extend-constructor-env! template))
|
||
|
|
|
||
|
|
(add!
|
||
|
|
`(forall ,all-gen-args
|
||
|
|
(,@all-match-args -> (,constructor ,@all-gen-args))))
|
||
|
|
(add! `(_ -> bool) `(predicate ,constructor))
|
||
|
|
(for n 0 (length fields)
|
||
|
|
(let* ([gen-arg (list-ref gen-args n)]
|
||
|
|
[field-name (list-ref field-names n)])
|
||
|
|
(add!
|
||
|
|
`(forall (,gen-arg)
|
||
|
|
((,constructor ,@_-parent-args
|
||
|
|
,@(map-with-n
|
||
|
|
(lambda (field m)
|
||
|
|
(if (= n m) gen-arg '_))
|
||
|
|
fields))
|
||
|
|
-> ,gen-arg)))
|
||
|
|
(when (list-ref list-mutable n)
|
||
|
|
(add! `(forall (,gen-arg)
|
||
|
|
((,constructor ,@_-parent-args
|
||
|
|
,@(map-with-n
|
||
|
|
(lambda (field m)
|
||
|
|
(if (= n m)
|
||
|
|
`(! ,gen-arg)
|
||
|
|
'_))
|
||
|
|
fields))
|
||
|
|
,(list-ref match-args n)
|
||
|
|
-> void))))))
|
||
|
|
|
||
|
|
(create-fo-FlowType (make-atvalues (reverse defs))))]))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define (zodiac:parsed-1st-ftype exp)
|
||
|
|
(extract-1st-value (zodiac:parsed-ftype exp)))
|
||
|
|
|
||
|
|
;; ----------
|
||
|
|
|
||
|
|
(define (if-splitting-env test env)
|
||
|
|
;; Returns (env-true env-false)
|
||
|
|
;; Assumes test expression already traversed
|
||
|
|
;; Can't lookup things in env, cause not defined for imported vars
|
||
|
|
(match test
|
||
|
|
;; arg
|
||
|
|
[($ zodiac:varref _ _ _ _ sym)
|
||
|
|
(let ([arg (zodiac:varref-binding test)])
|
||
|
|
(match (zodiac:parsed-1st-ftype test)
|
||
|
|
[(? Tvar? tvar)
|
||
|
|
(let* ([tvar-then (mk-Tvar sym)]
|
||
|
|
[tvar-else (mk-Tvar sym)]
|
||
|
|
[templates (list (lookup-template 'false))])
|
||
|
|
(new-con! tvar
|
||
|
|
(create-con-filter (create-filter #f templates) tvar-then))
|
||
|
|
(new-con! tvar
|
||
|
|
(create-con-filter (create-filter #t templates) tvar-else))
|
||
|
|
(values (atenv:change-binding env arg tvar-then)
|
||
|
|
(atenv:change-binding env arg tvar-else)))]
|
||
|
|
;; Annotated type so don't change
|
||
|
|
[_ (values env env)]))]
|
||
|
|
|
||
|
|
;; (not (pred? args ...))
|
||
|
|
[($ zodiac:app _ _ _ _ fn (pred-exp))
|
||
|
|
(=> fail)
|
||
|
|
(match (zodiac:parsed-atprim fn)
|
||
|
|
[($ atprim 'not)
|
||
|
|
;; Use recursive call and reverse
|
||
|
|
(let-values
|
||
|
|
([(env-true env-false) (if-splitting-env pred-exp env)])
|
||
|
|
(values env-false env-true))]
|
||
|
|
[_ (fail)])]
|
||
|
|
|
||
|
|
;; (pred? args ...)
|
||
|
|
[($ zodiac:app _ _ _ _ fn args)
|
||
|
|
(=> fail)
|
||
|
|
(match (zodiac:parsed-atprim fn)
|
||
|
|
[($ atprim _ type _ predicate-fn)
|
||
|
|
;;(pretty-print `(if (pred ,sym ,type ,predicate-fn ...)))
|
||
|
|
(recur loop ([args-before '()]
|
||
|
|
[args args]
|
||
|
|
[env-true env]
|
||
|
|
[env-false env])
|
||
|
|
(match args
|
||
|
|
[() (values env-true env-false)]
|
||
|
|
[((and arg ($ zodiac:varref)) . rest-args)
|
||
|
|
(=> fail)
|
||
|
|
(let ([barg (zodiac:varref-binding arg)])
|
||
|
|
(match (zodiac:parsed-1st-ftype arg)
|
||
|
|
[(? fo-FlowType?) (fail)]
|
||
|
|
[(? Tvar? tvar)
|
||
|
|
(let*
|
||
|
|
( [tvars-before (map zodiac:parsed-1st-ftype args-before)]
|
||
|
|
[tvars-after (map zodiac:parsed-1st-ftype rest-args)]
|
||
|
|
[tvar-true
|
||
|
|
(predicate-fn tvars-before tvars-after tvar #t)]
|
||
|
|
[tvar-false
|
||
|
|
(predicate-fn tvars-before tvars-after tvar #f)])
|
||
|
|
;;(pretty-print-debug (list tvar-true tvar-false))
|
||
|
|
(loop (append args-before (list arg))
|
||
|
|
rest-args
|
||
|
|
(if tvar-true
|
||
|
|
(atenv:change-binding env-true barg tvar-true)
|
||
|
|
env-true)
|
||
|
|
(if tvar-false
|
||
|
|
(atenv:change-binding env-false barg tvar-false)
|
||
|
|
env-false)))]))]
|
||
|
|
[(arg . rest-args)
|
||
|
|
(loop (append args-before (list arg))
|
||
|
|
rest-args env-true env-false)]))]
|
||
|
|
[_
|
||
|
|
;; Not a primitive
|
||
|
|
(fail)])]
|
||
|
|
|
||
|
|
[_ (values env env)]))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (flow-sensitive-env pi args env)
|
||
|
|
(match pi
|
||
|
|
[($ atprim _ _ domain-filters)
|
||
|
|
;; Walk domain-filters and args
|
||
|
|
(recur loop
|
||
|
|
([env env]
|
||
|
|
[args args]
|
||
|
|
[domain-filters domain-filters])
|
||
|
|
(match (list args domain-filters)
|
||
|
|
[( ((and arg ($ zodiac:varref _ _ _ _ arg-sym))
|
||
|
|
. args-rest)
|
||
|
|
((? filter? filter) . filters-rest))
|
||
|
|
(=> fail)
|
||
|
|
(let ([barg (zodiac:varref-binding arg)])
|
||
|
|
(match (FlowType->Tvar (zodiac:parsed-1st-ftype arg))
|
||
|
|
[(? fo-FlowType?)
|
||
|
|
;; Assigned, so don't track
|
||
|
|
(fail)]
|
||
|
|
[(? Tvar? tvar)
|
||
|
|
;; Have arg and domain
|
||
|
|
(let ([nu-tvar (mk-Tvar arg-sym)])
|
||
|
|
(new-con! tvar (create-con-filter filter nu-tvar))
|
||
|
|
(loop (atenv:change-binding env barg nu-tvar)
|
||
|
|
args-rest filters-rest))]))]
|
||
|
|
|
||
|
|
[( (_ . args-rest) (_ . filters-rest))
|
||
|
|
(loop env args-rest filters-rest)]
|
||
|
|
|
||
|
|
[_ env]))]
|
||
|
|
[#f env]))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
;; Constants -> constraints
|
||
|
|
;; All fns return Tvar
|
||
|
|
|
||
|
|
(define (traverse-const V)
|
||
|
|
;;(set! gV V)
|
||
|
|
;;(pretty-print (zodiac:stripper V))
|
||
|
|
;; Returns nothing
|
||
|
|
(let ([s (zodiac:const-size V)])
|
||
|
|
(if (>= s (st:const-merge-size))
|
||
|
|
(traverse-consts-tidy (list V))
|
||
|
|
(let ([Tvar (mk-Tvar 'traverse-const)])
|
||
|
|
(new-AV! Tvar (traverse-const-exact V))
|
||
|
|
Tvar))))
|
||
|
|
|
||
|
|
(define traverse-consts-tidy
|
||
|
|
;; Takes a list of constants
|
||
|
|
;; Returns a Tvar
|
||
|
|
(lambda (V*)
|
||
|
|
(match-let*
|
||
|
|
( [Tvar (mk-Tvar 'traverse-consts-tidy)]
|
||
|
|
[vec-elems
|
||
|
|
(apply append
|
||
|
|
(map
|
||
|
|
(match-lambda
|
||
|
|
[($ zodiac:vector _ _ _ v) v]
|
||
|
|
[(? vector? v) (vector->list v)]
|
||
|
|
[_ '()])
|
||
|
|
V*))]
|
||
|
|
[elems.cdr*
|
||
|
|
(filter-map
|
||
|
|
(match-lambda
|
||
|
|
[(or ($ zodiac:list _ _ _ l)
|
||
|
|
(? pair? l)
|
||
|
|
(? null? l))
|
||
|
|
(recur loop ([l l][elems '()])
|
||
|
|
(cond
|
||
|
|
[(pair? l) (loop (cdr l) (cons (car l) elems))]
|
||
|
|
[else (cons elems l)]))]
|
||
|
|
[($ zodiac:improper-list _ _ _ l)
|
||
|
|
(recur loop ([l l][elems '()])
|
||
|
|
(cond
|
||
|
|
[(and (pair? l) (null? (cdr l)))
|
||
|
|
(cons elems (car l))]
|
||
|
|
[(pair? l)
|
||
|
|
(loop (cdr l) (cons (car l) elems))]
|
||
|
|
[else (cons elems l)]))]
|
||
|
|
[_ #f])
|
||
|
|
V*)]
|
||
|
|
[elems (apply append (map car elems.cdr*))]
|
||
|
|
[cdrs (map cdr elems.cdr*)])
|
||
|
|
|
||
|
|
(unless (null? vec-elems)
|
||
|
|
(new-AV! Tvar
|
||
|
|
(make-AV-vec (traverse-consts-tidy vec-elems))))
|
||
|
|
(unless (null? elems)
|
||
|
|
(let* ([tvar-a (traverse-consts-tidy elems)]
|
||
|
|
[tvar-d (traverse-consts-tidy cdrs)]
|
||
|
|
[AV (make-AV-cons tvar-a tvar-d)])
|
||
|
|
(new-AV! tvar-d AV)
|
||
|
|
(new-AV! Tvar AV)))
|
||
|
|
|
||
|
|
(for-each
|
||
|
|
(lambda (V)
|
||
|
|
(let ([x (traverse-simple-const V)])
|
||
|
|
(when x (new-AV! Tvar x))))
|
||
|
|
V*)
|
||
|
|
|
||
|
|
Tvar)))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|