: push-d ( obj -- ) meta-d push ;
: introduce-values ( values -- )
- [ [ [ input-parameter ] dip set-known ] each ]
+ [ [ input-parameter swap set-known ] each ]
[ length input-count +@ ]
[ #introduce, ]
tri ;
: push-r ( obj -- ) meta-r push ;
: pop-r ( -- obj )
- meta-r dup empty?
- [ too-many-r> ] [ pop ] if ;
+ meta-r [ too-many-r> ] [ pop ] if-empty ;
: consume-r ( n -- seq )
- meta-r 2dup length >
- [ too-many-r> ] when
+ meta-r 2dup length > [ too-many-r> ] when
[ swap tail* ] [ shorten-by ] 2bi ;
: output-r ( seq -- ) meta-r push-all ;
] [ pop recursive-state get swap ] if-empty ;
: literals-available? ( n -- literals ? )
- literals get 2dup length <=
- [ [ swap tail* ] [ shorten-by ] 2bi t ] [ 2drop f f ] if ;
+ literals get 2dup length <= [
+ [ swap tail* ] [ shorten-by ] 2bi t
+ ] [
+ 2drop f f
+ ] if ;
GENERIC: apply-object ( obj -- )
TUPLE: depends-on-class-predicate class1 class2 result ;
: add-depends-on-class-predicate ( class1 class2 result -- )
- \ depends-on-class-predicate add-conditional-dependency ;
+ depends-on-class-predicate add-conditional-dependency ;
M: depends-on-class-predicate satisfied?
{
TUPLE: depends-on-instance-predicate object class result ;
: add-depends-on-instance-predicate ( object class result -- )
- \ depends-on-instance-predicate add-conditional-dependency ;
+ depends-on-instance-predicate add-conditional-dependency ;
M: depends-on-instance-predicate satisfied?
{
: add-depends-on-next-method ( class generic next-method -- )
over add-depends-on-conditionally
- \ depends-on-next-method add-conditional-dependency ;
+ depends-on-next-method add-conditional-dependency ;
M: depends-on-next-method satisfied?
{
: add-depends-on-method ( class generic method -- )
over add-depends-on-conditionally
- \ depends-on-method add-conditional-dependency ;
+ depends-on-method add-conditional-dependency ;
M: depends-on-method satisfied?
{
: add-depends-on-tuple-layout ( class layout -- )
[ drop add-depends-on-conditionally ]
- [ \ depends-on-tuple-layout add-conditional-dependency ] 2bi ;
+ [ depends-on-tuple-layout add-conditional-dependency ] 2bi ;
M: depends-on-tuple-layout satisfied?
[ class>> tuple-layout ] [ layout>> ] bi eq? ;
: add-depends-on-flushable ( word -- )
[ add-depends-on-conditionally ]
- [ \ depends-on-flushable add-conditional-dependency ] bi ;
+ [ depends-on-flushable add-conditional-dependency ] bi ;
M: depends-on-flushable satisfied?
word>> flushable? ;
: add-depends-on-final ( word -- )
[ add-depends-on-conditionally ]
- [ \ depends-on-final add-conditional-dependency ] bi ;
+ [ depends-on-final add-conditional-dependency ] bi ;
M: depends-on-final satisfied?
class>> { [ class? ] [ final-class? ] } 1&& ;
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays effects fry hints kernel math math.order
-namespaces sequences stack-checker.backend
+USING: accessors arrays effects fry hints kernel locals math
+math.order namespaces sequences stack-checker.backend
stack-checker.dependencies stack-checker.errors
stack-checker.known-words stack-checker.recursive-state
stack-checker.state stack-checker.values stack-checker.visitor
: entry-stack-height ( label -- stack )
enter-out>> length ;
-: check-return ( word label -- )
- 2dup
- [ stack-height ]
- [ entry-stack-height current-stack-height swap - ]
- bi*
- = [ 2drop ] [
- terminated? get [ 2drop ] [
- word>> current-stack-height
+:: check-return ( word label -- )
+ word stack-height
+ current-stack-height label entry-stack-height -
+ = [
+ terminated? get [
+ label word>> current-stack-height
unbalanced-recursion-error inference-error
- ] if
- ] if ;
+ ] unless
+ ] unless ;
: end-recursive-word ( word label -- )
[ check-return ]
<effect> ;
: call-recursive-inline-word ( word label -- )
- over "recursive" word-prop [
+ over recursive? [
[ required-stack-effect adjust-stack-effect ] dip
[ check-call ] [ '[ _ #call-recursive, ] consume/produce ] bi
- ] [ drop undeclared-recursion-error inference-error ] if ;
+ ] [
+ drop undeclared-recursion-error inference-error
+ ] if ;
: inline-word ( word -- )
commit-literals
dup inline-recursive-label [
call-recursive-inline-word
] [
- dup "recursive" word-prop
+ dup recursive?
[ inline-recursive-word ]
[ dup infer-inline-word-def ]
if
M: literal-tuple hashcode* nip value>> identity-hashcode ;
: <literal> ( obj -- value )
- recursive-state get \ literal-tuple boa ;
+ recursive-state get literal-tuple boa ;
M: literal-tuple (input-value?) drop f ;
: curried/composed-literal ( input1 input2 quot -- literal )
[ [ literal ] bi@ ] dip
[ [ [ value>> ] bi@ ] dip call ] [ drop nip recursion>> ] 3bi
- \ literal-tuple boa ; inline
+ literal-tuple boa ; inline
TUPLE: curried obj quot ;
[ quot1>> ] [ quot2>> ] bi ; inline
M: composed (input-value?)
- [ quot1>> input-value? ] [ quot2>> input-value? ] bi or ;
+ >composed< [ input-value? ] either? ;
M: composed (literal-value?)
>composed< [ literal-value? ] both? ;
M: literal-tuple known>callable value>> ;
M: composed known>callable
- [ quot1>> ] [ quot2>> ] bi
- [ known known>callable ?@ ] bi@ append ;
+ >composed< [ known known>callable ?@ ] bi@ append ;
M: curried known>callable
- [ quot>> ] [ obj>> ] bi
- [ known known>callable ] bi@ prefix ;
+ >curried< [ known known>callable ] bi@ swap prefix ;
M: declared-effect known>callable
known>> known>callable ;