stack-checker: a little cleanup.

locals-and-roots
John Benediktsson 2016-03-27 10:01:56 -07:00
parent f549283508
commit 7038e8a55e
4 changed files with 35 additions and 36 deletions

View File

@ -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 -- )

View File

@ -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&& ;

View File

@ -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

View File

@ -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 ;