Fixing various test failures and updating some more vocabs for >r/r> removal

db4
Slava Pestov 2008-12-17 22:29:32 -06:00
parent 4dd615fa9e
commit 5fdb474c76
30 changed files with 79 additions and 79 deletions

View File

@ -79,7 +79,7 @@ IN: compiler.tree.dead-code.tests
[ [ read drop 1 2 ] ] [ [ read [ 1 2 ] dip drop ] optimize-quot ] unit-test [ [ 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 [ [ [ ] [ ] if ] ] [ [ [ 1 ] [ 2 ] if drop ] optimize-quot ] unit-test

View File

@ -8,13 +8,13 @@ compiler.tree.debugger ;
: test-modular-arithmetic ( quot -- quot' ) : test-modular-arithmetic ( quot -- quot' )
build-tree optimize-tree nodes>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 } declare + >fixnum ] test-modular-arithmetic ] unit-test
[ [ +-integer-integer dup >fixnum ] ] [ [ +-integer-integer dup >fixnum ] ]
[ [ { integer integer } declare + dup >fixnum ] test-modular-arithmetic ] unit-test [ [ { 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 [ [ { integer integer } declare + 4 * >fixnum ] test-modular-arithmetic ] unit-test
TUPLE: declared-fixnum { x fixnum } ; TUPLE: declared-fixnum { x fixnum } ;

View File

@ -20,13 +20,13 @@ M: thread send ( message thread -- )
my-mailbox mailbox-get ?linked ; my-mailbox mailbox-get ?linked ;
: receive-timeout ( timeout -- message ) : receive-timeout ( timeout -- message )
my-mailbox swap mailbox-get-timeout ?linked ; [ my-mailbox ] dip mailbox-get-timeout ?linked ;
: receive-if ( pred -- message ) : receive-if ( pred -- message )
my-mailbox swap mailbox-get? ?linked ; inline [ my-mailbox ] dip mailbox-get? ?linked ; inline
: receive-if-timeout ( timeout pred -- message ) : receive-if-timeout ( timeout pred -- message )
my-mailbox -rot mailbox-get-timeout? ?linked ; inline [ my-mailbox ] 2dip mailbox-get-timeout? ?linked ; inline
: rethrow-linked ( error process supervisor -- ) : rethrow-linked ( error process supervisor -- )
[ <linked-error> ] dip send ; [ <linked-error> ] dip send ;

View File

@ -56,7 +56,7 @@ sequences eval accessors ;
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call 3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test ] 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 [ error>> >r/r>-in-fry-error? ] must-fail-with
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [ [ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [

View File

@ -360,7 +360,7 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
{ $list { $list
"Factor only makes use of one native thread, and Factor threads are scheduled co-operatively. C library calls block the entire VM." "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." "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" } "." } { "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" } "." } { "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." } { "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." }

View File

@ -1,6 +1,6 @@
USING: io io.streams.string io.streams.duplex listener USING: io io.streams.string io.streams.duplex listener
tools.test parser math namespaces continuations vocabs kernel tools.test parser math namespaces continuations vocabs kernel
compiler.units eval ; compiler.units eval vocabs.parser ;
IN: listener.tests IN: listener.tests
: hello "Hi" print ; parsing : hello "Hi" print ; parsing

View File

@ -2,7 +2,7 @@ USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart math.order math.functions combinators.short-circuit.smart math.order math.functions
definitions compiler.units fry lexer ; definitions compiler.units fry lexer words.symbol ;
IN: locals.tests IN: locals.tests
:: foo ( a b -- a a ) a a ; :: foo ( a b -- a a ) a a ;

View File

@ -57,8 +57,8 @@ io.files io.encodings.utf8 ;
[ "mate" ] [ "mate" step5 "" like ] unit-test [ "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 [ 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 [ 2array ] 2map [ first2 = not ] filter
] unit-test ] unit-test

View File

@ -7,7 +7,7 @@ USING: kernel math parser sequences combinators splitting ;
] [ ] [
CHAR: y = [ CHAR: y = [
over zero? over zero?
[ 2drop t ] [ >r 1- r> consonant? not ] if [ 2drop t ] [ [ 1- ] dip consonant? not ] if
] [ ] [
2drop t 2drop t
] if ] if
@ -15,18 +15,18 @@ USING: kernel math parser sequences combinators splitting ;
: skip-vowels ( i str -- i str ) : skip-vowels ( i str -- i str )
2dup bounds-check? [ 2dup bounds-check? [
2dup consonant? [ >r 1+ r> skip-vowels ] unless 2dup consonant? [ [ 1+ ] dip skip-vowels ] unless
] when ; ] when ;
: skip-consonants ( i str -- i str ) : skip-consonants ( i str -- i str )
2dup bounds-check? [ 2dup bounds-check? [
2dup consonant? [ >r 1+ r> skip-consonants ] when 2dup consonant? [ [ 1+ ] dip skip-consonants ] when
] when ; ] when ;
: (consonant-seq) ( n i str -- n ) : (consonant-seq) ( n i str -- n )
skip-vowels skip-vowels
2dup bounds-check? [ 2dup bounds-check? [
>r 1+ >r 1+ r> r> skip-consonants >r 1+ r> [ 1+ ] [ 1+ ] [ ] tri* skip-consonants [ 1+ ] dip
(consonant-seq) (consonant-seq)
] [ ] [
2drop 2drop
@ -42,7 +42,7 @@ USING: kernel math parser sequences combinators splitting ;
over 1 < [ over 1 < [
2drop f 2drop f
] [ ] [
2dup nth >r over 1- over nth r> = [ 2dup nth [ over 1- over nth ] dip = [
consonant? consonant?
] [ ] [
2drop f 2drop f
@ -52,7 +52,7 @@ USING: kernel math parser sequences combinators splitting ;
: consonant-end? ( n seq -- ? ) : consonant-end? ( n seq -- ? )
[ length swap - ] keep consonant? ; [ length swap - ] keep consonant? ;
: last-is? ( str possibilities -- ? ) >r peek r> member? ; : last-is? ( str possibilities -- ? ) [ peek ] dip member? ;
: cvc? ( str -- ? ) : cvc? ( str -- ? )
{ {

View File

@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint prettyprint.config
prettyprint.sections sequences tools.test vectors words prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard prettyprint.private effects splitting generic.standard prettyprint.private
continuations generic compiler.units tools.walker eval continuations generic compiler.units tools.walker eval
accessors make ; accessors make vocabs.parser ;
IN: prettyprint.tests IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test [ "4" ] [ 4 unparse ] unit-test

View File

@ -6,7 +6,7 @@ quotations effects tools.test continuations generic.standard
sorting assocs definitions prettyprint io inspector sorting assocs definitions prettyprint io inspector
classes.tuple classes.union classes.predicate debugger classes.tuple classes.union classes.predicate debugger
threads.private io.streams.string io.timeouts io.thread 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 IN: stack-checker.tests
\ infer. must-infer \ infer. must-infer
@ -320,7 +320,7 @@ DEFER: bar
: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
[ [ bad-bin ] infer ] must-fail [ [ bad-bin ] infer ] must-fail
[ [ r> ] infer ] [ inference-error? ] must-fail-with [ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with
! Regression ! Regression
[ [ cleave ] infer ] [ inference-error? ] must-fail-with [ [ cleave ] infer ] [ inference-error? ] must-fail-with
@ -502,7 +502,7 @@ ERROR: custom-error ;
[ custom-error inference-error ] infer [ custom-error inference-error ] infer
] unit-test ] unit-test
[ T{ effect f 1 1 t } ] [ [ T{ effect f 1 2 t } ] [
[ dup [ 3 throw ] dip ] infer [ dup [ 3 throw ] dip ] infer
] unit-test ] unit-test

View File

@ -1,9 +1,10 @@
! Copyright (C) 2008 Daniel Ehrenberg. ! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors values kernel sequences assocs io.files 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 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 IN: unicode.script
<PRIVATE <PRIVATE

View File

@ -136,7 +136,7 @@ ERROR: no-case ;
! recursive-hashcode ! recursive-hashcode
: recursive-hashcode ( n obj quot -- code ) : 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 ! These go here, not in sequences and hashtables, since those
! two cannot depend on us ! two cannot depend on us

View File

@ -1,7 +1,5 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 USING: accessors kernel kernel.private math math.private
sequences sequences.private ; sequences sequences.private ;
IN: growable IN: growable
@ -22,7 +20,7 @@ M: growable set-nth-unsafe underlying>> set-nth-unsafe ;
: contract ( len seq -- ) : contract ( len seq -- )
[ length ] keep [ length ] keep
[ 0 -rot set-nth-unsafe ] curry [ [ 0 ] 2dip set-nth-unsafe ] curry
(each-integer) ; inline (each-integer) ; inline
: growable-check ( n seq -- n seq ) : growable-check ( n seq -- n seq )

View File

@ -17,7 +17,7 @@ IN: kernel.tests
[ ] [ :c ] unit-test [ ] [ :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 ] unit-test
@ -35,7 +35,7 @@ IN: kernel.tests
[ ] [ [ :c ] with-string-writer drop ] 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 [ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with

View File

@ -34,7 +34,7 @@ ARTICLE: "namespaces.private" "Namespace implementation details"
ARTICLE: "namespaces" "Variables and namespaces" ARTICLE: "namespaces" "Variables and namespaces"
"The " { $vocab-link "namespaces" } " vocabulary implements simple dynamically-scoped variables." "The " { $vocab-link "namespaces" } " vocabulary implements simple dynamically-scoped variables."
$nl $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 $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." "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 } { $subsection get }

View File

@ -2,7 +2,8 @@ USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files assocs io.streams.string namespaces classes effects source-files assocs
sequences strings io.files io.pathnames definitions sequences strings io.files io.pathnames definitions
continuations sorting classes.tuple compiler.units debugger 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 IN: parser.tests
\ run-file must-infer \ run-file must-infer
@ -485,19 +486,19 @@ must-fail-with
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test [ 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? error>> staging-violation?
] must-fail-with ] must-fail-with
! Bogus error message ! Bogus error message
DEFER: blah DEFER: blahy
[ "IN: parser.tests USE: kernel TUPLE: blah < tuple ; : blah ; TUPLE: blah < tuple ; : blah ;" eval ] [ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ; TUPLE: blahy < tuple ; : blahy ;" eval ]
[ error>> error>> def>> \ blah eq? ] must-fail-with [ error>> error>> def>> \ blahy eq? ] must-fail-with
[ ] [ f lexer set f file set "Hello world" note. ] unit-test [ ] [ f lexer set f file set "Hello world" note. ] unit-test
@ -511,14 +512,16 @@ SYMBOLS: a b c ;
DEFER: blah DEFER: blah
[ ] [ "IN: symbols.tests GENERIC: blah" eval ] unit-test [ ] [ "IN: parser.tests GENERIC: blah" eval ] unit-test
[ ] [ "IN: symbols.tests USE: symbols SYMBOLS: blah ;" eval ] unit-test [ ] [ "IN: parser.tests SYMBOLS: blah ;" eval ] unit-test
[ f ] [ \ blah generic? ] unit-test [ f ] [ \ blah generic? ] unit-test
[ t ] [ \ blah symbol? ] unit-test [ t ] [ \ blah symbol? ] unit-test
[ "IN: symbols.tests USE: symbols SINGLETONS: blah blah blah ;" eval ] DEFER: blah1
[ error>> error>> def>> \ blah eq? ]
[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval ]
[ error>> error>> def>> \ blah1 eq? ]
must-fail-with must-fail-with
IN: qualified.tests.foo IN: qualified.tests.foo
@ -548,8 +551,8 @@ EXCLUDE: qualified.tests.bar => x ;
[ 3 ] [ x ] unit-test [ 3 ] [ x ] unit-test
[ 4 ] [ y ] 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 [ 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 [ error>> no-word-error? ] must-fail-with

View File

@ -414,7 +414,7 @@ HELP: QUALIFIED:
{ $syntax "QUALIFIED: vocab" } { $syntax "QUALIFIED: vocab" }
{ $description "Similar to " { $link POSTPONE: USE: } " but loads vocabulary with prefix." } { $description "Similar to " { $link POSTPONE: USE: } " but loads vocabulary with prefix." }
{ $examples { $example { $examples { $example
"USING: prettyprint qualified ;" "USING: prettyprint ;"
"QUALIFIED: math" "QUALIFIED: math"
"1 2 math:+ ." "3" "1 2 math:+ ." "3"
} } ; } } ;
@ -423,7 +423,7 @@ HELP: QUALIFIED-WITH:
{ $syntax "QUALIFIED-WITH: vocab word-prefix" } { $syntax "QUALIFIED-WITH: vocab word-prefix" }
{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses " { $snippet "word-prefix" } " as prefix." } { $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses " { $snippet "word-prefix" } " as prefix." }
{ $examples { $code { $examples { $code
"USING: prettyprint qualified ;" "USING: prettyprint ;"
"QUALIFIED-WITH: math m" "QUALIFIED-WITH: math m"
"1 2 m:+ ." "1 2 m:+ ."
"3" "3"
@ -445,7 +445,7 @@ HELP: RENAME:
{ $syntax "RENAME: word vocab => newname" } { $syntax "RENAME: word vocab => newname" }
{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "newname" } "." } { $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "newname" } "." }
{ $examples { $example { $examples { $example
"USING: prettyprint qualified ;" "USING: prettyprint ;"
"RENAME: + math => -" "RENAME: + math => -"
"2 3 - ." "2 3 - ."
"5" "5"

View File

@ -3,7 +3,7 @@ USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string kernel arrays sequences namespaces io.streams.string
parser source-files words assocs classes.tuple definitions parser source-files words assocs classes.tuple definitions
debugger compiler.units tools.vocabs accessors eval debugger compiler.units tools.vocabs accessors eval
combinators ; combinators vocabs.parser ;
! This vocab should not exist, but just in case... ! This vocab should not exist, but just in case...
[ ] [ [ ] [

View File

@ -35,8 +35,7 @@ $nl
"fee:append calls foe:append" "fee:append calls foe:append"
"foe:append calls sequences:append" "foe:append calls sequences:append"
"12345678" "12345678"
} } ;
"The " { $vocab-link "qualified" } " vocabulary contains some tools for helping with shadowing." ;
ARTICLE: "vocabulary-search-errors" "Word lookup errors" 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." "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."

View File

@ -33,7 +33,7 @@ $nl
{ $subsection define-inline } { $subsection define-inline }
"Word definitions should declare their stack effect, unless the definition is completely trivial. See " { $link "effect-declaration" } "." "Word definitions should declare their stack effect, unless the definition is completely trivial. See " { $link "effect-declaration" } "."
$nl $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" ARTICLE: "primitives" "Primitives"
"Primitives are words defined in the Factor VM. They provide the essential low-level services to the rest of the system." "Primitives are words defined in the Factor VM. They provide the essential low-level services to the rest of the system."

View File

@ -1,7 +1,7 @@
USING: arrays generic assocs kernel math namespaces USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations sequences tools.test words definitions parser quotations
vocabs continuations classes.tuple compiler.units vocabs continuations classes.tuple compiler.units
io.streams.string accessors eval ; io.streams.string accessors eval words.symbol ;
IN: words.tests IN: words.tests
[ 4 ] [ [ 4 ] [

View File

@ -16,6 +16,6 @@ test1 dup *coresume . dup *coresume . dup *coresume . dup *coresume 2drop
: test3 ( -- co ) : test3 ( -- co )
[ [ coyield* ] each ] cocreate ; [ [ 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 { 4+2/3 } [ [ 1+ coyield 2 * coyield 3 / coreset ] cocreate 1 5 [ over coresume ] times nip ] unit-test

View File

@ -7,7 +7,7 @@ eval help io io.files io.pathnames io.streams.string kernel
lexer listener listener.private make math memoize namespaces lexer listener listener.private make math memoize namespaces
parser prettyprint prettyprint.config quotations sequences sets parser prettyprint prettyprint.config quotations sequences sets
sorting source-files strings tools.vocabs vectors vocabs sorting source-files strings tools.vocabs vectors vocabs
vocabs.loader ; vocabs.loader vocabs.parser ;
IN: fuel IN: fuel

View File

@ -108,7 +108,7 @@ SYMBOL: boundaries
: ((d)) ( basis -- value ) boundaries get at ; : ((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) DEFER: (d)
@ -120,7 +120,7 @@ DEFER: (d)
: linear-op ( vec quot -- vec ) : linear-op ( vec quot -- vec )
[ [
[ [
-rot >r swap call r> alt*n (alt+) -rot [ swap call ] dip alt*n (alt+)
] curry assoc-each ] curry assoc-each
] with-terms ; inline ] with-terms ; inline
@ -165,7 +165,7 @@ DEFER: (d)
swap call [ at 0 or ] curry map ; inline swap call [ at 0 or ] curry map ; inline
: op-matrix ( domain range quot -- matrix ) : 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-matrix ( domain range -- matrix )
[ (d) ] op-matrix ; [ (d) ] op-matrix ;
@ -176,7 +176,7 @@ DEFER: (d)
! Graded by degree ! Graded by degree
: (graded-ker/im-d) ( n seq -- null/rank ) : (graded-ker/im-d) ( n seq -- null/rank )
#! d: C(n) ---> C(n+1) #! d: C(n) ---> C(n+1)
[ ?nth ] 2keep >r 1+ r> ?nth [ ?nth ] [ [ 1+ ] dip ?nth ] 2bi
dim-im/ker-d ; dim-im/ker-d ;
: graded-ker/im-d ( graded-basis -- seq ) : graded-ker/im-d ( graded-basis -- seq )
@ -188,13 +188,13 @@ DEFER: (d)
! Bi-graded for two-step complexes ! Bi-graded for two-step complexes
: (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank ) : (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )
#! d: C(u,z) ---> C(u+2,z-1) #! 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 ; dim-im/ker-d ;
: bigraded-ker/im-d ( bigraded-basis -- seq ) : bigraded-ker/im-d ( bigraded-basis -- seq )
dup length [ dup length [
over first length [ over first length [
>r 2dup r> spin (bigraded-ker/im-d) [ 2dup ] dip spin (bigraded-ker/im-d)
] map 2nip ] map 2nip
] with map ; ] with map ;
@ -224,13 +224,13 @@ DEFER: (d)
] if ; ] if ;
: laplacian-matrix ( basis1 basis2 basis3 -- matrix ) : 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-betti ( basis1 basis2 basis3 -- n )
laplacian-matrix null/rank drop ; laplacian-matrix null/rank drop ;
: laplacian-kernel ( basis1 basis2 basis3 -- basis ) : laplacian-kernel ( basis1 basis2 basis3 -- basis )
>r tuck r> [ tuck ] dip
laplacian-matrix dup empty-matrix? [ laplacian-matrix dup empty-matrix? [
2drop f 2drop f
] [ ] [
@ -246,7 +246,7 @@ DEFER: (d)
dup length [ graded-triple ] with map ; dup length [ graded-triple ] with map ;
: graded-laplacian ( generators quot -- seq ) : graded-laplacian ( generators quot -- seq )
>r basis graded graded-triples [ first3 ] r> compose map ; [ basis graded graded-triples [ first3 ] ] dip compose map ;
inline inline
: graded-laplacian-betti ( generators -- seq ) : graded-laplacian-betti ( generators -- seq )
@ -273,12 +273,12 @@ DEFER: (d)
: bigraded-triples ( grid -- triples ) : bigraded-triples ( grid -- triples )
dup length [ dup length [
over first length [ over first length [
>r 2dup r> spin bigraded-triple [ 2dup ] dip spin bigraded-triple
] map 2nip ] map 2nip
] with map ; ] with map ;
: bigraded-laplacian ( u-generators z-generators quot -- seq ) : 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 [ [ first3 ] prepose map ] curry map ; inline
: bigraded-laplacian-betti ( u-generators z-generators -- seq ) : bigraded-laplacian-betti ( u-generators z-generators -- seq )

View File

@ -88,7 +88,7 @@ TUPLE: slides < book ;
: prev-page ( book -- ) -1 change-page ; : prev-page ( book -- ) -1 change-page ;
: (strip-tease) ( data n -- data ) : (strip-tease) ( data n -- data )
>r first3 r> head 3array ; [ first3 ] dip head 3array ;
: strip-tease ( data -- seq ) : strip-tease ( data -- seq )
dup third length 1- [ dup third length 1- [

View File

@ -154,8 +154,7 @@ M: spheres-gadget distance-step ( gadget -- dz )
: (make-reflection-framebuffer) ( depthbuffer -- framebuffer ) : (make-reflection-framebuffer) ( depthbuffer -- framebuffer )
gen-framebuffer dup [ gen-framebuffer dup [
swap >r swap [ GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT GL_RENDERBUFFER_EXT ] dip
GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT GL_RENDERBUFFER_EXT r>
glFramebufferRenderbufferEXT glFramebufferRenderbufferEXT
] with-framebuffer ; ] with-framebuffer ;
@ -244,10 +243,10 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
[ drop dup [ -+ ] bi@ ] 2keep ; [ drop dup [ -+ ] bi@ ] 2keep ;
: (reflection-face) ( gadget face -- ) : (reflection-face) ( gadget face -- )
swap reflection-texture>> >r >r swap reflection-texture>> [
GL_FRAMEBUFFER_EXT GL_FRAMEBUFFER_EXT
GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT0_EXT
r> r> 0 glFramebufferTexture2DEXT ] 2dip 0 glFramebufferTexture2DEXT
check-framebuffer ; check-framebuffer ;
: (draw-reflection-texture) ( gadget -- ) : (draw-reflection-texture) ( gadget -- )

View File

@ -6,7 +6,7 @@ IN: sudoku
SYMBOL: solutions SYMBOL: solutions
SYMBOL: board 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 ; : row ( n -- row ) board get nth ;
: board> ( m n -- x ) row nth ; : board> ( m n -- x ) row nth ;
@ -19,13 +19,13 @@ SYMBOL: board
: box-contains? ( n x y -- ? ) : box-contains? ( n x y -- ? )
[ 3 /i 3 * ] bi@ [ 3 /i 3 * ] bi@
9 [ >r 3dup r> cell-contains? ] contains? 9 [ [ 3dup ] dip cell-contains? ] contains?
>r 3drop r> ; [ 3drop ] dip ;
DEFER: search DEFER: search
: assume ( n x y -- ) : 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 -- ) : attempt ( n x y -- )
{ {
@ -59,9 +59,9 @@ DEFER: search
: search ( 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. ] } { [ over 0 = over 9 = and ] [ 2drop solution. ] }
{ [ 2dup board> ] [ >r 1+ r> search ] } { [ 2dup board> ] [ [ 1+ ] dip search ] }
[ solve ] [ solve ]
} cond ; } cond ;

View File

@ -88,7 +88,7 @@ TUPLE: tetris
: tetris-move ( tetris move -- ? ) : tetris-move ( tetris move -- ? )
#! moves the piece if possible, returns whether the piece was moved #! moves the piece if possible, returns whether the piece was moved
2dup can-move? [ 2dup can-move? [
>r current-piece r> move-piece drop t [ current-piece ] dip move-piece drop t
] [ ] [
2drop f 2drop f
] if ; ] if ;

View File

@ -20,7 +20,7 @@ IN: tetris.gl
! TODO: move implementation specific stuff into tetris-board ! TODO: move implementation specific stuff into tetris-board
: (draw-row) ( x y row -- ) : (draw-row) ( x y row -- )
>r over r> nth dup [ over ] dip nth dup
[ gl-color 2array draw-block ] [ 3drop ] if ; [ gl-color 2array draw-block ] [ 3drop ] if ;
: draw-row ( y row -- ) : draw-row ( y row -- )