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

Merge branch 'row-polymorphism' of git://factorcode.org/git/factor into row-polymorphism

db4
Slava Pestov 2010-03-06 18:11:45 +13:00
parent 102a8dc8f8 26e4bb818a
commit a926576993
20 changed files with 368 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/compiler/cfg/linearization/linearization.factor
View File

@ -42,7 +42,7 @@ M: ##branch linearize-insn
: successors ( bb -- first second ) successors>> first2 ; inline : 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 bb insn
conditional-quot conditional-quot
[ drop dup successors>> second useless-branch? ] 2bi [ drop dup successors>> second useless-branch? ] 2bi

2
basis/compiler/tree/propagation/call-effect/call-effect.factor
View File

@ -48,7 +48,7 @@ M: +unknown+ curry-effect ;
M: effect curry-effect M: effect curry-effect
[ in>> length ] [ out>> length ] [ terminated?>> ] tri [ in>> length ] [ out>> length ] [ terminated?>> ] tri
pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
[ [ "x" <array> ] bi@ ] dip effect boa ; [ [ "x" <array> ] bi@ ] dip <terminated-effect> ;
M: curry cached-effect M: curry cached-effect
quot>> cached-effect curry-effect ; quot>> cached-effect curry-effect ;

6
basis/generalizations/generalizations-docs.factor
View File

@ -252,17 +252,17 @@ HELP: spread*
{ $notes "This word can be used with " { $link apply-curry } " to generalize the " { $snippet "bi-curry@ bi*" } " or " { $snippet "tri-curry@ tri*" } " dataflow patterns." } ; { $notes "This word can be used with " { $link apply-curry } " to generalize the " { $snippet "bi-curry@ bi*" } " or " { $snippet "tri-curry@ tri*" } " dataflow patterns." } ;
HELP: apply-curry HELP: apply-curry
{ $values { "...a" { $snippet "n" } " values on the datastack" } { "quot" quotation } { "n" integer } } { $values { "a..." { $snippet "n" } " values on the datastack" } { "quot" quotation } { "n" integer } }
{ $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@ } "." } { $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@ } "." }
{ $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*" } "." } ; { $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*" } "." } ;
HELP: cleave-curry HELP: cleave-curry
{ $values { "a" object } { "...quot" { $snippet "n" } " quotations on the datastack" } { "n" integer } } { $values { "a" object } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } }
{ $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 } "." } { $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 } "." }
{ $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*" } "." } ; { $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*" } "." } ;
HELP: spread-curry HELP: spread-curry
{ $values { "...a" { $snippet "n" } " objects on the datastack" } { "...quot" { $snippet "n" } " quotations on the datastack" } { "n" integer } } { $values { "a..." { $snippet "n" } " objects on the datastack" } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } }
{ $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* } "." } { $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* } "." }
{ $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*" } "." } ; { $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*" } "." } ;

6
basis/generalizations/generalizations.factor
View File

@ -125,13 +125,13 @@ MACRO: cleave* ( n -- )
: mnapply ( quot m n -- ) : mnapply ( quot m n -- )
[ nip dupn ] [ nspread* ] 2bi ; inline [ nip dupn ] [ nspread* ] 2bi ; inline
: apply-curry ( ...a quot n -- ) : apply-curry ( a... quot n -- )
[ [curry] ] dip napply ; inline [ [curry] ] dip napply ; inline
: cleave-curry ( a ...quot n -- ) : cleave-curry ( a quot... n -- )
[ [curry] ] swap [ napply ] [ cleave* ] bi ; inline [ [curry] ] swap [ napply ] [ cleave* ] bi ; inline
: spread-curry ( ...a ...quot n -- ) : spread-curry ( a... quot... n -- )
[ [curry] ] swap [ napply ] [ spread* ] bi ; inline [ [curry] ] swap [ napply ] [ spread* ] bi ; inline
MACRO: mnswap ( m n -- ) MACRO: mnswap ( m n -- )

8
basis/sequences/generalizations/generalizations-docs.factor
View File

