: successors ( bb -- first second ) successors>> first2 ; inline
-:: conditional ( bb insn n conditional-quot negate-cc-quot -- bb successor label ... )
+:: conditional ( bb insn n conditional-quot negate-cc-quot -- bb successor label etc... )
bb insn
conditional-quot
[ drop dup successors>> second useless-branch? ] 2bi
M: effect curry-effect
[ in>> length ] [ out>> length ] [ terminated?>> ] tri
pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
- [ [ "x" <array> ] bi@ ] dip effect boa ;
+ [ [ "x" <array> ] bi@ ] dip <terminated-effect> ;
M: curry cached-effect
quot>> cached-effect curry-effect ;
M: bad-effect summary
drop "Bad stack effect declaration" ;
+M: invalid-effect-variable summary
+ drop "Stack effect variables can only occur as the first input or output" ;
+M: effect-variable-can't-have-type summary
+ drop "Stack effect variables cannot have a declared type" ;
M: bad-escape error.
"Bad escape code: \\" write
{ $notes "This word can be used with " { $link apply-curry } " to generalize the " { $snippet "bi-curry@ bi*" } " or " { $snippet "tri-curry@ tri*" } " dataflow patterns." } ;\r
\r
HELP: apply-curry\r
-{ $values { "...a" { $snippet "n" } " values on the datastack" } { "quot" quotation } { "n" integer } }\r
+{ $values { "a..." { $snippet "n" } " values on the datastack" } { "quot" quotation } { "n" integer } }\r
{ $description "Curries each of the top " { $snippet "n" } " items of the datastack onto " { $snippet "quot" } ", leaving " { $snippet "n" } " quotations on the datastack. A generalization of " { $link bi-curry@ } " and " { $link tri-curry@ } "." }\r
{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry@ bi" } ", " { $snippet "tri-curry@ tri" } ", " { $snippet "bi-curry@ bi*" } ", and " { $snippet "tri-curry@ tri*" } "." } ;\r
\r
HELP: cleave-curry\r
-{ $values { "a" object } { "...quot" { $snippet "n" } " quotations on the datastack" } { "n" integer } }\r
+{ $values { "a" object } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } }\r
{ $description "Curries " { $snippet "a" } " onto the " { $snippet "n" } " quotations on the top of the datastack. A generalization of " { $link bi-curry } " and " { $link tri-curry } "." }\r
{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry bi" } ", " { $snippet "tri-curry tri" } ", " { $snippet "bi-curry bi*" } ", and " { $snippet "tri-curry tri*" } "." } ;\r
\r
HELP: spread-curry\r
-{ $values { "...a" { $snippet "n" } " objects on the datastack" } { "...quot" { $snippet "n" } " quotations on the datastack" } { "n" integer } }\r
+{ $values { "a..." { $snippet "n" } " objects on the datastack" } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } }\r
{ $description "Curries the " { $snippet "n" } " quotations on the top of the datastack with the " { $snippet "n" } " values just below them. A generalization of " { $link bi-curry* } " and " { $link tri-curry* } "." }\r
{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry* bi" } ", " { $snippet "tri-curry* tri" } ", " { $snippet "bi-curry* bi*" } ", and " { $snippet "tri-curry* tri*" } "." } ;\r
\r
: mnapply ( quot m n -- )
[ nip dupn ] [ nspread* ] 2bi ; inline
-: apply-curry ( ...a quot n -- )
+: apply-curry ( a... quot n -- )
[ [curry] ] dip napply ; inline
-: cleave-curry ( a ...quot n -- )
+: cleave-curry ( a quot... n -- )
[ [curry] ] swap [ napply ] [ cleave* ] bi ; inline
-: spread-curry ( ...a ...quot n -- )
+: spread-curry ( a... quot... n -- )
[ [curry] ] swap [ napply ] [ spread* ] bi ; inline
MACRO: mnswap ( m n -- )
IN: sequences.generalizations
HELP: neach
-{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- )" } } { "n" integer } }
+{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( element... -- )" } } { "n" integer } }
{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ;
HELP: nmap
-{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } }
+{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( element... -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } }
{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ;
HELP: nmap-as
-{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } }
+{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( element... -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } }
{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ;
HELP: mnmap
{ $description "A generalization of " { $link produce } " that generates " { $snippet "n" } " arrays in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
HELP: nproduce-as
-{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "...exemplar" { $snippet "n" } " sequences on the datastack" } { "n" integer } { "seq..." { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
+{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "exemplar..." { $snippet "n" } " sequences on the datastack" } { "n" integer } { "seq..." { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
{ $description "A generalization of " { $link produce-as } " that generates " { $snippet "n" } " sequences in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
ARTICLE: "sequences.generalizations" "Generalized sequence iteration combinators"
dup 1 - [ min ] n*quot
'[ [ length ] _ napply @ ] ;
-: nnth-unsafe ( n ...seq n -- )
+: nnth-unsafe ( n seq... n -- )
[ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
MACRO: nset-nth-unsafe ( n -- )
[ [ drop ] ]
[ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
if-zero ;
-: (neach) ( ...seq quot n -- len quot' )
+: (neach) ( seq... quot n -- len quot' )
dup dup dup
'[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
-: neach ( ...seq quot n -- )
+: neach ( seq... quot n -- )
(neach) each-integer ; inline
-: nmap-as ( ...seq quot exemplar n -- result )
+: nmap-as ( seq... quot exemplar n -- result )
'[ _ (neach) ] dip map-integers ; inline
-: nmap ( ...seq quot n -- result )
+: nmap ( seq... quot n -- result )
dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
MACRO: nnew-sequence ( n -- )
[ [ drop ] ]
[ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
-: nnew-like ( len ...exemplar quot n -- result... )
+: nnew-like ( len exemplar... quot n -- result... )
5 dupn '[
_ nover
[ [ _ nnew-sequence ] dip call ]
3 dupn 1 +
'[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ;
-: ncollect ( len quot ...into n -- )
+: ncollect ( len quot into... n -- )
(ncollect) each-integer ; inline
-: nmap-integers ( len quot ...exemplar n -- result... )
+: nmap-integers ( len quot exemplar... n -- result... )
4 dupn
'[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
: mnmap ( m*seq quot m n -- result*n )
2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
-: ncollector-for ( quot ...exemplar n -- quot' vec... )
+: ncollector-for ( quot exemplar... n -- quot' vec... )
5 dupn '[
[ [ length ] keep new-resizable ] _ napply
[ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep
: ncollector ( quot n -- quot' vec... )
[ V{ } swap dupn ] keep ncollector-for ; inline
-: nproduce-as ( pred quot ...exemplar n -- seq... )
+: nproduce-as ( pred quot exemplar... n -- seq... )
7 dupn '[
_ ndup
[ _ ncollector-for [ while ] _ ndip ]
V{ } clone \ literals set
H{ } clone known-values set
0 input-count set
+ 0 inner-d-index set
] unit-test
[ 0 ] [ 0 ensure-d length ] unit-test
USING: fry arrays generic io io.streams.string kernel math namespaces
parser sequences strings vectors words quotations effects classes
continuations assocs combinators compiler.errors accessors math.order
-definitions sets hints macros stack-checker.state
+definitions locals sets hints macros stack-checker.state
stack-checker.visitor stack-checker.errors stack-checker.values
stack-checker.recursive-state stack-checker.dependencies summary ;
+FROM: sequences.private => from-end ;
IN: stack-checker.backend
: push-d ( obj -- ) meta-d push ;
[ #introduce, ]
tri ;
+: update-inner-d ( new -- )
+ inner-d-index get min inner-d-index set ;
+
: pop-d ( -- obj )
- meta-d [ <value> dup 1array introduce-values ] [ pop ] if-empty ;
+ meta-d
+ [ <value> dup 1array introduce-values ]
+ [ pop meta-d length update-inner-d ] if-empty ;
: peek-d ( -- obj ) pop-d dup push-d ;
[ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
[ introduce-values ] [ meta-d push-all ] bi
meta-d push-all
- ] when swap tail* ;
+ ] when
+ swap from-end [ tail ] [ update-inner-d ] bi ;
: shorten-by ( n seq -- )
[ length swap - ] keep shorten ; inline
+: shorten-d ( n -- )
+ meta-d shorten-by meta-d length update-inner-d ;
+
: consume-d ( n -- seq )
- [ ensure-d ] [ meta-d shorten-by ] bi ;
+ [ ensure-d ] [ shorten-d ] bi ;
: output-d ( values -- ) meta-d push-all ;
current-effect
stack-visitor get
] with-scope ; inline
+
+: (infer) ( quot -- effect )
+ [ infer-quot-here ] with-infer drop ;
+
+: ?quotation-effect ( in -- effect/f )
+ dup pair? [ second dup effect? [ drop f ] unless ] [ drop f ] if ;
+
+:: declare-effect-d ( word effect variables branches n -- )
+ meta-d length :> d-length
+ n d-length < [
+ d-length 1 - n - :> n'
+ n' meta-d nth :> value
+ value known :> known
+ known word effect variables branches <declared-effect> :> known'
+ known' value set-known
+ known' branches push
+ ] [ word unknown-macro-input ] if ;
+
+:: declare-input-effects ( word -- )
+ H{ } clone :> variables
+ V{ } clone :> branches
+ word stack-effect in>> <reversed> [| in n |
+ in ?quotation-effect [| effect |
+ word effect variables branches n declare-effect-d
+ ] when*
+ ] each-index ;
+
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry vectors sequences assocs math math.order accessors kernel
-combinators quotations namespaces grouping stack-checker.state
+USING: arrays effects fry vectors sequences assocs math math.order accessors kernel
+combinators quotations namespaces grouping locals stack-checker.state
stack-checker.backend stack-checker.errors stack-checker.visitor
stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.branches
SYMBOL: quotations
+: simple-unbalanced-branches-error ( branches quots -- * )
+ [ \ if ] 2dip swap
+ [ length [ (( ..a -- ..b )) ] replicate ]
+ [ [ length [ "x" <array> ] bi@ <effect> ] { } assoc>map ] bi
+ unbalanced-branches-error ;
+
: unify-branches ( ins stacks -- in phi-in phi-out )
zip [ 0 { } { } ] [
[ keys supremum ] [ ] [ balanced? ] tri
[ dupd phi-inputs dup phi-outputs ]
- [ quotations get unbalanced-branches-error ]
+ [ quotations get simple-unbalanced-branches-error ]
if
] if-empty ;
branch-variable ;
: datastack-phi ( seq -- phi-in phi-out )
- [ input-count branch-variable ] [ \ meta-d active-variable ] bi
+ [ input-count branch-variable ]
+ [ inner-d-index branch-variable infimum inner-d-index set ]
+ [ \ meta-d active-variable ] tri
unify-branches
[ input-count set ] [ ] [ dup >vector \ meta-d set ] tri* ;
: copy-inference ( -- )
\ meta-d [ clone ] change
literals [ clone ] change
- input-count [ ] change ;
+ input-count [ ] change
+ inner-d-index [ ] change ;
GENERIC: infer-branch ( literal -- namespace )
[ value>> quotation set ] [ infer-literal-quot ] bi
] H{ } make-assoc ;
+M: declared-effect infer-branch
+ known>> infer-branch ;
+
M: callable infer-branch
[
copy-inference
infer-branches
[ first2 #if, ] dip compute-phi-function ;
+GENERIC: curried/composed? ( known -- ? )
+M: object curried/composed? drop f ;
+M: curried curried/composed? drop t ;
+M: composed curried/composed? drop t ;
+M: declared-effect curried/composed? known>> curried/composed? ;
+
+:: declare-if-effects ( -- )
+ H{ } clone :> variables
+ V{ } clone :> branches
+ \ if (( ..a -- ..b )) variables branches 0 declare-effect-d
+ \ if (( ..a -- ..b )) variables branches 1 declare-effect-d ;
+
: infer-if ( -- )
2 literals-available? [
(infer-if)
] [
- drop 2 consume-d
- dup [ known [ curried? ] [ composed? ] bi or ] any? [
+ drop 2 ensure-d
+ declare-if-effects
+ 2 shorten-d
+ dup [ known curried/composed? ] any? [
output-d
[ rot [ drop call ] [ nip call ] if ]
infer-quot-here
ERROR: unknown-macro-input < inference-error macro ;
-ERROR: unbalanced-branches-error < inference-error branches quots ;
-
ERROR: too-many->r < inference-error ;
ERROR: too-many-r> < inference-error ;
ERROR: transform-expansion-error < inference-error error continuation word ;
-ERROR: bad-declaration-error < inference-error declaration ;
\ No newline at end of file
+ERROR: bad-declaration-error < inference-error declaration ;
+
+ERROR: unbalanced-branches-error < inference-error word quots declareds actuals ;
+
M: bad-macro-input summary
macro>> name>> "Cannot apply “" "” to a run-time computed value" surround ;
-M: unbalanced-branches-error summary
- drop "Unbalanced branches" ;
-
-M: unbalanced-branches-error error.
- dup summary print
- [ quots>> ] [ branches>> [ length [ "x" <array> ] bi@ <effect> ] { } assoc>map ] bi zip
- [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
-
M: too-many->r summary
drop "Quotation pushes elements on retain stack without popping them" ;
tri ;
M: do-not-compile summary
- word>> name>> "Cannot compile call to " prepend ;
\ No newline at end of file
+ word>> name>> "Cannot compile call to " prepend ;
+
+M: unbalanced-branches-error summary
+ word>> name>>
+ "The input quotations to " " don't match their expected effects" surround ;
+
+M: unbalanced-branches-error error.
+ dup summary print
+ [ quots>> ] [ declareds>> ] [ actuals>> ] tri 3array flip
+ { "Input" "Expected" "Got" } prefix simple-table. ;
+
stack-checker.branches
stack-checker.known-words
stack-checker.dependencies
+stack-checker.row-polymorphism
stack-checker.recursive-state ;
IN: stack-checker.inlining
: trimmed-enter-out ( label -- stack )
dup enter-out>> trim-stack ;
+GENERIC: (undeclared-known) ( value -- known )
+M: object (undeclared-known) ;
+M: declared-effect (undeclared-known) known>> (undeclared-known) ;
+
+: undeclared-known ( value -- known ) known (undeclared-known) ;
+
: check-call-site-stack ( label -- )
[ ] [ call-site-stack ] [ trimmed-enter-out ] tri
- [ dup known [ [ known ] bi@ = ] [ 2drop t ] if ] 2all?
+ [ dup undeclared-known [ [ undeclared-known ] bi@ = ] [ 2drop t ] if ] 2all?
[ drop ] [ word>> inconsistent-recursive-call-error inference-error ] if ;
: check-call ( label -- )
: inline-word ( word -- )
commit-literals
[ depends-on-definition ]
+ [ declare-input-effects ]
[
dup inline-recursive-label [
call-recursive-inline-word
[ dup infer-inline-word-def ]
if
] if*
- ] bi ;
+ ] tri ;
M: word apply-object
dup inline? [ inline-word ] [ non-inline-word ] if ;
stack-checker.branches
stack-checker.transforms
stack-checker.dependencies
-stack-checker.recursive-state ;
+stack-checker.recursive-state
+stack-checker.row-polymorphism ;
IN: stack-checker.known-words
: infer-primitive ( word -- )
1 infer->r infer-call
terminated? get [ 1 infer-r> infer-call ] unless ;
+M: declared-effect infer-call*
+ [ [ known>> infer-call* ] keep ] with-effect-here check-declared-effect ;
+
M: input-parameter infer-call* \ call unknown-macro-input ;
M: object infer-call* \ call bad-macro-input ;
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: accessors arrays assocs combinators combinators.short-circuit
+continuations effects fry kernel locals math math.order namespaces
+quotations sequences splitting
+stack-checker.backend
+stack-checker.errors
+stack-checker.known-words
+stack-checker.state
+stack-checker.values
+stack-checker.visitor ;
+IN: stack-checker.row-polymorphism
+
+:: with-effect-here ( quot -- effect )
+ inner-d-index get :> old-inner-d-index
+ input-count get :> old-input-count
+ meta-d length :> old-meta-d-length
+
+ old-meta-d-length inner-d-index set
+ quot call
+
+ inner-d-index get :> new-inner-d-index
+ input-count get :> new-input-count
+
+ old-meta-d-length new-inner-d-index -
+ new-input-count old-input-count - + :> in
+
+ meta-d length new-inner-d-index - :> out
+
+ new-inner-d-index old-inner-d-index min inner-d-index set
+
+ in "x" <array> out "x" <array> terminated? get <terminated-effect> ; inline
+
+:: check-variable ( actual-count declared-count variable vars -- difference )
+ actual-count declared-count -
+ variable [
+ variable vars at* nip
+ [ variable vars at - ]
+ [ variable vars set-at 0 ] if
+ ] [ drop 0 ] if ;
+
+: adjust-variable ( diff var vars -- )
+ pick 0 >=
+ [ at+ ]
+ [ 3drop ] if ; inline
+
+:: check-variables ( vars declared actual -- ? )
+ actual terminated?>> [ t ] [
+ actual declared [ in>> length ] bi@ declared in-var>>
+ [ vars check-variable ] keep :> ( in-diff in-var )
+ actual declared [ out>> length ] bi@ declared out-var>>
+ [ vars check-variable ] keep :> ( out-diff out-var )
+ { [ in-var not ] [ out-var not ] [ in-diff out-diff = ] } 0||
+ dup [
+ in-var [ in-diff swap vars adjust-variable ] when*
+ out-var [ out-diff swap vars adjust-variable ] when*
+ ] when
+ ] if ;
+
+: complex-unbalanced-branches-error ( known -- * )
+ [ word>> ] [
+ branches>> <reversed>
+ [ [ known>callable ] { } map-as ]
+ [ [ effect>> ] { } map-as ]
+ [ [ actual>> ] { } map-as ] tri
+ ] bi unbalanced-branches-error ;
+
+: check-declared-effect ( known effect -- )
+ [ >>actual ] keep
+ 2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables
+ [ 2drop ] [ drop complex-unbalanced-branches-error ] if ;
+
{ "If the word is declared " { $link POSTPONE: inline } ", the combinator may additionally be called on one of the word's input parameters or with quotations built from the word's input parameters, literal quotations, " { $link curry } ", and " { $link compose } ". When inline, a word is itself considered to be a combinator, and its callers must in turn satisfy these conditions." }
}
"If neither condition holds, the stack checker throws a " { $link unknown-macro-input } " or " { $link bad-macro-input } " error. To make the code compile, a runtime checking combinator such as " { $link POSTPONE: call( } " must be used instead. See " { $link "inference-escape" } " for details. An inline combinator can be called with an unknown quotation by " { $link curry } "ing the quotation onto a literal quotation that uses " { $link POSTPONE: call( } "."
+{ $heading "Input stack effects" }
+"Inline combinators will verify the stack effect of their input quotations if they are declared in the combinator's stack effect. See " { $link "effects-variables" } " for details."
{ $heading "Examples" }
{ $subheading "Calling a combinator" }
"The following usage of " { $link map } " passes the stack checker, because the quotation is the result of " { $link curry } ":"
! Test some curry stuff
{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as
+{ 3 1 } [ [ ] curry [ [ ] curry ] dip if ] must-infer-as
{ 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ ] curry [ [ ] 2curry ] dip if ] infer ] [ unbalanced-branches-error? ] must-fail-with
{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
[ [ cond ] infer ] [ T{ unknown-macro-input f cond } = ] must-fail-with
[ [ bi ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
-[ [ each ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
+
+[ [ each ] infer ] [ T{ unknown-macro-input f each } = ] must-fail-with
+[ [ if* ] infer ] [ T{ unknown-macro-input f if* } = ] must-fail-with
+[ [ [ "derp" ] if* ] infer ] [ T{ unknown-macro-input f if* } = ] must-fail-with
[ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer
[ "special" word-prop not ] filter
[ "shuffle" word-prop not ] filter
] unit-test
+
+{ 1 0 } [ [ drop ] each ] must-infer-as
+{ 2 1 } [ [ append ] each ] must-infer-as
+{ 1 1 } [ [ ] map ] must-infer-as
+{ 1 1 } [ [ reverse ] map ] must-infer-as
+{ 2 2 } [ [ append dup ] map ] must-infer-as
+{ 2 2 } [ [ swap nth suffix dup ] map-index ] must-infer-as
+
+{ 4 1 } [ [ 2drop ] [ 2nip ] if ] must-infer-as
+{ 3 3 } [ [ dup ] [ over ] if ] must-infer-as
+{ 1 1 } [ [ 1 ] [ 0 ] if ] must-infer-as
+{ 2 2 } [ [ t ] [ 1 + f ] if ] must-infer-as
+
+{ 1 0 } [ [ write ] [ "(f)" write ] if* ] must-infer-as
+{ 1 1 } [ [ ] [ f ] if* ] must-infer-as
+{ 2 1 } [ [ nip ] [ drop f ] if* ] must-infer-as
+{ 2 1 } [ [ nip ] [ ] if* ] must-infer-as
+{ 3 2 } [ [ 3append f ] [ ] if* ] must-infer-as
+{ 1 0 } [ [ drop ] [ ] if* ] must-infer-as
+
+{ 1 1 } [ [ 1 + ] [ "oops" throw ] if* ] must-infer-as
+
+! ensure that polymorphic checking works on recursive combinators
+FROM: splitting.private => split, ;
+{ 2 0 } [ [ member? ] curry split, ] must-infer-as
+
+[ [ [ write write ] each ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+[ [ [ ] each ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ dup ] map ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ drop ] map ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ 1 + ] map-index ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+[ [ [ dup ] [ ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ 2dup ] [ over ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ drop ] [ ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+[ [ [ ] [ ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ dup ] [ ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ drop ] [ drop ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ ] [ drop ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ ] [ 2dup ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+! M\ declared-effect infer-call* didn't properly unify branches
+{ 1 0 } [ [ 1 [ drop ] [ drop ] if ] each ] must-infer-as
+
GENERIC: infer ( quot -- effect )
M: callable infer ( quot -- effect )
- [ infer-quot-here ] with-infer drop ;
+ (infer) ;
: infer. ( quot -- )
#! Safe to call from inference transforms.
! Number of inputs current word expects from the stack
SYMBOL: input-count
+SYMBOL: inner-d-index
DEFER: commit-literals
: current-effect ( -- effect )
input-count get "x" <array>
meta-d length "x" <array>
- terminated? get effect boa ;
+ terminated? get <terminated-effect> ;
: init-inference ( -- )
terminated? off
V{ } clone \ meta-d set
V{ } clone literals set
- 0 input-count set ;
+ 0 input-count set
+ 0 inner-d-index set ;
:: ((apply-transform)) ( quot values stack rstate -- )
rstate recursive-state [ stack quot call-transformer ] with-variable
- values [ length meta-d shorten-by ] [ #drop, ] bi
+ values [ length shorten-d ] [ #drop, ] bi
rstate infer-quot ;
: literal-values? ( values -- ? ) [ literal-value? ] all? ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel assocs sequences
-stack-checker.recursive-state stack-checker.errors ;
+USING: accessors namespaces fry kernel assocs sequences
+stack-checker.recursive-state stack-checker.errors
+quotations ;
IN: stack-checker.values
! Values
M: input-parameter (literal) current-word get unknown-macro-input ;
+! Argument corresponding to polymorphic declared input of inline combinator
+
+TUPLE: declared-effect known word effect variables branches actual ;
+
+C: (declared-effect) declared-effect
+
+: <declared-effect> ( known word effect variables branches -- declared-effect )
+ f (declared-effect) ; inline
+
+M: declared-effect (input-value?) known>> (input-value?) ;
+
+M: declared-effect (literal-value?) known>> (literal-value?) ;
+
+M: declared-effect (literal) known>> (literal) ;
+
! Computed values
M: f (input-value?) drop f ;
M: f (literal-value?) drop f ;
-M: f (literal) current-word get bad-macro-input ;
\ No newline at end of file
+M: f (literal) current-word get bad-macro-input ;
+
+GENERIC: known>callable ( known -- quot )
+
+: ?@ ( x -- y )
+ dup callable? [ drop [ @ ] ] unless ;
+
+M: object known>callable drop \ _ ;
+M: literal known>callable value>> ;
+M: composed known>callable
+ [ quot1>> known known>callable ?@ ] [ quot2>> known known>callable ?@ ] bi
+ append ;
+M: curried known>callable
+ [ quot>> known known>callable ] [ obj>> known known>callable ] bi
+ prefix ;
+M: declared-effect known>callable
+ known>> known>callable ;
+
-USING: help.markup help.syntax math strings words kernel combinators ;
+USING: help.markup help.syntax math strings words kernel combinators sequences ;
IN: effects
ARTICLE: "effects" "Stack effect declarations"
{ $code "( input1 input2 ... -- output1 ... )" }
"Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Here is an example:"
{ $synopsis + }
-"Parameters which are quotations can be declared by suffixing the parameter name with " { $snippet ":" } " and then writing a nested stack effect declaration:"
+"Parameters which are quotations can be declared by suffixing the parameter name with " { $snippet ":" } " and then writing a nested stack effect declaration. If the number of inputs or outputs depends on the stack effects of quotation parameters, " { $link "effects-variables" } " can be used to declare this:"
{ $synopsis while }
-"Only the number of inputs and outputs carries semantic meaning."
-$nl
-"Nested quotation declaration only has semantic meaning for " { $link POSTPONE: inline } " " { $link POSTPONE: recursive } " words. See " { $link "inference-recursive-combinators" } "."
+"For words that are not " { $link POSTPONE: inline } ", only the number of inputs and outputs carries semantic meaning, and effect variables are ignored. However, nested quotation declarations are enforced for inline words. Nested quotation declarations are optional for non-recursive inline combinators and only provide better error messages. However, quotation inputs to " { $link POSTPONE: recursive } " combinators must have an effect declared. See " { $link "inference-recursive-combinators" } "."
$nl
"In concatenative code, input and output names are for documentation purposes only and certain conventions have been established to make them more descriptive. For code written with " { $link "locals" } ", stack values are bound to local variables named by the stack effect's input parameters."
$nl
{ { $snippet "loc" } "a screen location specified as a two-element array holding x and y co-ordinates" }
{ { $snippet "dim" } "a screen dimension specified as a two-element array holding width and height values" }
{ { $snippet "*" } "when this symbol appears by itself in the list of outputs, it means the word unconditionally throws an error" }
+ { { $snippet ".." } { "indicates " { $link "effects-variables" } ". only valid as the first input or first output" } }
}
{ $see-also "inference" } ;
+ARTICLE: "effects-variables" "Stack effect variables"
+{ $link POSTPONE: inline } " combinators can have variable stack effects, depending on the effect of the quotation they call. For example, while " { $link each } " inputs elements of its sequence to its quotation, the quotation can also manipulate values on the stack below the element, as long as it leaves the same number of elements on the stack. This ability is used to implement " { $link reduce } " in terms of " { $snippet "each" } ". This variable stack effect is indicated by starting the list of inputs and outputs with a name starting with " { $snippet ".." } ":"
+{ $synopsis each }
+"In combinators with multiple quotation inputs, the number of inputs or outputs represented by a particular " { $snippet ".." } " name must match. For example, the predicate for a " { $link while } " loop can take an arbitrary number of inputs and leave an arbitrary number of outputs on the stack in addition to the predicate result; however, for the loop to leave the stack balanced, the body of the while loop must consume all of the predicate's outputs and leave a number of its own outputs equal to the initial number of stack values before the predicate was called. This is expressed with the following stack effect:"
+{ $synopsis while }
+"Stack effect variables can only occur as the first input or first output of a stack effect; names starting in " { $snippet ".." } " cause a syntax error if they occur elsewhere in the effect. For words that are not " { $link POSTPONE: inline } ", effect variables are currently ignored by the stack checker." ;
+
ABOUT: "effects"
HELP: effect
-USING: effects kernel tools.test prettyprint accessors
+USING: effects effects.parser eval kernel tools.test prettyprint accessors
quotations sequences ;
IN: effects.tests
[ { object object } ] [ (( a b -- )) effect-in-types ] unit-test
[ { object sequence } ] [ (( a b: sequence -- )) effect-in-types ] unit-test
+
+[ f ] [ (( a b c -- d )) in-var>> ] unit-test
+[ f ] [ (( -- d )) in-var>> ] unit-test
+[ "a" ] [ (( ..a b c -- d )) in-var>> ] unit-test
+[ { "b" "c" } ] [ (( ..a b c -- d )) in>> ] unit-test
+
+[ f ] [ (( ..a b c -- e )) out-var>> ] unit-test
+[ "d" ] [ (( ..a b c -- ..d e )) out-var>> ] unit-test
+[ { "e" } ] [ (( ..a b c -- ..d e )) out>> ] unit-test
+
+[ "(( a ..b c -- d ))" eval( -- effect ) ]
+[ error>> invalid-effect-variable? ] must-fail-with
+
+[ "(( ..a: integer b c -- d ))" eval( -- effect ) ]
+[ error>> effect-variable-can't-have-type? ] must-fail-with
TUPLE: effect
{ in array read-only }
{ out array read-only }
-{ terminated? read-only } ;
+{ terminated? read-only }
+{ in-var read-only }
+{ out-var read-only } ;
+
+: ?terminated ( out -- out terminated? )
+ dup { "*" } = [ drop { } t ] [ f ] if ;
: <effect> ( in out -- effect )
- dup { "*" } = [ drop { } t ] [ f ] if
- effect boa ;
+ ?terminated f f effect boa ;
+
+: <terminated-effect> ( in out terminated? -- effect )
+ f f effect boa ; inline
+
+: <variable-effect> ( in-var in out-var out -- effect )
+ swap [ rot ] dip [ ?terminated ] 2dip effect boa ;
: effect-height ( effect -- n )
[ out>> length ] [ in>> length ] bi - ; inline
: stack-picture ( seq -- string )
[ [ effect>string % CHAR: \s , ] each ] "" make ;
+: var-picture ( var -- string )
+ [ ".." " " surround ]
+ [ "" ] if* ;
+
M: effect effect>string ( effect -- string )
[
"( " %
- [ in>> stack-picture % "-- " % ]
- [ out>> stack-picture % ]
- [ terminated?>> [ "* " % ] when ]
- tri
+ dup in-var>> var-picture %
+ dup in>> stack-picture % "-- " %
+ dup out-var>> var-picture %
+ dup out>> stack-picture %
+ dup terminated?>> [ "* " % ] when
+ drop
")" %
] "" make ;
shuffle-mapping swap nths ;
: add-effect-input ( effect -- effect' )
- [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri effect boa ;
+ [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri <terminated-effect> ;
: compose-effects ( effect1 effect2 -- effect' )
over terminated?>> [
[ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
[ nip terminated?>> ] 2tri
[ [ "x" <array> ] bi@ ] dip
- effect boa
+ <terminated-effect>
] if ; inline
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: lexer sets sequences kernel splitting effects
-combinators arrays vocabs.parser classes parser ;
+combinators arrays make vocabs.parser classes parser ;
IN: effects.parser
DEFER: parse-effect
ERROR: bad-effect ;
-
-: parse-effect-token ( end -- token/f )
- scan [ nip ] [ = ] 2bi [ drop f ] [
- dup { f "(" "((" } member? [ bad-effect ] [
- ":" ?tail [
- scan {
- { [ dup "(" = ] [ drop ")" parse-effect ] }
- { [ dup f = ] [ ")" unexpected-eof ] }
- [ parse-word dup class? [ bad-effect ] unless ]
- } cond 2array
- ] when
+ERROR: invalid-effect-variable ;
+ERROR: effect-variable-can't-have-type ;
+ERROR: stack-effect-omits-dashes ;
+
+SYMBOL: effect-var
+
+: parse-var ( first? var name -- var )
+ nip
+ [ ":" ?tail [ effect-variable-can't-have-type ] when ] curry
+ [ invalid-effect-variable ] if ;
+
+: parse-effect-token ( first? var end -- var more? )
+ scan [ nip ] [ = ] 2bi [ drop nip f ] [
+ dup { f "(" "((" "--" } member? [ bad-effect ] [
+ dup { ")" "))" } member? [ stack-effect-omits-dashes ] [
+ ".." ?head [ parse-var t ] [
+ [ drop ] 2dip
+ ":" ?tail [
+ scan {
+ { [ dup "(" = ] [ drop ")" parse-effect ] }
+ { [ dup f = ] [ ")" unexpected-eof ] }
+ [ parse-word dup class? [ bad-effect ] unless ]
+ } cond 2array
+ ] when , t
+ ] if
+ ] if
] if
] if ;
-: parse-effect-tokens ( end -- tokens )
- [ parse-effect-token dup ] curry [ ] produce nip ;
-
-ERROR: stack-effect-omits-dashes tokens ;
+: parse-effect-tokens ( end -- var tokens )
+ [
+ [ t f ] dip [ parse-effect-token [ f ] 2dip ] curry [ ] while nip
+ ] { } make ;
: parse-effect ( end -- effect )
- parse-effect-tokens { "--" } split1 dup
- [ <effect> ] [ drop stack-effect-omits-dashes ] if ;
+ [ "--" parse-effect-tokens ] dip parse-effect-tokens
+ <variable-effect> ;
: complete-effect ( -- effect )
"(" expect ")" parse-effect ;
#! two literal quotations.
rot [ drop ] [ nip ] if ; inline
-: if ( ? true false -- ) ? call ;
+: if ( ..a ? true: ( ..a -- ..b ) false: ( ..a -- ..b ) -- ..b ) ? call ;
! Single branch
: unless ( ? false -- )
swap [ call ] [ drop ] if ; inline
! Anaphoric
-: if* ( ? true false -- )
+: if* ( ..a ? true: ( ..a ? -- ..b ) false: ( ..a -- ..b ) -- ..b )
pick [ drop call ] [ 2nip call ] if ; inline
: when* ( ? true -- )
over [ drop ] [ nip call ] if ; inline
! Default
-: ?if ( default cond true false -- )
+: ?if ( ..a default cond true: ( ..a cond -- ..b ) false: ( ..a default -- ..b ) -- ..b )
pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline
! Dippers.
: most ( x y quot -- z ) 2keep ? ; inline
! Loops
-: loop ( pred: ( -- ? ) -- )
+: loop ( ... pred: ( ... -- ... ? ) -- ... )
[ call ] keep [ loop ] curry when ; inline recursive
: do ( pred body -- pred body )
dup 2dip ; inline
-: while ( pred: ( -- ? ) body: ( -- ) -- )
+: while ( ..a pred: ( ..a -- ..b ? ) body: ( ..b -- ..a ) -- ..b )
swap do compose [ loop ] curry when ; inline
-: until ( pred: ( -- ? ) body: ( -- ) -- )
+: until ( ..a pred: ( ..a -- ..b ? ) body: ( ..b -- ..a ) -- ..b )
[ [ not ] compose ] dip while ; inline
! Object protocol
: even? ( n -- ? ) 1 bitand zero? ;
: odd? ( n -- ? ) 1 bitand 1 number= ;
-: if-zero ( n quot1 quot2 -- )
+: if-zero ( ..a n quot1: ( ..a -- ..b ) quot2: ( ..a n -- ..b ) -- ..b )
[ dup zero? ] [ [ drop ] prepose ] [ ] tri* if ; inline
: when-zero ( n quot -- ) [ ] if-zero ; inline
PRIVATE>
-: (each-integer) ( i n quot: ( i -- ) -- )
+: (each-integer) ( ... i n quot: ( ... i -- ... ) -- ... )
[ iterate-step iterate-next (each-integer) ]
[ 3drop ] if-iterate? ; inline recursive
-: (find-integer) ( i n quot: ( i -- ? ) -- i )
+: (find-integer) ( ... i n quot: ( ... i -- ... ? ) -- ... i )
[
iterate-step
[ [ ] ] 2dip
[ iterate-next (find-integer) ] 2curry bi-curry if
] [ 3drop f ] if-iterate? ; inline recursive
-: (all-integers?) ( i n quot: ( i -- ? ) -- ? )
+: (all-integers?) ( ... i n quot: ( ... i -- ... ? ) -- ... ? )
[
iterate-step
[ iterate-next (all-integers?) ] 3curry
: all-integers? ( n quot -- ? )
iterate-prep (all-integers?) ; inline
-: find-last-integer ( n quot: ( i -- ? ) -- i )
+: find-last-integer ( ... n quot: ( ... i -- ... ? ) -- ... i )
over 0 < [
2drop f
] [
: empty? ( seq -- ? ) length 0 = ; inline
-: if-empty ( seq quot1 quot2 -- )
+: if-empty ( ..a seq quot1: ( ..a -- ..b ) quot2: ( ..a seq -- ..b ) -- ..b )
[ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
: when-empty ( seq quot -- ) [ ] if-empty ; inline
PRIVATE>
-: each ( seq quot -- )
+: each ( ... seq quot: ( ... x -- ... ) -- ... )
(each) each-integer ; inline
-: reduce ( seq identity quot -- result )
+: reduce ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... result )
swapd each ; inline
: map-integers ( len quot exemplar -- newseq )
[ over ] dip [ [ collect ] keep ] new-like ; inline
-: map-as ( seq quot exemplar -- newseq )
+: map-as ( ... seq quot: ( ... x -- ... newx ) exemplar -- ... newseq )
[ (each) ] dip map-integers ; inline
-: map ( seq quot -- newseq )
+: map ( ... seq quot: ( ... x -- ... newx ) -- ... newseq )
over map-as ; inline
-: replicate-as ( len quot exemplar -- newseq )
+: replicate-as ( ... len quot: ( ... -- ... newx ) exemplar -- ... newseq )
[ [ drop ] prepose ] dip map-integers ; inline
-: replicate ( len quot -- newseq )
+: replicate ( ... len quot: ( ... -- ... newx ) -- ... newseq )
{ } replicate-as ; inline
-: map! ( seq quot -- seq )
+: map! ( ... seq quot: ( ... x -- ... x' ) -- ... seq )
over [ map-into ] keep ; inline
-: accumulate-as ( seq identity quot exemplar -- final newseq )
+: accumulate-as ( ... seq identity quot: ( ... prev elt -- ... next ) exemplar -- ... final newseq )
[ (accumulate) ] dip map-as ; inline
-: accumulate ( seq identity quot -- final newseq )
+: accumulate ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... final newseq )
{ } accumulate-as ; inline
-: accumulate! ( seq identity quot -- final seq )
+: accumulate! ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... final seq )
(accumulate) map! ; inline
-: 2each ( seq1 seq2 quot -- )
+: 2each ( ... seq1 seq2 quot: ( ... x1 x2 -- ... ) -- ... )
(2each) each-integer ; inline
-: 2reverse-each ( seq1 seq2 quot -- )
+: 2reverse-each ( ... seq1 seq2 quot: ( ... x1 x2 -- ... ) -- ... )
[ [ <reversed> ] bi@ ] dip 2each ; inline
-: 2reduce ( seq1 seq2 identity quot -- result )
+: 2reduce ( ... seq1 seq2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result )
[ -rot ] dip 2each ; inline
-: 2map-as ( seq1 seq2 quot exemplar -- newseq )
+: 2map-as ( ... seq1 seq2 quot: ( ... x1 x2 -- ... newx ) exemplar -- ... newseq )
[ (2each) ] dip map-integers ; inline
-: 2map ( seq1 seq2 quot -- newseq )
+: 2map ( ... seq1 seq2 quot: ( ... x1 x2 -- ... newx ) -- ... newseq )
pick 2map-as ; inline
-: 2all? ( seq1 seq2 quot -- ? )
+: 2all? ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... ? )
(2each) all-integers? ; inline
-: 3each ( seq1 seq2 seq3 quot -- )
+: 3each ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... ) -- ... )
(3each) each-integer ; inline
-: 3map-as ( seq1 seq2 seq3 quot exemplar -- newseq )
+: 3map-as ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... newx ) exemplar -- ... newseq )
[ (3each) ] dip map-integers ; inline
-: 3map ( seq1 seq2 seq3 quot -- newseq )
+: 3map ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... newx ) -- ... newseq )
[ pick ] dip swap 3map-as ; inline
-: find-from ( n seq quot -- i elt )
+: find-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ (find-integer) ] (find-from) ; inline
-: find ( seq quot -- i elt )
+: find ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ find-integer ] (find) ; inline
-: find-last-from ( n seq quot -- i elt )
+: find-last-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ nip find-last-integer ] (find-from) ; inline
-: find-last ( seq quot -- i elt )
+: find-last ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ [ 1 - ] dip find-last-integer ] (find) ; inline
-: all? ( seq quot -- ? )
+: all? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
(each) all-integers? ; inline
-: push-if ( elt quot accum -- )
+: push-if ( ..a elt quot: ( ..a elt -- ..b ? ) accum -- ..b )
[ keep ] dip rot [ push ] [ 2drop ] if ; inline
: selector-for ( quot exemplar -- selector accum )
: selector ( quot -- selector accum )
V{ } selector-for ; inline
-: filter-as ( seq quot exemplar -- subseq )
+: filter-as ( ... seq quot: ( ... elt -- ... ? ) exemplar -- ... subseq )
dup [ selector-for [ each ] dip ] curry dip like ; inline
-: filter ( seq quot -- subseq )
+: filter ( ... seq quot: ( ... elt -- ... ? ) -- ... subseq )
over filter-as ; inline
-: push-either ( elt quot accum1 accum2 -- )
+: push-either ( ..a elt quot: ( ..a elt -- ..b ? ) accum1 accum2 -- ..b )
[ keep swap ] 2dip ? push ; inline
: 2selector ( quot -- selector accum1 accum2 )
V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
-: partition ( seq quot -- trueseq falseseq )
+: partition ( ... seq quot: ( ... elt -- ... ? ) -- ... trueseq falseseq )
over [ 2selector [ each ] 2dip ] dip [ like ] curry bi@ ; inline
: collector-for ( quot exemplar -- quot' vec )
: collector ( quot -- quot' vec )
V{ } collector-for ; inline
-: produce-as ( pred quot exemplar -- seq )
+: produce-as ( ..a pred: ( ..a -- ..b ? ) quot: ( ..b -- ..a obj ) exemplar -- ..b seq )
dup [ collector-for [ while ] dip ] curry dip like ; inline
-: produce ( pred quot -- seq )
+: produce ( ..a pred: ( ..a -- ..b ? ) quot: ( ..b -- ..a obj ) -- ..b seq )
{ } produce-as ; inline
-: follow ( obj quot -- seq )
+: follow ( ... obj quot: ( ... prev -- ... result/f ) -- ... seq )
[ dup ] swap [ keep ] curry produce nip ; inline
-: each-index ( seq quot -- )
+: each-index ( ... seq quot: ( ... x i -- ... ) -- ... )
(each-index) each-integer ; inline
: interleave ( seq between quot -- )
3bi
] if ; inline
-: map-index ( seq quot -- newseq )
+: map-index ( ... seq quot: ( ... x i -- ... newx ) -- ... newseq )
[ dup length iota ] dip 2map ; inline
-: reduce-index ( seq identity quot -- )
+: reduce-index ( ... seq identity quot: ( ... prev x i -- ... next ) -- ... result )
swapd each-index ; inline
: index ( obj seq -- n )
: nths ( indices seq -- seq' )
[ nth ] curry map ;
-: any? ( seq quot -- ? )
+: any? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
find drop >boolean ; inline
: member? ( elt seq -- ? )
<PRIVATE
-: (filter!) ( quot: ( elt -- ? ) store scan seq -- )
+: (filter!) ( ... quot: ( ... elt -- ... ? ) store scan seq -- ... )
2dup length < [
[ move ] 3keep
[ nth-unsafe pick call [ 1 + ] when ] 2keep
PRIVATE>
-: filter! ( seq quot -- seq )
+: filter! ( ... seq quot: ( ... elt -- ... ? ) -- ... seq )
swap [ [ 0 0 ] dip (filter!) ] keep ; inline
: remove! ( elt seq -- seq )
] keep like
] if ;
-: padding ( seq n elt quot -- newseq )
+: padding ( ... seq n elt quot: ( ... seq1 seq2 -- ... newseq ) -- ... newseq )
[
[ over length [-] dup 0 = [ drop ] ] dip
[ <repetition> ] curry
: halves ( seq -- first-slice second-slice )
dup midpoint@ cut-slice ;
-: binary-reduce ( seq start quot: ( elt1 elt2 -- newelt ) -- value )
+: binary-reduce ( ... seq start quot: ( ... elt1 elt2 -- ... newelt ) -- ... value )
#! We can't use case here since combinators depends on
#! sequences
pick length dup 0 3 between? [
: 2unclip-slice ( seq1 seq2 -- rest-slice1 rest-slice2 first1 first2 )
[ unclip-slice ] bi@ swapd ; inline
-: map-reduce ( seq map-quot reduce-quot -- result )
+: map-reduce ( ..a seq map-quot: ( ..a x -- ..b elt ) reduce-quot: ( ..b prev elt -- ..a next ) -- ..a result )
[ [ unclip-slice ] dip [ call ] keep ] dip
compose reduce ; inline
-: 2map-reduce ( seq1 seq2 map-quot reduce-quot -- result )
+: 2map-reduce ( ..a seq1 seq2 map-quot: ( ..a x1 x2 -- ..b elt ) reduce-quot: ( ..b prev elt -- ..a next ) -- ..a result )
[ [ prepare-2map-reduce ] keep ] dip
compose compose each-integer ; inline
PRIVATE>
-: map-find ( seq quot -- result elt )
+: map-find ( ... seq quot: ( ... elt -- ... ? ) -- ... result elt )
[ find ] (map-find) ; inline
-: map-find-last ( seq quot -- result elt )
+: map-find-last ( ... seq quot: ( ... elt -- ... ? ) -- ... result elt )
[ find-last ] (map-find) ; inline
: unclip-last-slice ( seq -- butlast-slice last )
PRIVATE>
-: trim-head-slice ( seq quot -- slice )
+: trim-head-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
(trim-head) tail-slice ; inline
-: trim-head ( seq quot -- newseq )
+: trim-head ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
(trim-head) tail ; inline
-: trim-tail-slice ( seq quot -- slice )
+: trim-tail-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
(trim-tail) head-slice ; inline
-: trim-tail ( seq quot -- newseq )
+: trim-tail ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
(trim-tail) head ; inline
-: trim-slice ( seq quot -- slice )
+: trim-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
[ trim-head-slice ] [ trim-tail-slice ] bi ; inline
-: trim ( seq quot -- newseq )
+: trim ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
[ trim-slice ] [ drop ] 2bi like ; inline
GENERIC: sum ( seq -- n )
: supremum ( seq -- n ) [ ] [ max ] map-reduce ;
-: map-sum ( seq quot -- n )
+: map-sum ( ... seq quot: ( ... elt -- ... n ) -- ... n )
[ 0 ] 2dip [ dip + ] curry [ swap ] prepose each ; inline
-: count ( seq quot -- n ) [ 1 0 ? ] compose map-sum ; inline
+: count ( ... seq quot: ( ... elt -- ... ? ) -- ... n ) [ 1 0 ? ] compose map-sum ; inline
-: cartesian-each ( seq1 seq2 quot -- )
+: cartesian-each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
[ with each ] 2curry each ; inline
-: cartesian-map ( seq1 seq2 quot -- newseq )
+: cartesian-map ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) -- ... newseq )
[ with map ] 2curry map ; inline
: cartesian-product ( seq1 seq2 -- newseq )
[ drop [ swap [ tail ] unless-zero , ] 2curry ]
3tri if* ; inline recursive
-: split, ( seq quot -- ) [ 0 ] 2dip (split) ; inline
+: split, ( ... seq quot: ( ... elt -- ... ? ) -- ... ) [ 0 ] 2dip (split) ; inline
PRIVATE>
PRIVATE>
-: fuel-use-suggested-vocabs ( suggestions quot -- ... )
+: fuel-use-suggested-vocabs ( ..a suggestions quot: ( ..a -- ..b ) -- ..b )
[ :uses-suggestions set ] dip
[ try-suggested-restarts rethrow ] recover ; inline
: fuel-run-file ( path -- )
[ fuel-set-use-hook run-file ] curry with-scope ; inline
-: fuel-with-autouse ( ... quot: ( ... -- ... ) -- ... )
+: fuel-with-autouse ( ..a quot: ( ..a -- ..b ) -- ..b )
[ auto-use? on fuel-set-use-hook call ] curry with-scope ; inline
: fuel-get-uses ( lines -- )
projects / factor.git / commitdiff