stack-checker: a little cleanup.
parent
f549283508
commit
7038e8a55e
|
@ -11,7 +11,7 @@ IN: stack-checker.backend
|
|||
: 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 ;
|
||||
|
@ -55,12 +55,10 @@ IN: stack-checker.backend
|
|||
: 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 ;
|
||||
|
@ -76,8 +74,11 @@ IN: stack-checker.backend
|
|||
] [ 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 -- )
|
||||
|
||||
|
|
|
@ -75,7 +75,7 @@ GENERIC: satisfied? ( dependency -- ? )
|
|||
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?
|
||||
{
|
||||
|
@ -87,7 +87,7 @@ 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?
|
||||
{
|
||||
|
@ -99,7 +99,7 @@ TUPLE: depends-on-next-method class generic next-method ;
|
|||
|
||||
: 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?
|
||||
{
|
||||
|
@ -111,7 +111,7 @@ TUPLE: depends-on-method class generic method ;
|
|||
|
||||
: 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?
|
||||
{
|
||||
|
@ -123,7 +123,7 @@ TUPLE: depends-on-tuple-layout class layout ;
|
|||
|
||||
: 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? ;
|
||||
|
@ -132,7 +132,7 @@ TUPLE: depends-on-flushable word ;
|
|||
|
||||
: 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? ;
|
||||
|
@ -141,7 +141,7 @@ TUPLE: depends-on-final class ;
|
|||
|
||||
: 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&& ;
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! 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
|
||||
|
@ -56,17 +56,15 @@ SYMBOL: enter-out
|
|||
: 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 ]
|
||||
|
@ -134,10 +132,12 @@ M: declared-effect (undeclared-known) known>> (undeclared-known) ;
|
|||
<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
|
||||
|
@ -147,7 +147,7 @@ M: declared-effect (undeclared-known) known>> (undeclared-known) ;
|
|||
dup inline-recursive-label [
|
||||
call-recursive-inline-word
|
||||
] [
|
||||
dup "recursive" word-prop
|
||||
dup recursive?
|
||||
[ inline-recursive-word ]
|
||||
[ dup infer-inline-word-def ]
|
||||
if
|
||||
|
|
|
@ -45,7 +45,7 @@ TUPLE: literal-tuple < identity-tuple value recursion ;
|
|||
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 ;
|
||||
|
||||
|
@ -56,7 +56,7 @@ M: literal-tuple (literal) ;
|
|||
: 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 ;
|
||||
|
||||
|
@ -82,7 +82,7 @@ C: <composed> composed
|
|||
[ 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? ;
|
||||
|
@ -132,12 +132,10 @@ M: object known>callable drop \ _ ;
|
|||
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 ;
|
||||
|
|
Loading…
Reference in New Issue