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

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

@ -48,7 +48,7 @@ M: +unknown+ curry-effect ;
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 ;

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." } ;
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@ } "." }
{ $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
{ $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 } "." }
{ $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
{ $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* } "." }
{ $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 -- )
[ 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 -- )

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

@ -4,15 +4,15 @@ math arrays combinators ;
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
@ -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." } ;
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"

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

@ -8,31 +8,31 @@ MACRO: nmin-length ( n -- )
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 ]
@ -45,10 +45,10 @@ MACRO: (ncollect) ( n -- )
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
@ -58,7 +58,7 @@ MACRO: (ncollect) ( n -- )
: 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
@ -67,7 +67,7 @@ MACRO: (ncollect) ( n -- )
: 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 ]

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

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

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

@ -32,4 +32,11 @@ ERROR: inconsistent-recursive-call-error < inference-error 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 ;

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

@ -13,10 +13,13 @@ M: bad-macro-input summary
M: unbalanced-branches-error summary
drop "Unbalanced branches" ;
: quots-and-branches. ( quots branches -- )
zip [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
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 ;
[ quots>> ] [ branches>> [ length [ "x" <array> ] bi@ <effect> ] { } assoc>map ] bi
quots-and-branches. ;
M: too-many->r summary
drop "Quotation pushes elements on retain stack without popping them" ;
@ -60,4 +63,18 @@ M: transform-expansion-error error.
tri ;
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.known-words
stack-checker.dependencies
stack-checker.row-polymorphism
stack-checker.recursive-state ;
IN: stack-checker.inlining
@ -141,6 +142,7 @@ SYMBOL: enter-out
: inline-word ( word -- )
commit-literals
[ depends-on-definition ]
[ infer-polymorphic? get [ check-polymorphic-effect ] [ drop ] if ]
[
dup inline-recursive-label [
call-recursive-inline-word
@ -150,7 +152,7 @@ SYMBOL: enter-out
[ dup infer-inline-word-def ]
if
] if*
] bi ;
] tri ;
M: word apply-object
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 )
M: callable infer ( quot -- effect )
[ infer-quot-here ] with-infer drop ;
(infer) ;
: infer. ( quot -- )
#! Safe to call from inference transforms.

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

@ -40,7 +40,7 @@ SYMBOL: 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

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 ;
IN: effects.tests
@ -27,3 +27,18 @@ 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

34
core/effects/effects.factor
View File

@ -8,11 +8,21 @@ IN: effects
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
@ -42,13 +52,19 @@ M: pair effect>string first2 [ effect>string ] bi@ ": " glue ;
: 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 ;
@ -87,7 +103,7 @@ M: effect clone
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?>> [
@ -97,5 +113,5 @@ M: effect clone
[ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
[ nip terminated?>> ] 2tri
[ [ "x" <array> ] bi@ ] dip
effect boa
<terminated-effect>
] if ; inline

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

@ -1,34 +1,49 @@
! 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 ;
ERROR: invalid-effect-variable ;
ERROR: effect-variable-can't-have-type ;
ERROR: stack-effect-omits-dashes ;
: 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
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 ;

12
core/kernel/kernel.factor
View File

@ -29,7 +29,7 @@ DEFER: if
#! 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 -- )
@ -39,7 +39,7 @@ DEFER: if
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 -- )
@ -49,7 +49,7 @@ DEFER: if
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.
@ -171,16 +171,16 @@ UNION: boolean POSTPONE: t POSTPONE: f ;
: 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 ( ... pred: ( ... -- ... ? ) body: ( ... -- ... ) -- ... )
swap do compose [ loop ] curry when ; inline
: until ( pred: ( -- ? ) body: ( -- ) -- )
: until ( ... pred: ( ... -- ... ? ) body: ( ... -- ... ) -- )
[ [ not ] compose ] dip while ; inline
! Object protocol

10
core/math/math.factor
View File

@ -77,7 +77,7 @@ ERROR: log2-expects-positive x ;
: 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
@ -141,18 +141,18 @@ GENERIC: prev-float ( m -- n )
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
@ -171,7 +171,7 @@ PRIVATE>
: 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
] [

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
: 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
@ -408,82 +408,82 @@ PRIVATE>
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 ( ... elt quot: ( ... elt -- ... ? ) accum -- ... )
[ keep ] dip rot [ push ] [ 2drop ] if ; inline
: selector-for ( quot exemplar -- selector accum )
@ -492,19 +492,19 @@ PRIVATE>
: 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 ( ... elt quot: ( ... elt -- ... ? ) accum1 accum2 -- ... )
[ 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 )
@ -513,16 +513,16 @@ PRIVATE>
: collector ( quot -- quot' vec )
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
: produce ( pred quot -- seq )
: produce ( ... pred: ( ... -- ... ? ) quot: ( ... -- ... obj ) -- ... 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 -- )
@ -532,10 +532,10 @@ PRIVATE>
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 )
@ -564,7 +564,7 @@ PRIVATE>
: nths ( indices seq -- seq' )
[ nth ] curry map ;
: any? ( seq quot -- ? )
: any? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
find drop >boolean ; inline
: member? ( elt seq -- ? )
@ -626,7 +626,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
<PRIVATE
: (filter!) ( quot: ( elt -- ? ) store scan seq -- )
: (filter!) ( ... quot: ( ... elt -- ... ? ) store scan seq -- ... )
2dup length < [
[ move ] 3keep
[ nth-unsafe pick call [ 1 + ] when ] 2keep
@ -636,7 +636,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
PRIVATE>
: filter! ( seq quot -- seq )
: filter! ( ... seq quot: ( ... elt -- ... ? ) -- ... seq )
swap [ [ 0 0 ] dip (filter!) ] keep ; inline
: remove! ( elt seq -- seq )
@ -771,7 +771,7 @@ PRIVATE>
] 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
@ -810,7 +810,7 @@ PRIVATE>
: 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? [
@ -873,11 +873,11 @@ PRIVATE>
: 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
@ -889,10 +889,10 @@ PRIVATE>
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 )
@ -915,22 +915,22 @@ PRIVATE>
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 )
@ -942,15 +942,15 @@ M: object sum 0 [ + ] binary-reduce ; inline
: 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 )