@ -4,15 +4,15 @@ math arrays combinators ;
IN: sequences.generalizations IN: sequences.generalizations
HELP: neach 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." } ; { $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ;
HELP: nmap 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." } ; { $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ;
HELP: nmap-as 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." } ; { $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 HELP: mnmap
@ -28,7 +28,7 @@ HELP: nproduce
{ $description "A generalization of " { $link produce } " that generates " { $snippet "n" } " arrays in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ; { $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 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." } ; { $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" ARTICLE: "sequences.generalizations" "Generalized sequence iteration combinators"

20
basis/sequences/generalizations/generalizations.factor
View File

@ -8,31 +8,31 @@ MACRO: nmin-length ( n -- )
dup 1 - [ min ] n*quot dup 1 - [ min ] n*quot
'[ [ length ] _ napply @ ] ; '[ [ length ] _ napply @ ] ;
: nnth-unsafe ( n ...seq n -- ) : nnth-unsafe ( n seq... n -- )
[ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline [ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
MACRO: nset-nth-unsafe ( n -- ) MACRO: nset-nth-unsafe ( n -- )
[ [ drop ] ] [ [ drop ] ]
[ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ] [ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
if-zero ; if-zero ;
: (neach) ( ...seq quot n -- len quot' ) : (neach) ( seq... quot n -- len quot' )
dup dup dup dup dup dup
'[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline '[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
: neach ( ...seq quot n -- ) : neach ( seq... quot n -- )
(neach) each-integer ; inline (neach) each-integer ; inline
: nmap-as ( ...seq quot exemplar n -- result ) : nmap-as ( seq... quot exemplar n -- result )
'[ _ (neach) ] dip map-integers ; inline '[ _ (neach) ] dip map-integers ; inline
: nmap ( ...seq quot n -- result ) : nmap ( seq... quot n -- result )
dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
MACRO: nnew-sequence ( n -- ) MACRO: nnew-sequence ( n -- )
[ [ drop ] ] [ [ drop ] ]
[ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ; [ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
: nnew-like ( len ...exemplar quot n -- result... ) : nnew-like ( len exemplar... quot n -- result... )
5 dupn '[ 5 dupn '[
_ nover _ nover
[ [ _ nnew-sequence ] dip call ] [ [ _ nnew-sequence ] dip call ]
@ -45,10 +45,10 @@ MACRO: (ncollect) ( n -- )
3 dupn 1 + 3 dupn 1 +
'[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ; '[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ;
: ncollect ( len quot ...into n -- ) : ncollect ( len quot into... n -- )
(ncollect) each-integer ; inline (ncollect) each-integer ; inline
: nmap-integers ( len quot ...exemplar n -- result... ) : nmap-integers ( len quot exemplar... n -- result... )
4 dupn 4 dupn
'[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline '[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
@ -58,7 +58,7 @@ MACRO: (ncollect) ( n -- )
: mnmap ( m*seq quot m n -- result*n ) : mnmap ( m*seq quot m n -- result*n )
2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline 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 '[ 5 dupn '[
[ [ length ] keep new-resizable ] _ napply [ [ length ] keep new-resizable ] _ napply
[ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep [ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep
@ -67,7 +67,7 @@ MACRO: (ncollect) ( n -- )
: ncollector ( quot n -- quot' vec... ) : ncollector ( quot n -- quot' vec... )
[ V{ } swap dupn ] keep ncollector-for ; inline [ V{ } swap dupn ] keep ncollector-for ; inline
: nproduce-as ( pred quot ...exemplar n -- seq... ) : nproduce-as ( pred quot exemplar... n -- seq... )
7 dupn '[ 7 dupn '[
_ ndup _ ndup
[ _ ncollector-for [ while ] _ ndip ] [ _ ncollector-for [ while ] _ ndip ]

3
basis/stack-checker/backend/backend.factor
View File

@ -157,3 +157,6 @@ M: bad-call summary
current-effect current-effect
stack-visitor get stack-visitor get
] with-scope ; inline ] with-scope ; inline
: (infer) ( quot -- effect )
[ infer-quot-here ] with-infer drop ;

7
basis/stack-checker/errors/errors.factor
View File

@ -33,3 +33,10 @@ ERROR: inconsistent-recursive-call-error < inference-error word ;
ERROR: transform-expansion-error < inference-error error continuation word ; ERROR: transform-expansion-error < inference-error error continuation word ;
ERROR: bad-declaration-error < inference-error declaration ; ERROR: bad-declaration-error < inference-error declaration ;
ERROR: invalid-quotation-input < inference-error word branches quots ;
ERROR: invalid-effect-variable < inference-error effect ;
ERROR: effect-variable-can't-have-type < inference-error effect ;

21
basis/stack-checker/errors/prettyprint/prettyprint.factor
View File

@ -13,10 +13,13 @@ M: bad-macro-input summary
M: unbalanced-branches-error summary M: unbalanced-branches-error summary
drop "Unbalanced branches" ; drop "Unbalanced branches" ;
: quots-and-branches. ( quots branches -- )
zip [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
M: unbalanced-branches-error error. M: unbalanced-branches-error error.
dup summary print dup summary print
[ quots>> ] [ branches>> [ length [ "x" <array> ] bi@ <effect> ] { } assoc>map ] bi zip [ quots>> ] [ branches>> [ length [ "x" <array> ] bi@ <effect> ] { } assoc>map ] bi
[ [ first pprint-short bl ] [ second effect>string print ] bi ] each ; quots-and-branches. ;
M: too-many->r summary M: too-many->r summary
drop "Quotation pushes elements on retain stack without popping them" ; drop "Quotation pushes elements on retain stack without popping them" ;
@ -61,3 +64,17 @@ M: transform-expansion-error error.
M: do-not-compile summary M: do-not-compile summary
word>> name>> "Cannot compile call to " prepend ; word>> name>> "Cannot compile call to " prepend ;
M: invalid-quotation-input summary
word>> name>>
"The input quotations to " " don't match their expected effects" surround ;
M: invalid-quotation-input error.
dup summary print
[ quots>> ] [ branches>> ] bi quots-and-branches. ;
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" ;

4
basis/stack-checker/inlining/inlining.factor
View File

@ -11,6 +11,7 @@ stack-checker.backend
stack-checker.branches stack-checker.branches
stack-checker.known-words stack-checker.known-words
stack-checker.dependencies stack-checker.dependencies
stack-checker.row-polymorphism
stack-checker.recursive-state ; stack-checker.recursive-state ;
IN: stack-checker.inlining IN: stack-checker.inlining
@ -141,6 +142,7 @@ SYMBOL: enter-out
: inline-word ( word -- ) : inline-word ( word -- )
commit-literals commit-literals
[ depends-on-definition ] [ depends-on-definition ]
[ infer-polymorphic? get [ check-polymorphic-effect ] [ drop ] if ]
[ [
dup inline-recursive-label [ dup inline-recursive-label [
call-recursive-inline-word call-recursive-inline-word
@ -150,7 +152,7 @@ SYMBOL: enter-out
[ dup infer-inline-word-def ] [ dup infer-inline-word-def ]
if if
] if* ] if*
] bi ; ] tri ;
M: word apply-object M: word apply-object
dup inline? [ inline-word ] [ non-inline-word ] if ; dup inline? [ inline-word ] [ non-inline-word ] if ;

71
basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor Normal file
View File

@ -0,0 +1,71 @@
! (c)2010 Joe Groff bsd license
USING: effects fry io kernel math namespaces sequences
system tools.test
stack-checker.backend
stack-checker.errors
stack-checker.row-polymorphism
stack-checker.state
stack-checker.values ;
IN: stack-checker.row-polymorphism.tests
: infer-polymorphic-quot ( quot -- vars )
t infer-polymorphic? [
unclip-last [
dup current-word set
init-inference
init-known-values
[ [ <literal> <value> [ set-known ] [ push-d ] bi ] each ]
[ stack-effect ] bi*
infer-polymorphic-vars
] with-scope
] with-variable ;
: test-poly-infer ( effect quot -- )
[ '[ _ ] ] [ '[ _ infer-polymorphic-quot ] ] bi* unit-test ; inline
: poly-infer-must-fail ( quot -- )
'[ _ infer-polymorphic-quot ] [ invalid-quotation-input? ] must-fail-with ; inline
: poly-infer-must-fail-unknown ( quot -- )
'[ _ infer-polymorphic-quot ] [ unknown-macro-input? ] must-fail-with ; inline
H{ { "." 0 } } [ [ write ] each ] test-poly-infer
H{ { "." 1 } } [ [ append ] each ] test-poly-infer
H{ { "." 0 } } [ [ ] map ] test-poly-infer
H{ { "." 0 } } [ [ reverse ] map ] test-poly-infer
H{ { "." 1 } } [ [ append dup ] map ] test-poly-infer
H{ { "." 1 } } [ [ swap nth suffix dup ] map-index ] test-poly-infer
H{ { "a" 3 } { "b" 1 } } [ [ 2drop ] [ 2nip ] if ] test-poly-infer
H{ { "a" 2 } { "b" 3 } } [ [ dup ] [ over ] if ] test-poly-infer
H{ { "a" 0 } { "b" 1 } } [ [ os ] [ cpu ] if ] test-poly-infer
H{ { "a" 1 } { "b" 2 } } [ [ os ] [ 1 + cpu ] if ] test-poly-infer
H{ { "a" 0 } { "b" 0 } } [ [ write ] [ "(f)" write ] if* ] test-poly-infer
H{ { "a" 0 } { "b" 1 } } [ [ ] [ f ] if* ] test-poly-infer
H{ { "a" 1 } { "b" 1 } } [ [ nip ] [ drop f ] if* ] test-poly-infer
H{ { "a" 1 } { "b" 1 } } [ [ nip ] [ ] if* ] test-poly-infer
H{ { "a" 2 } { "b" 2 } } [ [ 3append f ] [ ] if* ] test-poly-infer
H{ { "a" 0 } { "b" 0 } } [ [ drop ] [ ] if* ] test-poly-infer
[ [ write write ] each ] poly-infer-must-fail
[ [ ] each ] poly-infer-must-fail
[ [ dup ] map ] poly-infer-must-fail
[ [ drop ] map ] poly-infer-must-fail
[ [ 1 + ] map-index ] poly-infer-must-fail
[ [ dup ] [ ] if ] poly-infer-must-fail
[ [ 2dup ] [ over ] if ] poly-infer-must-fail
[ [ drop ] [ ] if ] poly-infer-must-fail
[ [ ] [ ] if* ] poly-infer-must-fail
[ [ dup ] [ ] if* ] poly-infer-must-fail
[ [ drop ] [ drop ] if* ] poly-infer-must-fail
[ [ ] [ drop ] if* ] poly-infer-must-fail
[ [ ] [ 2dup ] if* ] poly-infer-must-fail
[ "derp" each ] poly-infer-must-fail
[ each ] poly-infer-must-fail-unknown
[ "derp" [ "derp" ] if ] poly-infer-must-fail
[ [ "derp" ] "derp" if ] poly-infer-must-fail
[ [ "derp" ] if ] poly-infer-must-fail-unknown

100
basis/stack-checker/row-polymorphism/row-polymorphism.factor Normal file
View File

@ -0,0 +1,100 @@
! (c)2010 Joe Groff bsd license
USING: accessors arrays assocs combinators combinators.short-circuit
continuations effects fry kernel locals math 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
<PRIVATE
SYMBOLS: current-effect-variables current-word-effect current-meta-d ;
: quotation-effect? ( in -- ? )
dup pair? [ second effect? ] [ drop f ] if ;
SYMBOL: (unknown)
GENERIC: >error-quot ( known -- quot )
M: object >error-quot drop (unknown) ;
M: literal >error-quot value>> ;
M: composed >error-quot
[ quot1>> known >error-quot ] [ quot2>> known >error-quot ] bi
\ compose [ ] 3sequence ;
M: curried >error-quot
[ obj>> known >error-quot ] [ quot>> known >error-quot ] bi
\ curry [ ] 3sequence ;
: >error-branches-and-quots ( branch/values -- branches quots )
[ [ second ] [ known >error-quot ] bi* ] assoc-map unzip ;
: abandon-check ( -- * )
current-word get
current-word-effect get in>> current-meta-d get zip
[ first quotation-effect? ] filter
>error-branches-and-quots
invalid-quotation-input ;
:: check-variable ( actual-count declared-count variable -- difference )
actual-count declared-count -
variable [
variable current-effect-variables get at* nip
[ variable current-effect-variables get at - ]
[ variable current-effect-variables get set-at 0 ] if
] [
dup [ abandon-check ] unless-zero
] if ;
: adjust-variable ( diff var -- )
over 0 >=
[ current-effect-variables get at+ ]
[ 2drop ] if ; inline
:: (check-input) ( declared actual -- )
actual declared [ in>> length ] bi@ declared in-var>>
[ check-variable ] keep :> ( in-diff in-var )
actual declared [ out>> length ] bi@ declared out-var>>
[ check-variable ] keep :> ( out-diff out-var )
{ [ in-var not ] [ out-var not ] [ in-diff out-diff = ] } 0||
[
in-var [ in-diff swap adjust-variable ] when*
out-var [ out-diff swap adjust-variable ] when*
] [
abandon-check
] if ;
: infer-value ( value -- effect )
dup known [ nest-visitor init-inference infer-call* current-effect ] with-scope ; inline
: check-input ( in value -- )
over quotation-effect? [
[ second ] dip infer-value (check-input)
] [ 2drop ] if ;
: normalize-variables ( -- variables' )
current-effect-variables get dup values [
infimum dup 0 <
[ '[ _ - ] assoc-map ] [ drop ] if
] unless-empty ;
PRIVATE>
: infer-polymorphic-vars ( effect -- variables )
H{ } clone current-effect-variables set
dup current-word-effect set
in>> dup length ensure-d dup current-meta-d set
[ check-input ] 2each
normalize-variables ;
: check-polymorphic-effect ( word -- )
current-word get [
dup current-word set stack-effect
dup { [ in-var>> ] [ out-var>> ] } 1||
[ infer-polymorphic-vars ] when drop
] dip current-word set ;
SYMBOL: infer-polymorphic?

2
basis/stack-checker/stack-checker.factor
View File

@ -11,7 +11,7 @@ IN: stack-checker
GENERIC: infer ( quot -- effect ) GENERIC: infer ( quot -- effect )
M: callable infer ( quot -- effect ) M: callable infer ( quot -- effect )
[ infer-quot-here ] with-infer drop ; (infer) ;
: infer. ( quot -- ) : infer. ( quot -- )
#! Safe to call from inference transforms. #! Safe to call from inference transforms.

2
basis/stack-checker/state/state.factor
View File

@ -40,7 +40,7 @@ SYMBOL: literals
: current-effect ( -- effect ) : current-effect ( -- effect )
input-count get "x" <array> input-count get "x" <array>
meta-d length "x" <array> meta-d length "x" <array>
terminated? get effect boa ; terminated? get <terminated-effect> ;
: init-inference ( -- ) : init-inference ( -- )
terminated? off terminated? off

17
core/effects/effects-tests.factor
View File

@ -1,4 +1,4 @@
USING: effects kernel tools.test prettyprint accessors USING: effects effects.parser eval kernel tools.test prettyprint accessors
quotations sequences ; quotations sequences ;
IN: effects.tests IN: effects.tests
@ -27,3 +27,18 @@ IN: effects.tests
[ { object object } ] [ (( a b -- )) effect-in-types ] unit-test [ { object object } ] [ (( a b -- )) effect-in-types ] unit-test
[ { object sequence } ] [ (( a b: sequence -- )) 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

34
core/effects/effects.factor
View File

@ -8,11 +8,21 @@ IN: effects
TUPLE: effect TUPLE: effect
{ in array read-only } { in array read-only }
{ out 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 ) : <effect> ( in out -- effect )
dup { "*" } = [ drop { } t ] [ f ] if ?terminated f f effect boa ;
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 ) : effect-height ( effect -- n )
[ out>> length ] [ in>> length ] bi - ; inline [ out>> length ] [ in>> length ] bi - ; inline
@ -42,13 +52,19 @@ M: pair effect>string first2 [ effect>string ] bi@ ": " glue ;
: stack-picture ( seq -- string ) : stack-picture ( seq -- string )
[ [ effect>string % CHAR: \s , ] each ] "" make ; [ [ effect>string % CHAR: \s , ] each ] "" make ;
: var-picture ( var -- string )
[ ".." " " surround ]
[ "" ] if* ;
M: effect effect>string ( effect -- string ) M: effect effect>string ( effect -- string )
[ [
"( " % "( " %
[ in>> stack-picture % "-- " % ] dup in-var>> var-picture %
[ out>> stack-picture % ] dup in>> stack-picture % "-- " %
[ terminated?>> [ "* " % ] when ] dup out-var>> var-picture %
tri dup out>> stack-picture %
dup terminated?>> [ "* " % ] when
drop
")" % ")" %
] "" make ; ] "" make ;
@ -87,7 +103,7 @@ M: effect clone
shuffle-mapping swap nths ; shuffle-mapping swap nths ;
: add-effect-input ( effect -- effect' ) : 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' ) : compose-effects ( effect1 effect2 -- effect' )
over terminated?>> [ over terminated?>> [
@ -97,5 +113,5 @@ M: effect clone
[ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ] [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
[ nip terminated?>> ] 2tri [ nip terminated?>> ] 2tri
[ [ "x" <array> ] bi@ ] dip [ [ "x" <array> ] bi@ ] dip
effect boa <terminated-effect>
] if ; inline ] if ; inline

37
core/effects/parser/parser.factor
View File

@ -1,34 +1,49 @@
! Copyright (C) 2008, 2010 Slava Pestov. ! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: lexer sets sequences kernel splitting effects USING: lexer sets sequences kernel splitting effects
combinators arrays vocabs.parser classes parser ; combinators arrays make vocabs.parser classes parser ;
IN: effects.parser IN: effects.parser
DEFER: parse-effect DEFER: parse-effect
ERROR: bad-effect ; ERROR: bad-effect ;
ERROR: invalid-effect-variable ;
ERROR: effect-variable-can't-have-type ;
ERROR: stack-effect-omits-dashes ;
: parse-effect-token ( end -- token/f ) SYMBOL: effect-var
scan [ nip ] [ = ] 2bi [ drop f ] [
dup { f "(" "((" } member? [ bad-effect ] [ : 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 [ ":" ?tail [
scan { scan {
{ [ dup "(" = ] [ drop ")" parse-effect ] } { [ dup "(" = ] [ drop ")" parse-effect ] }
{ [ dup f = ] [ ")" unexpected-eof ] } { [ dup f = ] [ ")" unexpected-eof ] }
[ parse-word dup class? [ bad-effect ] unless ] [ parse-word dup class? [ bad-effect ] unless ]
} cond 2array } cond 2array
] when ] when , t
] if
] if
] if ] if
] if ; ] if ;
: parse-effect-tokens ( end -- tokens ) : parse-effect-tokens ( end -- var tokens )
[ parse-effect-token dup ] curry [ ] produce nip ; [
[ t f ] dip [ parse-effect-token [ f ] 2dip ] curry [ ] while nip
ERROR: stack-effect-omits-dashes tokens ; ] { } make ;
: parse-effect ( end -- effect ) : parse-effect ( end -- effect )
parse-effect-tokens { "--" } split1 dup [ "--" parse-effect-tokens ] dip parse-effect-tokens
[ <effect> ] [ drop stack-effect-omits-dashes ] if ; <variable-effect> ;
: complete-effect ( -- effect ) : complete-effect ( -- effect )
"(" expect ")" parse-effect ; "(" expect ")" parse-effect ;

12
core/kernel/kernel.factor
View File

@ -29,7 +29,7 @@ DEFER: if
#! two literal quotations. #! two literal quotations.
rot [ drop ] [ nip ] if ; inline rot [ drop ] [ nip ] if ; inline
: if ( ? true false -- ) ? call ; : if ( ..a ? true: ( ..a -- ..b ) false: ( ..a -- ..b ) -- ..b ) ? call ;
! Single branch ! Single branch
: unless ( ? false -- ) : unless ( ? false -- )
@ -39,7 +39,7 @@ DEFER: if
swap [ call ] [ drop ] if ; inline swap [ call ] [ drop ] if ; inline
! Anaphoric ! Anaphoric
: if* ( ? true false -- ) : if* ( ..a ? true: ( ..a ? -- ..b ) false: ( ..a -- ..b ) -- ..b )
pick [ drop call ] [ 2nip call ] if ; inline pick [ drop call ] [ 2nip call ] if ; inline
: when* ( ? true -- ) : when* ( ? true -- )
@ -49,7 +49,7 @@ DEFER: if
over [ drop ] [ nip call ] if ; inline over [ drop ] [ nip call ] if ; inline
! Default ! 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 pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline
! Dippers. ! Dippers.
@ -171,16 +171,16 @@ UNION: boolean POSTPONE: t POSTPONE: f ;
: most ( x y quot -- z ) 2keep ? ; inline : most ( x y quot -- z ) 2keep ? ; inline
! Loops ! Loops
: loop ( pred: ( -- ? ) -- ) : loop ( ... pred: ( ... -- ... ? ) -- ... )
[ call ] keep [ loop ] curry when ; inline recursive [ call ] keep [ loop ] curry when ; inline recursive
: do ( pred body -- pred body ) : do ( pred body -- pred body )
dup 2dip ; inline dup 2dip ; inline
: while ( pred: ( -- ? ) body: ( -- ) -- ) : while ( ... pred: ( ... -- ... ? ) body: ( ... -- ... ) -- ... )
swap do compose [ loop ] curry when ; inline swap do compose [ loop ] curry when ; inline
: until ( pred: ( -- ? ) body: ( -- ) -- ) : until ( ... pred: ( ... -- ... ? ) body: ( ... -- ... ) -- )
[ [ not ] compose ] dip while ; inline [ [ not ] compose ] dip while ; inline
! Object protocol ! Object protocol

10
core/math/math.factor
View File

@ -77,7 +77,7 @@ ERROR: log2-expects-positive x ;
: even? ( n -- ? ) 1 bitand zero? ; : even? ( n -- ? ) 1 bitand zero? ;
: odd? ( n -- ? ) 1 bitand 1 number= ; : 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 [ dup zero? ] [ [ drop ] prepose ] [ ] tri* if ; inline
: when-zero ( n quot -- ) [ ] if-zero ; inline : when-zero ( n quot -- ) [ ] if-zero ; inline
@ -141,18 +141,18 @@ GENERIC: prev-float ( m -- n )
PRIVATE> PRIVATE>
: (each-integer) ( i n quot: ( i -- ) -- ) : (each-integer) ( ... i n quot: ( ... i -- ... ) -- ... )
[ iterate-step iterate-next (each-integer) ] [ iterate-step iterate-next (each-integer) ]
[ 3drop ] if-iterate? ; inline recursive [ 3drop ] if-iterate? ; inline recursive
: (find-integer) ( i n quot: ( i -- ? ) -- i ) : (find-integer) ( ... i n quot: ( ... i -- ... ? ) -- ... i )
[ [
iterate-step iterate-step
[ [ ] ] 2dip [ [ ] ] 2dip
[ iterate-next (find-integer) ] 2curry bi-curry if [ iterate-next (find-integer) ] 2curry bi-curry if
] [ 3drop f ] if-iterate? ; inline recursive ] [ 3drop f ] if-iterate? ; inline recursive
: (all-integers?) ( i n quot: ( i -- ? ) -- ? ) : (all-integers?) ( ... i n quot: ( ... i -- ... ? ) -- ... ? )
[ [
iterate-step iterate-step
[ iterate-next (all-integers?) ] 3curry [ iterate-next (all-integers?) ] 3curry
@ -171,7 +171,7 @@ PRIVATE>
: all-integers? ( n quot -- ? ) : all-integers? ( n quot -- ? )
iterate-prep (all-integers?) ; inline iterate-prep (all-integers?) ; inline
: find-last-integer ( n quot: ( i -- ? ) -- i ) : find-last-integer ( ... n quot: ( ... i -- ... ? ) -- ... i )
over 0 < [ over 0 < [
2drop f 2drop f
] [ ] [

110
core/sequences/sequences.factor
View File

@ -29,7 +29,7 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; inline
: empty? ( seq -- ? ) length 0 = ; inline : 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 [ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
: when-empty ( seq quot -- ) [ ] if-empty ; inline : when-empty ( seq quot -- ) [ ] if-empty ; inline
@ -408,82 +408,82 @@ PRIVATE>
PRIVATE> PRIVATE>
: each ( seq quot -- ) : each ( ... seq quot: ( ... x -- ... ) -- ... )
(each) each-integer ; inline (each) each-integer ; inline
: reduce ( seq identity quot -- result ) : reduce ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... result )
swapd each ; inline swapd each ; inline
: map-integers ( len quot exemplar -- newseq ) : map-integers ( len quot exemplar -- newseq )
[ over ] dip [ [ collect ] keep ] new-like ; inline [ 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 [ (each) ] dip map-integers ; inline
: map ( seq quot -- newseq ) : map ( ... seq quot: ( ... x -- ... newx ) -- ... newseq )
over map-as ; inline over map-as ; inline
: replicate-as ( len quot exemplar -- newseq ) : replicate-as ( ... len quot: ( ... -- ... newx ) exemplar -- ... newseq )
[ [ drop ] prepose ] dip map-integers ; inline [ [ drop ] prepose ] dip map-integers ; inline
: replicate ( len quot -- newseq ) : replicate ( ... len quot: ( ... -- ... newx ) -- ... newseq )
{ } replicate-as ; inline { } replicate-as ; inline
: map! ( seq quot -- seq ) : map! ( ... seq quot: ( ... x -- ... x' ) -- ... seq )
over [ map-into ] keep ; inline 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) ] dip map-as ; inline
: accumulate ( seq identity quot -- final newseq ) : accumulate ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... final newseq )
{ } accumulate-as ; inline { } accumulate-as ; inline
: accumulate! ( seq identity quot -- final seq ) : accumulate! ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... final seq )
(accumulate) map! ; inline (accumulate) map! ; inline
: 2each ( seq1 seq2 quot -- ) : 2each ( ... seq1 seq2 quot: ( ... x1 x2 -- ... ) -- ... )
(2each) each-integer ; inline (2each) each-integer ; inline
: 2reverse-each ( seq1 seq2 quot -- ) : 2reverse-each ( ... seq1 seq2 quot: ( ... x1 x2 -- ... ) -- ... )
[ [ <reversed> ] bi@ ] dip 2each ; inline [ [ <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 [ -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 [ (2each) ] dip map-integers ; inline
: 2map ( seq1 seq2 quot -- newseq ) : 2map ( ... seq1 seq2 quot: ( ... x1 x2 -- ... newx ) -- ... newseq )
pick 2map-as ; inline pick 2map-as ; inline
: 2all? ( seq1 seq2 quot -- ? ) : 2all? ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... ? )
(2each) all-integers? ; inline (2each) all-integers? ; inline
: 3each ( seq1 seq2 seq3 quot -- ) : 3each ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... ) -- ... )
(3each) each-integer ; inline (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 [ (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 [ 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-integer) ] (find-from) ; inline
: find ( seq quot -- i elt ) : find ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ find-integer ] (find) ; inline [ 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 [ 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 [ [ 1 - ] dip find-last-integer ] (find) ; inline
: all? ( seq quot -- ? ) : all? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
(each) all-integers? ; inline (each) all-integers? ; inline
: push-if ( elt quot accum -- ) : push-if ( ... elt quot: ( ... elt -- ... ? ) accum -- ... )
[ keep ] dip rot [ push ] [ 2drop ] if ; inline [ keep ] dip rot [ push ] [ 2drop ] if ; inline
: selector-for ( quot exemplar -- selector accum ) : selector-for ( quot exemplar -- selector accum )
@ -492,19 +492,19 @@ PRIVATE>
: selector ( quot -- selector accum ) : selector ( quot -- selector accum )
V{ } selector-for ; inline 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 dup [ selector-for [ each ] dip ] curry dip like ; inline
: filter ( seq quot -- subseq ) : filter ( ... seq quot: ( ... elt -- ... ? ) -- ... subseq )
over filter-as ; inline over filter-as ; inline
: push-either ( elt quot accum1 accum2 -- ) : push-either ( ... elt quot: ( ... elt -- ... ? ) accum1 accum2 -- ... )
[ keep swap ] 2dip ? push ; inline [ keep swap ] 2dip ? push ; inline
: 2selector ( quot -- selector accum1 accum2 ) : 2selector ( quot -- selector accum1 accum2 )
V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline 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 over [ 2selector [ each ] 2dip ] dip [ like ] curry bi@ ; inline
: collector-for ( quot exemplar -- quot' vec ) : collector-for ( quot exemplar -- quot' vec )
@ -513,16 +513,16 @@ PRIVATE>
: collector ( quot -- quot' vec ) : collector ( quot -- quot' vec )
V{ } collector-for ; inline V{ } collector-for ; inline
: produce-as ( pred quot exemplar -- seq ) : produce-as ( ... pred: ( ... -- ... ? ) quot: ( ... -- ... obj ) exemplar -- ... seq )
dup [ collector-for [ while ] dip ] curry dip like ; inline dup [ collector-for [ while ] dip ] curry dip like ; inline
: produce ( pred quot -- seq ) : produce ( ... pred: ( ... -- ... ? ) quot: ( ... -- ... obj ) -- ... seq )
{ } produce-as ; inline { } produce-as ; inline
: follow ( obj quot -- seq ) : follow ( ... obj quot: ( ... prev -- ... result/f ) -- ... seq )
[ dup ] swap [ keep ] curry produce nip ; inline [ dup ] swap [ keep ] curry produce nip ; inline
: each-index ( seq quot -- ) : each-index ( ... seq quot: ( ... x i -- ... ) -- ... )
(each-index) each-integer ; inline (each-index) each-integer ; inline
: interleave ( seq between quot -- ) : interleave ( seq between quot -- )
@ -532,10 +532,10 @@ PRIVATE>
3bi 3bi
] if ; inline ] if ; inline
: map-index ( seq quot -- newseq ) : map-index ( ... seq quot: ( ... x i -- ... newx ) -- ... newseq )
[ dup length iota ] dip 2map ; inline [ 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 swapd each-index ; inline
: index ( obj seq -- n ) : index ( obj seq -- n )
@ -564,7 +564,7 @@ PRIVATE>
: nths ( indices seq -- seq' ) : nths ( indices seq -- seq' )
[ nth ] curry map ; [ nth ] curry map ;
: any? ( seq quot -- ? ) : any? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
find drop >boolean ; inline find drop >boolean ; inline
: member? ( elt seq -- ? ) : member? ( elt seq -- ? )
@ -626,7 +626,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
<PRIVATE <PRIVATE
: (filter!) ( quot: ( elt -- ? ) store scan seq -- ) : (filter!) ( ... quot: ( ... elt -- ... ? ) store scan seq -- ... )
2dup length < [ 2dup length < [
[ move ] 3keep [ move ] 3keep
[ nth-unsafe pick call [ 1 + ] when ] 2keep [ nth-unsafe pick call [ 1 + ] when ] 2keep
@ -636,7 +636,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
PRIVATE> PRIVATE>
: filter! ( seq quot -- seq ) : filter! ( ... seq quot: ( ... elt -- ... ? ) -- ... seq )
swap [ [ 0 0 ] dip (filter!) ] keep ; inline swap [ [ 0 0 ] dip (filter!) ] keep ; inline
: remove! ( elt seq -- seq ) : remove! ( elt seq -- seq )
@ -771,7 +771,7 @@ PRIVATE>
] keep like ] keep like
] if ; ] if ;
: padding ( seq n elt quot -- newseq ) : padding ( ... seq n elt quot: ( ... seq1 seq2 -- ... newseq ) -- ... newseq )
[ [
[ over length [-] dup 0 = [ drop ] ] dip [ over length [-] dup 0 = [ drop ] ] dip
[ <repetition> ] curry [ <repetition> ] curry
@ -810,7 +810,7 @@ PRIVATE>
: halves ( seq -- first-slice second-slice ) : halves ( seq -- first-slice second-slice )
dup midpoint@ cut-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 #! We can't use case here since combinators depends on
#! sequences #! sequences
pick length dup 0 3 between? [ pick length dup 0 3 between? [
@ -873,11 +873,11 @@ PRIVATE>
: 2unclip-slice ( seq1 seq2 -- rest-slice1 rest-slice2 first1 first2 ) : 2unclip-slice ( seq1 seq2 -- rest-slice1 rest-slice2 first1 first2 )
[ unclip-slice ] bi@ swapd ; inline [ 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 [ [ unclip-slice ] dip [ call ] keep ] dip
compose reduce ; inline 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 [ [ prepare-2map-reduce ] keep ] dip
compose compose each-integer ; inline compose compose each-integer ; inline
@ -889,10 +889,10 @@ PRIVATE>
PRIVATE> PRIVATE>
: map-find ( seq quot -- result elt ) : map-find ( ... seq quot: ( ... elt -- ... ? ) -- ... result elt )
[ find ] (map-find) ; inline [ find ] (map-find) ; inline
: map-find-last ( seq quot -- result elt ) : map-find-last ( ... seq quot: ( ... elt -- ... ? ) -- ... result elt )
[ find-last ] (map-find) ; inline [ find-last ] (map-find) ; inline
: unclip-last-slice ( seq -- butlast-slice last ) : unclip-last-slice ( seq -- butlast-slice last )
@ -915,22 +915,22 @@ PRIVATE>
PRIVATE> PRIVATE>
: trim-head-slice ( seq quot -- slice ) : trim-head-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
(trim-head) tail-slice ; inline (trim-head) tail-slice ; inline
: trim-head ( seq quot -- newseq ) : trim-head ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
(trim-head) tail ; inline (trim-head) tail ; inline
: trim-tail-slice ( seq quot -- slice ) : trim-tail-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
(trim-tail) head-slice ; inline (trim-tail) head-slice ; inline
: trim-tail ( seq quot -- newseq ) : trim-tail ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
(trim-tail) head ; inline (trim-tail) head ; inline
: trim-slice ( seq quot -- slice ) : trim-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
[ trim-head-slice ] [ trim-tail-slice ] bi ; inline [ trim-head-slice ] [ trim-tail-slice ] bi ; inline
: trim ( seq quot -- newseq ) : trim ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
[ trim-slice ] [ drop ] 2bi like ; inline [ trim-slice ] [ drop ] 2bi like ; inline
GENERIC: sum ( seq -- n ) GENERIC: sum ( seq -- n )
@ -942,15 +942,15 @@ M: object sum 0 [ + ] binary-reduce ; inline
: supremum ( seq -- n ) [ ] [ max ] map-reduce ; : 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 [ 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 [ 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 [ with map ] 2curry map ; inline
: cartesian-product ( seq1 seq2 -- newseq ) : cartesian-product ( seq1 seq2 -- newseq )