steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

pre-chew the bite-sized morsels of stack-checker.row-polymorphism so they're easy for old people to digest

db4
Joe Groff 2010-03-11 14:09:18 -08:00
parent 0d3015cd1c
commit dfbe1211f7
1 changed files with 20 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
basis/stack-checker/row-polymorphism/row-polymorphism.factor
View File

@ -24,45 +24,41 @@ IN: stack-checker.row-polymorphism
meta-d length input-count get meta-d length input-count get
[ with-inner-d ] 2dip (effect-here) ; inline [ with-inner-d ] 2dip (effect-here) ; inline
:: (check-variable) ( actual-count declared-count variable vars -- difference ? ) : (diff-variable) ( diff variable vars -- diff' )
actual-count declared-count - [ at* nip ] [ '[ _ _ at - ] ] [ '[ _ _ set-at 0 ] ] 2tri if ;
variable [
variable vars at* nip : (check-variable) ( actual-count declared-count variable vars -- diff ? )
[ variable vars at - ] [ - ] 2dip dupd '[ _ _ (diff-variable) t ] [ dup 0 <= ] if ;
[ variable vars set-at 0 ] if
t
] [ dup 0 <= ] if ;
: adjust-variable ( diff var vars -- ) : adjust-variable ( diff var vars -- )
pick 0 >= pick 0 >= [ at+ ] [ 3drop ] if ; inline
[ at+ ]
[ 3drop ] if ; inline
:: check-variable ( vars declared actual slot var-slot -- diff ok? var ) :: check-variable ( vars declared actual slot var-slot -- diff ok? var )
actual declared [ slot call length ] bi@ declared var-slot call actual declared [ slot call length ] bi@ declared var-slot call
[ vars (check-variable) ] keep ; inline [ vars (check-variable) ] keep ; inline
:: unify-variables ( in-diff in-ok? in-var out-diff out-ok? out-var vars -- ? ) :: unify-variables ( in-diff in-ok? in-var out-diff out-ok? out-var vars -- ? )
{ [ in-ok? ] [ out-ok? ] [ in-diff out-diff = ] } 0&& { [ in-ok? ] [ out-ok? ] [ in-diff out-diff = ] } 0&& dup [
dup [
in-var [ in-diff swap vars adjust-variable ] when* in-var [ in-diff swap vars adjust-variable ] when*
out-var [ out-diff swap vars adjust-variable ] when* out-var [ out-diff swap vars adjust-variable ] when*
] when ; ] when ;
: (check-variables) ( vars declared actual -- ? )
[ [ in>> ] [ in-var>> ] check-variable ]
[ [ out>> ] [ out-var>> ] check-variable ]
[ 2drop ] 3tri unify-variables ;
: check-variables ( vars declared actual -- ? ) : check-variables ( vars declared actual -- ? )
dup terminated?>> [ 3drop t ] [ dup terminated?>> [ 3drop t ] [ (check-variables) ] if ;
[ [ in>> ] [ in-var>> ] check-variable ]
[ [ out>> ] [ out-var>> ] check-variable ] : combinator-branches-effects ( branches -- quots declareds actuals )
[ 2drop ] 3tri unify-variables [ [ known>callable ] { } map-as ]
] if ; [ [ effect>> ] { } map-as ]
[ [ actual>> ] { } map-as ] tri ;
: combinator-unbalanced-branches-error ( known -- * ) : combinator-unbalanced-branches-error ( known -- * )
[ word>> ] [ [ word>> ] [ branches>> <reversed> combinator-branches-effects ] bi
branches>> <reversed> unbalanced-branches-error ;
[ [ known>callable ] { } map-as ]
[ [ effect>> ] { } map-as ]
[ [ actual>> ] { } map-as ] tri
] bi unbalanced-branches-error ;
: check-declared-effect ( known effect -- ) : check-declared-effect ( known effect -- )
[ >>actual ] keep [ >>actual ] keep