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.
686 lines
15 KiB
Scheme
686 lines
15 KiB
Scheme
;; sba-sigs.ss
|
|
; ----------------------------------------------------------------------
|
|
; 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.
|
|
; ----------------------------------------------------------------------
|
|
;; ----------------------------------------------------------------------
|
|
|
|
(define-signature mzlib:unprefixed-core^
|
|
( (open mzlib:pretty-print^)
|
|
(open mzlib:file^)
|
|
(open mzlib:function^)
|
|
(open mzlib:compat^)
|
|
(open mzlib:string^)))
|
|
|
|
(define-signature mrspidey:library-paras^
|
|
(make-parameter-boolean
|
|
make-parameter-integer
|
|
make-parameter-list))
|
|
|
|
(define-signature mrspidey:library-list^
|
|
(mapLR
|
|
mapRL
|
|
foldl-with-n
|
|
foldr2
|
|
filter
|
|
filter-map
|
|
filter-map-split
|
|
rac
|
|
rdc
|
|
map-with-n
|
|
for-each-with-n
|
|
map-ilist
|
|
length-ilist
|
|
improper?
|
|
flatten-ilist
|
|
map2
|
|
for-each2
|
|
andmap2
|
|
andmap2len
|
|
ormap2
|
|
list-n-copies
|
|
count
|
|
get-prefix
|
|
mklist
|
|
nth
|
|
list-pos
|
|
list-pos-equal
|
|
find
|
|
index
|
|
))
|
|
|
|
(define-signature mrspidey:library-vec^
|
|
( vector-copy
|
|
vector-map1
|
|
vector-map2
|
|
vector-map
|
|
vector-for-each-with-n
|
|
vector-for-each
|
|
vector-andmap1
|
|
vector-andmap2
|
|
vector-andmap
|
|
vector-ormap1
|
|
vector-ormap2
|
|
vector-ormap
|
|
vector-zero!))
|
|
|
|
(define-signature mrspidey:library-set^
|
|
(empty-set
|
|
empty-set?
|
|
set
|
|
list->set
|
|
list->set-equal?
|
|
element-of?
|
|
cardinality
|
|
set<=
|
|
set-eq?
|
|
union2
|
|
union
|
|
setdiff2
|
|
setdiff
|
|
intersect2
|
|
intersect))
|
|
|
|
(define-signature mrspidey:library-misc^
|
|
(symbol-append
|
|
get-cpu-time
|
|
get&return-cpu-time
|
|
make-timer
|
|
clear-timer!
|
|
record-time
|
|
strip-string
|
|
padl
|
|
padr
|
|
chop-number
|
|
substring?
|
|
char-find
|
|
file-newer
|
|
eqc?
|
|
))
|
|
|
|
(define-signature
|
|
mrspidey:env^
|
|
( empty-env lookup-or-fail lookup-or-#f lookup bound-in-env?
|
|
extend-env extend-env* join-env bang-env!
|
|
env:change-binding env:remove
|
|
))
|
|
|
|
(define-signature mrspidey:library^
|
|
((open mrspidey:library-paras^)
|
|
(open mrspidey:library-list^)
|
|
(open mrspidey:library-vec^)
|
|
(open mrspidey:library-set^)
|
|
(open mrspidey:library-misc^)
|
|
(open mrspidey:env^)))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
|
|
(define-signature mrspidey:interaction^
|
|
(mrspidey:error
|
|
mrspidey:warning
|
|
mrspidey:internal-error
|
|
mrspidey:add-summary
|
|
mrspidey:add-summary-handler
|
|
mrspidey:progress
|
|
mrspidey:progress-handler
|
|
record-analyzed-file
|
|
record-analyzed-file-hook
|
|
|
|
))
|
|
|
|
(define-signature mrspidey:config^
|
|
( st:restricted
|
|
st:name
|
|
st:version
|
|
|
|
st:fake-reader
|
|
st:system-expand
|
|
|
|
st:constants
|
|
st:const-merge-size
|
|
st:if-split
|
|
st:flow-sensitive
|
|
st:fo-units
|
|
st:lazy-fo-units
|
|
st:cache-units
|
|
st:whole-program
|
|
st:special-fo-prims
|
|
st:see-void
|
|
st:cons-mutable
|
|
st:use-fo-ftype
|
|
need-label-types
|
|
need-explanation
|
|
st:zero-old-constraint-sets
|
|
st:zero-old-asts
|
|
|
|
st:minimize-respect-assignable-part-of-fields
|
|
|
|
st:constraint-simplification-poly
|
|
st:polymorphism
|
|
|
|
st:unit-read-za
|
|
st:unit-write-za
|
|
st:unit-simplify
|
|
st:unit-separate-S
|
|
st:save-za-in
|
|
|
|
;; --- Type Viewing Parameters
|
|
st:sdl-fo
|
|
st:sdl-fo-ivars
|
|
st:sdl-fo-struct-fields
|
|
st:sdl-fo-depth-limit?
|
|
st:sdl-fo-depth-limit
|
|
st:sdl-fo-size-limit?
|
|
st:sdl-fo-size-limit
|
|
st:sdl-constraint-simplification
|
|
st:show-assignable-part-of-fields
|
|
st:listify-etc
|
|
st:sdl-constructor/selector
|
|
st:naming-strategy
|
|
st:primitive-types
|
|
st:expand-output-type
|
|
st:sdl-tidy
|
|
st:pretty-type-width
|
|
|
|
st:check-kernel
|
|
st:compare-min-algs
|
|
|
|
;; --- Checking Parameters
|
|
st:all-checks
|
|
|
|
;; st:show-filters
|
|
;; st:add-hyper-links
|
|
;; st:dont-combine-definitions
|
|
;; st:structure-opaque
|
|
;; st:library-prims
|
|
;; st:topo-sort
|
|
|
|
mrspidey:control-fn
|
|
|
|
))
|
|
|
|
(define-signature mrspidey:debugging^
|
|
(debugging
|
|
debugging-front
|
|
debugging-traverse
|
|
debugging-unit
|
|
debugging-check
|
|
debugging-atenv
|
|
debugging-atype
|
|
debugging-sdl
|
|
debugging-sdl2
|
|
debugging-gui
|
|
|
|
debugging-min
|
|
debugging-min2
|
|
debugging-few
|
|
debugging-gram
|
|
debugging-dfa-min
|
|
debugging-min-table
|
|
debugging-object
|
|
|
|
timing-min
|
|
|
|
pretty-print-debug
|
|
set-debug-flag
|
|
))
|
|
|
|
(define-signature mrspidey:CDL^
|
|
((open mrspidey:config^)
|
|
(open mrspidey:debugging^)
|
|
(open mrspidey:library^)))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; Kernel analysis stuff
|
|
|
|
(define-signature mrspidey:hash^
|
|
( init-hash-table
|
|
hash-fn hash-fn*
|
|
add-entry hash-find hash-table-info
|
|
capture-hash-table-state restore-hash-table-state!
|
|
prompt-hash-table-state unprompt-hash-table-state!
|
|
free-hash-table-state!
|
|
))
|
|
|
|
(define-signature
|
|
mrspidey:kernel^
|
|
(;; --- Structures
|
|
(struct FlowType
|
|
(num expr arrowto arrowfrom type-annotation proplist values-ftype))
|
|
num-ftype list-ftype num-edge
|
|
add-FlowType-arrow! add-FlowType!
|
|
add-FlowType-prop! get-FlowType-prop FlowType-name
|
|
|
|
(struct Tvar (objs orig-objs constraints edgeto edgefrom L U))
|
|
|
|
(struct AV (num template misc fields+ fields- U PU))
|
|
(struct template
|
|
(type num+ num- ref assign super-templates misc-eq?))
|
|
(struct con (num template field-no tvar misc sign))
|
|
(struct con-filter (num filter tvar))
|
|
(struct filter (sign templates))
|
|
create-filter
|
|
mt-vector
|
|
|
|
;; --- Values
|
|
num-con
|
|
num-AV
|
|
num-AV-in-Tvar
|
|
|
|
;; --- Functions
|
|
init-kernel!
|
|
create-AV
|
|
mk-Tvar
|
|
create-con create-con-misc create-con-filter
|
|
new-edge! new-bidir-edge! new-edge-para new-AV! new-create-AV! new-con!
|
|
new-leq-top-s! new-geq-top-s!
|
|
mk-Tvar-init-AV
|
|
constraint-system-size
|
|
get-Tvar-objs
|
|
add-AV! add-con! add-edge!
|
|
Tvar-name
|
|
|
|
save-kernel-state restore-kernel-state!
|
|
prompt-kernel-state unprompt-kernel-state!
|
|
free-kernel-state!
|
|
|
|
alloc-Tvar-field alloc-AV-field field->set
|
|
check-kernel-ok
|
|
really-check-kernel-ok
|
|
check-unreachable
|
|
))
|
|
|
|
(define-signature
|
|
mrspidey:gram^
|
|
( ;; --- grsyms
|
|
(struct grsym (fn mono))
|
|
(struct grsym-normal (template misc field-no))
|
|
(struct grsym-misc ())
|
|
grsym-eq?
|
|
|
|
;; --- rhs
|
|
(struct rhs (grsym nt))
|
|
add-rhs!
|
|
|
|
calc-productions!
|
|
))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; Front end stuff
|
|
|
|
(define-signature mrspidey:loadexpand^
|
|
(open-code-file
|
|
zodiac:read*
|
|
mrspidey:zprogress
|
|
strip-hash-percent
|
|
system-expand-if-necy
|
|
expand-zexp->port
|
|
|
|
clear-file-time-cache!
|
|
extend-file-time-cache!
|
|
zodiac-time
|
|
zodiac-time*
|
|
|
|
init-expand!
|
|
my-scheme-expand-program
|
|
))
|
|
|
|
;;(define-signature mrspidey:parser^ (top-level-parse-defs top-level-parse-exp))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
|
|
(define-signature mrspidey:atenv^
|
|
( atenv:empty
|
|
atenv:extend
|
|
atenv:extend-mutated
|
|
atenv:extend*
|
|
atenv:extend-voids
|
|
atenv:extend-undefineds
|
|
atenv:lookup
|
|
atenv:change-binding
|
|
atenv:change-bindings
|
|
atenv:capture-locs
|
|
atenv:unflush
|
|
atenv:flush!
|
|
atenv->pretty
|
|
atenv:domain
|
|
atenv:ok?
|
|
link-parsed-ftype!
|
|
))
|
|
|
|
(define-signature mrspidey:traverse^
|
|
( top-level-traverse-defs
|
|
traverse-defs
|
|
;;traverse-def
|
|
traverse-exp
|
|
))
|
|
|
|
(define-signature mrspidey:atype^
|
|
((struct fo-FlowType (def))
|
|
FlowType->Atype
|
|
create-fo-FlowType
|
|
fo-Atype? poly-atype?
|
|
|
|
(struct atconst (c))
|
|
(struct schema (tvar tvar* edges))
|
|
(struct atprim (sym type domain-filters predicate-fn attrs orig-type))
|
|
(struct atthunk (thunk))
|
|
(struct atstruct (struct:sym super-constructors
|
|
parent-gen-args
|
|
parent-match-args
|
|
parent-field-types
|
|
parent-list-mutable))
|
|
(struct atvalues (values))
|
|
wrap-value extract-1st-value multiple-value-components
|
|
|
|
(struct atunit (imports exports result expr))
|
|
(struct atlunit (ui))
|
|
|
|
FlowType->Tvar
|
|
Atype->Tvar
|
|
FlowType->pretty
|
|
FlowType->SDL
|
|
copy-ftype
|
|
))
|
|
|
|
(define-signature mrspidey:atlunit^
|
|
(create-atlunit-unit
|
|
create-atlunit-cmpd
|
|
create-atlunit-reference
|
|
|
|
apply-unit
|
|
atlunit->atunit
|
|
apply-atlunit
|
|
|
|
))
|
|
|
|
|
|
(define-signature mrspidey:type-env^
|
|
(global-tref-env
|
|
global-tdef-env
|
|
global-tbang-env
|
|
|
|
add-global-tref!
|
|
add-global-tdef!
|
|
add-global-tbang!
|
|
init-global-tenv!
|
|
|
|
connect-bangs-defs
|
|
report-duplicate-defs
|
|
connect-refs-defs
|
|
report-unbound-vars
|
|
))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; ???
|
|
|
|
(define-signature mrspidey:templates^
|
|
( constructor->template
|
|
constructor-env
|
|
set-constructor-env!
|
|
extend-constructor-env!
|
|
add-constructor!
|
|
constructor-alias!
|
|
record-super-constructor!
|
|
record-super-constructor-of-template!
|
|
record-super-template!
|
|
|
|
lam-misc-eq?
|
|
template-lam
|
|
template-lam++
|
|
filter-not-lam
|
|
template-cons
|
|
template-nil
|
|
template-num
|
|
template-sym
|
|
template-str
|
|
template-char
|
|
template-void
|
|
template-undefined
|
|
template-true
|
|
template-false
|
|
template-promise
|
|
template-unit
|
|
template-structure
|
|
template-mvalues
|
|
template-internal-class
|
|
template-all-ivars
|
|
template-dots
|
|
;;template-ivar-box
|
|
template-top-s
|
|
template-ivarset
|
|
|
|
init-default-constructor-env!
|
|
|
|
saved-constructor-env
|
|
init-constructor-env!
|
|
|
|
get-unit-import-template
|
|
get-unit-export-template
|
|
get-ivar-template
|
|
|
|
type-constructor?
|
|
lookup-template
|
|
lookup-template-or-error
|
|
is-template?
|
|
))
|
|
|
|
(define-signature mrspidey:kernel-aux^
|
|
( make-constructed-AV-template
|
|
make-constructed-AV
|
|
make-constructed-Tvar
|
|
|
|
make-AV-cons
|
|
make-con-car
|
|
make-con-cdr
|
|
make-con-dom
|
|
make-con-rng
|
|
;make-con-arg-car
|
|
;make-con-arg-cdr
|
|
make-AV-vec
|
|
make-AV-lam
|
|
|
|
AV-nil
|
|
AV-numb
|
|
AV-sym
|
|
AV-str
|
|
AV-char
|
|
AV-true
|
|
AV-false
|
|
AV-void
|
|
AV-undefined
|
|
AV-top-s
|
|
|
|
mk-tvar-nil
|
|
mk-tvar-numb
|
|
mk-tvar-sym
|
|
mk-tvar-str
|
|
mk-tvar-char
|
|
mk-tvar-void
|
|
mk-tvar-undefined
|
|
mk-tvar-true
|
|
mk-tvar-false
|
|
mk-tvar-empty
|
|
|
|
init-common-AV!
|
|
traverse-simple-const
|
|
traverse-const-exact
|
|
|
|
Tvar-transitive-edgeto
|
|
copy-constraint-set
|
|
AV->rep
|
|
|
|
;; --- NTs
|
|
(struct NT (tvar type rhs*))
|
|
mk-Tvar-NTs! mk-AV-NTs!
|
|
alloc-NT-field
|
|
nt->sym
|
|
select-L
|
|
select-U
|
|
chk-Tvar-U
|
|
chk-Tvar-L
|
|
chk-AV-U
|
|
))
|
|
|
|
(define-signature mrspidey:sdl^
|
|
(Tvar->SDL))
|
|
|
|
(define-signature mrspidey:languages^
|
|
( st:language
|
|
initialize-language!
|
|
st:numops
|
|
get-default-bindings
|
|
make-expander-namespace
|
|
))
|
|
|
|
; ----------------------------------------------------------------------
|
|
|
|
(define-signature mrspidey:typelang^
|
|
( absUnion absunion absIntersect absintersect
|
|
init-output-type-expander! install-output-type-expander!
|
|
init-input-type-expander!
|
|
install-input-type-expander!
|
|
expand-input-type expand-input-type-err expand-output-type
|
|
typevar?
|
|
|
|
type->templates
|
|
split-schema
|
|
schema->con
|
|
tschema->con
|
|
tschema->con-for-nargs
|
|
;;dom+rng-for-nargs
|
|
Tvar-in-type?
|
|
primitive->atprim))
|
|
|
|
(define-signature mrspidey:contained^
|
|
(Tvar-containment?))
|
|
; ----------------------------------------------------------------------
|
|
|
|
(define-signature mrspidey:min^
|
|
( minimize-constraints-&-compare
|
|
minimize-constraints
|
|
min-record-progress))
|
|
|
|
(define-signature mrspidey:min-live^
|
|
( copy-live-constraints
|
|
copy-live-constraints-noe
|
|
calc-live-tvars-nts
|
|
copy-constraints-equiv!
|
|
follow-antimono-fields))
|
|
|
|
(define-signature mrspidey:find-nonempty-tvars^
|
|
( copy-nonempty-tvars
|
|
find-nonempty-tvars))
|
|
|
|
(define-signature mrspidey:min-live-few-e^
|
|
(copy-live-constraints-few-e))
|
|
|
|
(define-signature mrspidey:hopcroft^
|
|
(Hopcroft-calc-equivalences))
|
|
|
|
(define-signature mrspidey:min-dfa-fast^
|
|
( minimize-constraints-dfa-min-lub
|
|
minimize-constraints-dfa-min-glb))
|
|
|
|
; ----------------------------------------------------------------------
|
|
|
|
(define-signature mrspidey:calc-checks^
|
|
( calc-checks
|
|
calc-type-annotations
|
|
(struct annotation (loc))
|
|
(struct check-annotation (text num rest))
|
|
(struct uncheck-annotation (text))
|
|
(struct type-annotation (end-first finish FlowType))
|
|
))
|
|
|
|
(define-signature mrspidey:za^
|
|
(read-za write-za))
|
|
|
|
; ----------------------------------------------------------------------
|
|
|
|
(define-signature mrspidey:program^
|
|
(analyze-program global-def-env initialize-analysis!))
|
|
|
|
(define-signature mrspidey:driver^
|
|
(st:analyze st: st:type-fn st:help st:set-debug))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
|
|
(define-signature
|
|
mrspidey:zodiac-aux^
|
|
( compat compat*
|
|
ast-size const-size
|
|
unparse-dynamic-letd
|
|
stripper
|
|
|
|
parsed-ftype set-parsed-ftype!
|
|
parsed-check set-parsed-check!
|
|
parsed-atprim set-parsed-atprim!
|
|
app-tvar-args set-app-tvar-args!
|
|
binding-refs set-binding-refs!
|
|
binding-mutated set-binding-mutated!
|
|
varref-binding
|
|
my-create-binding
|
|
|
|
lambda-flatten-arglist
|
|
|
|
no-location
|
|
location-inc
|
|
determine-end-first-token
|
|
|
|
parsed-value?
|
|
free-refs
|
|
free-vars
|
|
initialize-mutated
|
|
free-vars-defs
|
|
zero!
|
|
inline-begins
|
|
))
|
|
|
|
(define-signature mrspidey:zodiac^
|
|
((open zodiac:system^) (open mrspidey:zodiac-aux^)))
|
|
|
|
; ----------------------------------------------------------------------
|
|
|
|
(define-signature mrspidey:hyper^
|
|
( analysis-set-arrow-filter!
|
|
analysis-filter-on?
|
|
analysis-get-filters
|
|
analysis-shortest-path
|
|
analysis-parents
|
|
analysis-children
|
|
analysis-ancestors
|
|
analysis-descendants
|
|
analysis-callback
|
|
analysis-get-param
|
|
analysis-set-param!
|
|
calc-annotations
|
|
st:analyze-and-make-annotations
|
|
|
|
))
|
|
|
|
(define-signature mrspidey:sba^
|
|
( (open mrspidey:driver^)
|
|
(open mrspidey:CDL^)
|
|
(open mrspidey:atype^)
|
|
(open mrspidey:hyper^)
|
|
(open mrspidey:kernel^)
|
|
(open mrspidey:calc-checks^)
|
|
(open mrspidey:languages^)
|
|
(unit zodiac : mrspidey:zodiac^)
|
|
))
|
|
|
|
; ----------------------------------------------------------------------
|