[ [ read drop 1 2 ] ] [ [ read [ 1 2 ] dip drop ] optimize-quot ] unit-test
-[ [ over [ + ] dip ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
+[ [ over >R + R> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
[ [ [ ] [ ] if ] ] [ [ [ 1 ] [ 2 ] if drop ] optimize-quot ] unit-test
: test-modular-arithmetic ( quot -- quot' )
build-tree optimize-tree nodes>quot ;
-[ [ [ >fixnum ] dip >fixnum fixnum+fast ] ]
+[ [ >R >fixnum R> >fixnum fixnum+fast ] ]
[ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test
[ [ +-integer-integer dup >fixnum ] ]
[ [ { integer integer } declare + dup >fixnum ] test-modular-arithmetic ] unit-test
-[ [ [ >fixnum ] dip >fixnum fixnum+fast 4 fixnum*fast ] ]
+[ [ >R >fixnum R> >fixnum fixnum+fast 4 fixnum*fast ] ]
[ [ { integer integer } declare + 4 * >fixnum ] test-modular-arithmetic ] unit-test
TUPLE: declared-fixnum { x fixnum } ;
my-mailbox mailbox-get ?linked ;\r
\r
: receive-timeout ( timeout -- message )\r
- my-mailbox swap mailbox-get-timeout ?linked ;\r
+ [ my-mailbox ] dip mailbox-get-timeout ?linked ;\r
\r
: receive-if ( pred -- message )\r
- my-mailbox swap mailbox-get? ?linked ; inline\r
+ [ my-mailbox ] dip mailbox-get? ?linked ; inline\r
\r
: receive-if-timeout ( timeout pred -- message )\r
- my-mailbox -rot mailbox-get-timeout? ?linked ; inline\r
+ [ my-mailbox ] 2dip mailbox-get-timeout? ?linked ; inline\r
\r
: rethrow-linked ( error process supervisor -- )\r
[ <linked-error> ] dip send ;\r
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test
-[ "USING: fry kernel ; f '[ load-local _ ]" eval ]
+[ "USING: fry locals.backend ; f '[ load-local _ ]" eval ]
[ error>> >r/r>-in-fry-error? ] must-fail-with
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [
{ $list
"Factor only makes use of one native thread, and Factor threads are scheduled co-operatively. C library calls block the entire VM."
"Factor does not hide anything from the programmer, all internals are exposed. It is your responsibility to avoid writing fragile code which depends too much on implementation detail."
- { "When a source file uses two vocabularies which define words with the same name, the order of the vocabularies in the " { $link POSTPONE: USE: } " or " { $link POSTPONE: USING: } " forms is important. The parser prints warnings when vocabularies shadow words from other vocabularies; see " { $link "vocabulary-search-shadow" } ". The " { $vocab-link "qualified" } " vocabulary implements qualified naming, which can be used to resolve ambiguities." }
+ { "When a source file uses two vocabularies which define words with the same name, the order of the vocabularies in the " { $link POSTPONE: USE: } " or " { $link POSTPONE: USING: } " forms is important. The " { $link POSTPONE: QUALIFIED: } " word implements qualified naming, which can be used to resolve ambiguities." }
{ "If a literal object appears in a word definition, the object itself is pushed on the stack when the word executes, not a copy. If you intend to mutate this object, you must " { $link clone } " it first. See " { $link "syntax-literals" } "." }
{ "For a discussion of potential issues surrounding the " { $link f } " object, see " { $link "booleans" } "." }
{ "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by ``multiple inheritance'' in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." }
USING: io io.streams.string io.streams.duplex listener
tools.test parser math namespaces continuations vocabs kernel
-compiler.units eval ;
+compiler.units eval vocabs.parser ;
IN: listener.tests
: hello "Hi" print ; parsing
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart math.order math.functions
-definitions compiler.units fry lexer ;
+definitions compiler.units fry lexer words.symbol ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
[ "mate" ] [ "mate" step5 "" like ] unit-test
[ { } ] [
- "resource:extra/porter-stemmer/test/voc.txt" utf8 file-lines
+ "resource:basis/porter-stemmer/test/voc.txt" utf8 file-lines
[ stem ] map
- "resource:extra/porter-stemmer/test/output.txt" utf8 file-lines
+ "resource:basis/porter-stemmer/test/output.txt" utf8 file-lines
[ 2array ] 2map [ first2 = not ] filter
] unit-test
] [
CHAR: y = [
over zero?
- [ 2drop t ] [ >r 1- r> consonant? not ] if
+ [ 2drop t ] [ [ 1- ] dip consonant? not ] if
] [
2drop t
] if
: skip-vowels ( i str -- i str )
2dup bounds-check? [
- 2dup consonant? [ >r 1+ r> skip-vowels ] unless
+ 2dup consonant? [ [ 1+ ] dip skip-vowels ] unless
] when ;
: skip-consonants ( i str -- i str )
2dup bounds-check? [
- 2dup consonant? [ >r 1+ r> skip-consonants ] when
+ 2dup consonant? [ [ 1+ ] dip skip-consonants ] when
] when ;
: (consonant-seq) ( n i str -- n )
skip-vowels
2dup bounds-check? [
- >r 1+ >r 1+ r> r> skip-consonants >r 1+ r>
+ [ 1+ ] [ 1+ ] [ ] tri* skip-consonants [ 1+ ] dip
(consonant-seq)
] [
2drop
over 1 < [
2drop f
] [
- 2dup nth >r over 1- over nth r> = [
+ 2dup nth [ over 1- over nth ] dip = [
consonant?
] [
2drop f
: consonant-end? ( n seq -- ? )
[ length swap - ] keep consonant? ;
-: last-is? ( str possibilities -- ? ) >r peek r> member? ;
+: last-is? ( str possibilities -- ? ) [ peek ] dip member? ;
: cvc? ( str -- ? )
{
prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard prettyprint.private
continuations generic compiler.units tools.walker eval
-accessors make ;
+accessors make vocabs.parser ;
IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test
sorting assocs definitions prettyprint io inspector
classes.tuple classes.union classes.predicate debugger
threads.private io.streams.string io.timeouts io.thread
-sequences.private destructors combinators eval ;
+sequences.private destructors combinators eval locals.backend ;
IN: stack-checker.tests
\ infer. must-infer
: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
[ [ bad-bin ] infer ] must-fail
-[ [ r> ] infer ] [ inference-error? ] must-fail-with
+[ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with
! Regression
[ [ cleave ] infer ] [ inference-error? ] must-fail-with
[ custom-error inference-error ] infer
] unit-test
-[ T{ effect f 1 1 t } ] [
+[ T{ effect f 1 2 t } ] [
[ dup [ 3 throw ] dip ] infer
] unit-test
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors values kernel sequences assocs io.files
-io.encodings ascii math.ranges io splitting math.parser
+io.encodings ascii math.ranges io splitting math.parser
namespaces make byte-arrays locals math sets io.encodings.ascii
-words compiler.units arrays interval-maps unicode.data ;
+words words.symbol compiler.units arrays interval-maps
+unicode.data ;
IN: unicode.script
<PRIVATE
! recursive-hashcode
: recursive-hashcode ( n obj quot -- code )
- pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
+ pick 0 <= [ 3drop 0 ] [ [ 1- ] 2dip call ] if ; inline
! These go here, not in sequences and hashtables, since those
! two cannot depend on us
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-
-! Some low-level code used by vectors and string buffers.
USING: accessors kernel kernel.private math math.private
sequences sequences.private ;
IN: growable
: contract ( len seq -- )
[ length ] keep
- [ 0 -rot set-nth-unsafe ] curry
+ [ [ 0 ] 2dip set-nth-unsafe ] curry
(each-integer) ; inline
: growable-check ( n seq -- n seq )
[ ] [ :c ] unit-test
-[ { } set-retainstack r> ] [ { "kernel-error" 13 f f } = ] must-fail-with
+[ 3 [ { } set-retainstack ] dip ] [ { "kernel-error" 13 f f } = ] must-fail-with
[ ] [ :c ] unit-test
[ ] [ [ :c ] with-string-writer drop ] unit-test
-: overflow-r 3 >r overflow-r ;
+: overflow-r 3 [ overflow-r ] dip ;
[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with
ARTICLE: "namespaces" "Variables and namespaces"
"The " { $vocab-link "namespaces" } " vocabulary implements simple dynamically-scoped variables."
$nl
-"A variable is an entry in an assoc of bindings, where the assoc is implicit rather than passed on the stack. These assocs are termed " { $emphasis "namespaces" } ". Nesting of scopes is implemented with a search order on namespaces, defined by a " { $emphasis "namestack" } ". Since namespaces are just assoc, any object can be used as a variable, however by convention, variables are keyed by symbols (see " { $link "symbols" } ")."
+"A variable is an entry in an assoc of bindings, where the assoc is implicit rather than passed on the stack. These assocs are termed " { $emphasis "namespaces" } ". Nesting of scopes is implemented with a search order on namespaces, defined by a " { $emphasis "namestack" } ". Since namespaces are just assoc, any object can be used as a variable, however by convention, variables are keyed by symbols (see " { $link "words.symbol" } ")."
$nl
"The " { $link get } " and " { $link set } " words read and write variable values. The " { $link get } " word searches up the chain of nested namespaces, while " { $link set } " always sets variable values in the current namespace only. Namespaces are dynamically scoped; when a quotation is called from a nested scope, any words called by the quotation also execute in that scope."
{ $subsection get }
io.streams.string namespaces classes effects source-files assocs
sequences strings io.files io.pathnames definitions
continuations sorting classes.tuple compiler.units debugger
-vocabs vocabs.loader accessors eval combinators lexer ;
+vocabs vocabs.loader accessors eval combinators lexer
+vocabs.parser words.symbol ;
IN: parser.tests
\ run-file must-infer
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
-[ "DEFER: blah" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
+[ "DEFER: blahy" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
[
- "IN: parser.tests : blah ; parsing FORGET: blah" eval
+ "IN: parser.tests : blahy ; parsing FORGET: blahy" eval
] [
error>> staging-violation?
] must-fail-with
! Bogus error message
-DEFER: blah
+DEFER: blahy
-[ "IN: parser.tests USE: kernel TUPLE: blah < tuple ; : blah ; TUPLE: blah < tuple ; : blah ;" eval ]
-[ error>> error>> def>> \ blah eq? ] must-fail-with
+[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ; TUPLE: blahy < tuple ; : blahy ;" eval ]
+[ error>> error>> def>> \ blahy eq? ] must-fail-with
[ ] [ f lexer set f file set "Hello world" note. ] unit-test
DEFER: blah
-[ ] [ "IN: symbols.tests GENERIC: blah" eval ] unit-test
-[ ] [ "IN: symbols.tests USE: symbols SYMBOLS: blah ;" eval ] unit-test
+[ ] [ "IN: parser.tests GENERIC: blah" eval ] unit-test
+[ ] [ "IN: parser.tests SYMBOLS: blah ;" eval ] unit-test
[ f ] [ \ blah generic? ] unit-test
[ t ] [ \ blah symbol? ] unit-test
-[ "IN: symbols.tests USE: symbols SINGLETONS: blah blah blah ;" eval ]
-[ error>> error>> def>> \ blah eq? ]
+DEFER: blah1
+
+[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval ]
+[ error>> error>> def>> \ blah1 eq? ]
must-fail-with
IN: qualified.tests.foo
[ 3 ] [ x ] unit-test
[ 4 ] [ y ] unit-test
-[ "USE: qualified IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ]
+[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ]
[ error>> no-word-error? ] must-fail-with
-[ "USE: qualified IN: qualified.tests RENAME: doesnotexist qualified.tests => blah" eval ]
+[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ]
[ error>> no-word-error? ] must-fail-with
{ $syntax "QUALIFIED: vocab" }
{ $description "Similar to " { $link POSTPONE: USE: } " but loads vocabulary with prefix." }
{ $examples { $example
- "USING: prettyprint qualified ;"
+ "USING: prettyprint ;"
"QUALIFIED: math"
"1 2 math:+ ." "3"
} } ;
{ $syntax "QUALIFIED-WITH: vocab word-prefix" }
{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses " { $snippet "word-prefix" } " as prefix." }
{ $examples { $code
- "USING: prettyprint qualified ;"
+ "USING: prettyprint ;"
"QUALIFIED-WITH: math m"
"1 2 m:+ ."
"3"
{ $syntax "RENAME: word vocab => newname" }
{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "newname" } "." }
{ $examples { $example
- "USING: prettyprint qualified ;"
+ "USING: prettyprint ;"
"RENAME: + math => -"
"2 3 - ."
"5"
kernel arrays sequences namespaces io.streams.string
parser source-files words assocs classes.tuple definitions
debugger compiler.units tools.vocabs accessors eval
-combinators ;
+combinators vocabs.parser ;
! This vocab should not exist, but just in case...
[ ] [
"fee:append calls foe:append"
"foe:append calls sequences:append"
"12345678"
-}
-"The " { $vocab-link "qualified" } " vocabulary contains some tools for helping with shadowing." ;
+} ;
ARTICLE: "vocabulary-search-errors" "Word lookup errors"
"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies."
{ $subsection define-inline }
"Word definitions should declare their stack effect, unless the definition is completely trivial. See " { $link "effect-declaration" } "."
$nl
-"All other types of word definitions, such as " { $link "symbols" } " and " { $link "generic" } ", are just special cases of the above." ;
+"All other types of word definitions, such as " { $link "words.symbol" } " and " { $link "generic" } ", are just special cases of the above." ;
ARTICLE: "primitives" "Primitives"
"Primitives are words defined in the Factor VM. They provide the essential low-level services to the rest of the system."
USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations
vocabs continuations classes.tuple compiler.units
-io.streams.string accessors eval ;
+io.streams.string accessors eval words.symbol ;
IN: words.tests
[ 4 ] [
: test3 ( -- co )
[ [ coyield* ] each ] cocreate ;
-{ "c" "b" "a" } [ test3 { "a" "b" "c" } over coresume >r dup *coresume >r *coresume r> r> ] unit-test
+{ "c" "b" "a" } [ test3 { "a" "b" "c" } over coresume [ dup *coresume [ *coresume ] dip ] dip ] unit-test
{ 4+2/3 } [ [ 1+ coyield 2 * coyield 3 / coreset ] cocreate 1 5 [ over coresume ] times nip ] unit-test
\ No newline at end of file
lexer listener listener.private make math memoize namespaces
parser prettyprint prettyprint.config quotations sequences sets
sorting source-files strings tools.vocabs vectors vocabs
-vocabs.loader ;
+vocabs.loader vocabs.parser ;
IN: fuel
: ((d)) ( basis -- value ) boundaries get at ;
-: dx.y ( x y -- vec ) >r ((d)) r> wedge ;
+: dx.y ( x y -- vec ) [ ((d)) ] dip wedge ;
DEFER: (d)
: linear-op ( vec quot -- vec )
[
[
- -rot >r swap call r> alt*n (alt+)
+ -rot [ swap call ] dip alt*n (alt+)
] curry assoc-each
] with-terms ; inline
swap call [ at 0 or ] curry map ; inline
: op-matrix ( domain range quot -- matrix )
- rot [ >r 2dup r> (op-matrix) ] map 2nip ; inline
+ rot [ [ 2dup ] dip (op-matrix) ] map 2nip ; inline
: d-matrix ( domain range -- matrix )
[ (d) ] op-matrix ;
! Graded by degree
: (graded-ker/im-d) ( n seq -- null/rank )
#! d: C(n) ---> C(n+1)
- [ ?nth ] 2keep >r 1+ r> ?nth
+ [ ?nth ] [ [ 1+ ] dip ?nth ] 2bi
dim-im/ker-d ;
: graded-ker/im-d ( graded-basis -- seq )
! Bi-graded for two-step complexes
: (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )
#! d: C(u,z) ---> C(u+2,z-1)
- [ ?nth ?nth ] 3keep >r >r 2 + r> 1 - r> ?nth ?nth
+ [ ?nth ?nth ] 3keep [ [ 2 + ] dip 1 - ] dip ?nth ?nth
dim-im/ker-d ;
: bigraded-ker/im-d ( bigraded-basis -- seq )
dup length [
over first length [
- >r 2dup r> spin (bigraded-ker/im-d)
+ [ 2dup ] dip spin (bigraded-ker/im-d)
] map 2nip
] with map ;
] if ;
: laplacian-matrix ( basis1 basis2 basis3 -- matrix )
- dupd d-matrix m.m' >r d-matrix m'.m r> ?m+ ;
+ dupd d-matrix m.m' [ d-matrix m'.m ] dip ?m+ ;
: laplacian-betti ( basis1 basis2 basis3 -- n )
laplacian-matrix null/rank drop ;
: laplacian-kernel ( basis1 basis2 basis3 -- basis )
- >r tuck r>
+ [ tuck ] dip
laplacian-matrix dup empty-matrix? [
2drop f
] [
dup length [ graded-triple ] with map ;
: graded-laplacian ( generators quot -- seq )
- >r basis graded graded-triples [ first3 ] r> compose map ;
+ [ basis graded graded-triples [ first3 ] ] dip compose map ;
inline
: graded-laplacian-betti ( generators -- seq )
: bigraded-triples ( grid -- triples )
dup length [
over first length [
- >r 2dup r> spin bigraded-triple
+ [ 2dup ] dip spin bigraded-triple
] map 2nip
] with map ;
: bigraded-laplacian ( u-generators z-generators quot -- seq )
- >r [ basis graded ] bi@ tensor bigraded-triples r>
+ [ [ basis graded ] bi@ tensor bigraded-triples ] dip
[ [ first3 ] prepose map ] curry map ; inline
: bigraded-laplacian-betti ( u-generators z-generators -- seq )
: prev-page ( book -- ) -1 change-page ;
: (strip-tease) ( data n -- data )
- >r first3 r> head 3array ;
+ [ first3 ] dip head 3array ;
: strip-tease ( data -- seq )
dup third length 1- [
: (make-reflection-framebuffer) ( depthbuffer -- framebuffer )
gen-framebuffer dup [
- swap >r
- GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT GL_RENDERBUFFER_EXT r>
+ swap [ GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT GL_RENDERBUFFER_EXT ] dip
glFramebufferRenderbufferEXT
] with-framebuffer ;
[ drop dup [ -+ ] bi@ ] 2keep ;
: (reflection-face) ( gadget face -- )
- swap reflection-texture>> >r >r
- GL_FRAMEBUFFER_EXT
- GL_COLOR_ATTACHMENT0_EXT
- r> r> 0 glFramebufferTexture2DEXT
+ swap reflection-texture>> [
+ GL_FRAMEBUFFER_EXT
+ GL_COLOR_ATTACHMENT0_EXT
+ ] 2dip 0 glFramebufferTexture2DEXT
check-framebuffer ;
: (draw-reflection-texture) ( gadget -- )
SYMBOL: solutions
SYMBOL: board
-: pair+ ( a b c d -- a+b c+d ) swapd + >r + r> ;
+: pair+ ( a b c d -- a+b c+d ) swapd [ + ] 2bi@ ;
: row ( n -- row ) board get nth ;
: board> ( m n -- x ) row nth ;
: box-contains? ( n x y -- ? )
[ 3 /i 3 * ] bi@
- 9 [ >r 3dup r> cell-contains? ] contains?
- >r 3drop r> ;
+ 9 [ [ 3dup ] dip cell-contains? ] contains?
+ [ 3drop ] dip ;
DEFER: search
: assume ( n x y -- )
- [ >board ] 2keep [ >r 1+ r> search ] 2keep f>board ;
+ [ >board ] 2keep [ [ 1+ ] dip search ] 2keep f>board ;
: attempt ( n x y -- )
{
: search ( x y -- )
{
- { [ over 9 = ] [ >r drop 0 r> 1+ search ] }
+ { [ over 9 = ] [ [ drop 0 ] dip 1+ search ] }
{ [ over 0 = over 9 = and ] [ 2drop solution. ] }
- { [ 2dup board> ] [ >r 1+ r> search ] }
+ { [ 2dup board> ] [ [ 1+ ] dip search ] }
[ solve ]
} cond ;
: tetris-move ( tetris move -- ? )
#! moves the piece if possible, returns whether the piece was moved
2dup can-move? [
- >r current-piece r> move-piece drop t
+ [ current-piece ] dip move-piece drop t
] [
2drop f
] if ;
! TODO: move implementation specific stuff into tetris-board
: (draw-row) ( x y row -- )
- >r over r> nth dup
+ [ over ] dip nth dup
[ gl-color 2array draw-block ] [ 3drop ] if ;
: draw-row ( y row -- )
projects / factor.git / commitdiff