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

Merge git://factorcode.org/git/factor

db4
Eduardo Cavazos 2008-02-06 15:36:00 -06:00
parent a5c69dae63 8428f66933
commit ccfe4a34de
123 changed files with 868 additions and 918 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
Makefile
View File

@ -65,6 +65,7 @@ default:
@echo "solaris-x86-64"
@echo "wince-arm"
@echo "winnt-x86-32"
@echo "winnt-x86-64"
@echo ""
@echo "Additional modifiers:"
@echo ""
@ -125,6 +126,9 @@ solaris-x86-64:
winnt-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
winnt-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
wince-arm:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm
@ -151,7 +155,7 @@ clean:
rm -f factor*.dll libfactor*.*
vm/resources.o:
windres vm/factor.rs vm/resources.o
$(WINDRES) vm/factor.rs vm/resources.o
.c.o:
$(CC) -c $(CFLAGS) -o $@ $<

6
core/alien/alien-tests.factor
View File

@ -14,7 +14,7 @@ prettyprint ;
! Testing the various bignum accessor
10 <byte-array> "dump" set
[ "dump" get alien-address ] unit-test-fails
[ "dump" get alien-address ] must-fail
[ 123 ] [
123 "dump" get 0 set-alien-signed-1
@ -61,9 +61,9 @@ cell 8 = [
[ ] [ 0 F{ 1 2 3 } <displaced-alien> drop ] unit-test
[ ] [ 0 ?{ t f t } <displaced-alien> drop ] unit-test
[ 0 B{ 1 2 3 } <displaced-alien> alien-address ] unit-test-fails
[ 0 B{ 1 2 3 } <displaced-alien> alien-address ] must-fail
[ 1 1 <displaced-alien> ] unit-test-fails
[ 1 1 <displaced-alien> ] must-fail
[ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test

2
core/alien/c-types/c-types-tests.factor
View File

@ -71,4 +71,4 @@ TYPEDEF: uchar* MyLPBYTE
[
0 B{ 1 2 3 4 } <displaced-alien> <void*>
] unit-test-fails
] must-fail

12
core/arrays/arrays-tests.factor
View File

@ -2,10 +2,10 @@ USING: arrays kernel sequences sequences.private growable
tools.test vectors layouts system math vectors.private ;
IN: temporary
[ -2 { "a" "b" "c" } nth ] unit-test-fails
[ 10 { "a" "b" "c" } nth ] unit-test-fails
[ "hi" -2 { "a" "b" "c" } set-nth ] unit-test-fails
[ "hi" 10 { "a" "b" "c" } set-nth ] unit-test-fails
[ -2 { "a" "b" "c" } nth ] must-fail
[ 10 { "a" "b" "c" } nth ] must-fail
[ "hi" -2 { "a" "b" "c" } set-nth ] must-fail
[ "hi" 10 { "a" "b" "c" } set-nth ] must-fail
[ f ] [ { "a" "b" "c" } dup clone eq? ] unit-test
[ "hi" ] [ "hi" 1 { "a" "b" "c" } clone [ set-nth ] keep second ] unit-test
[ V{ "a" "b" "c" } ] [ { "a" "b" "c" } >vector ] unit-test
@ -17,5 +17,5 @@ IN: temporary
[ { "a" "b" "c" "d" "e" } ]
[ { "a" } { "b" "c" } { "d" "e" } 3append ] unit-test
[ -1 f <array> ] unit-test-fails
[ cell-bits cell log2 - 2^ f <array> ] unit-test-fails
[ -1 f <array> ] must-fail
[ cell-bits cell log2 - 2^ f <array> ] must-fail

2
core/bit-arrays/bit-arrays-tests.factor
View File

@ -51,4 +51,4 @@ IN: temporary
[ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test
[ -10 ?{ } resize-bit-array ] unit-test-fails
[ -10 ?{ } resize-bit-array ] must-fail

79
core/bootstrap/stage2.factor
View File

@ -8,25 +8,63 @@ definitions assocs compiler.errors compiler.units
math.parser generic ;
IN: bootstrap.stage2
SYMBOL: bootstrap-time
: default-image-name ( -- string )
vm file-name windows? [ "." split1 drop ] when
".image" append ;
: do-crossref ( -- )
"Cross-referencing..." print flush
H{ } clone crossref set-global
xref-words
xref-generics
xref-sources ;
: load-components ( -- )
"exclude" "include"
[ get-global " " split [ empty? not ] subset ] 2apply
seq-diff
[ "bootstrap." swap append require ] each ;
: compile-remaining ( -- )
"Compiling remaining words..." print flush
vocabs [
words "compile" "compiler" lookup execute
] each ;
: count-words ( pred -- )
all-words swap subset length number>string write ;
: print-report ( time -- )
1000 /i
60 /mod swap
"Bootstrap completed in " write number>string write
" minutes and " write number>string write " seconds." print
[ compiled? ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print
"Bootstrapping is complete." print
"Now, you can run Factor:" print
vm write " -i=" write "output-image" get print flush ;
! Wrap everything in a catch which starts a listener so
! you can see what went wrong, instead of dealing with a
! fep
[
vm file-name windows? [ "." split1 drop ] when
".image" append "output-image" set-global
! We time bootstrap
millis >r
default-image-name "output-image" set-global
"math help compiler tools ui ui.tools io" "include" set-global
"" "exclude" set-global
parse-command-line
"-no-crossref" cli-args member? [
"Cross-referencing..." print flush
H{ } clone crossref set-global
xref-words
xref-generics
xref-sources
] unless
"-no-crossref" cli-args member? [ do-crossref ] unless
! Set dll paths
wince? [ "windows.ce" require ] when
@ -40,19 +78,12 @@ IN: bootstrap.stage2
] if
[
"exclude" "include"
[ get-global " " split [ empty? not ] subset ] 2apply
seq-diff
[ "bootstrap." swap append require ] each
load-components
run-bootstrap-init
"Compiling remaining words..." print flush
"bootstrap.compiler" vocab [
vocabs [
words "compile" "compiler" lookup execute
] each
compile-remaining
] when
] with-compiler-errors
:errors
@ -74,16 +105,8 @@ IN: bootstrap.stage2
] [ print-error 1 exit ] recover
] set-boot-quot
: count-words ( pred -- )
all-words swap subset length number>string write ;
[ compiled? ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print
"Bootstrapping is complete." print
"Now, you can run Factor:" print
vm write " -i=" write "output-image" get print flush
millis r> - dup bootstrap-time set-global
print-report
"output-image" get resource-path save-image-and-exit
] if

2
core/byte-arrays/byte-arrays-tests.factor
View File

@ -5,4 +5,4 @@ USING: tools.test byte-arrays ;
[ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test
[ -10 B{ } resize-byte-array ] unit-test-fails
[ -10 B{ } resize-byte-array ] must-fail

16
core/classes/classes-tests.factor
View File

@ -91,7 +91,7 @@ M: union-1 generic-update-test drop "union-1" ;
[ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test
[ "union-1" ] [ 8 generic-update-test ] unit-test
[ -7 generic-update-test ] unit-test-fails
[ -7 generic-update-test ] must-fail
! Test mixins
MIXIN: sequence-mixin
@ -169,10 +169,14 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
UNION: forget-class-bug-1 integer ;
UNION: forget-class-bug-2 forget-class-bug-1 dll ;
FORGET: forget-class-bug-1
FORGET: forget-class-bug-2
[
\ forget-class-bug-1 forget
\ forget-class-bug-2 forget
] with-compilation-unit
[ t ] [ integer dll class-or interned? ] unit-test
[ f ] [ forget-class-bug-1 typemap get values [ memq? ] with contains? ] unit-test
[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
DEFER: mixin-forget-test-g
@ -191,7 +195,7 @@ DEFER: mixin-forget-test-g
] unit-test
[ { } ] [ { } mixin-forget-test-g ] unit-test
[ H{ } mixin-forget-test-g ] unit-test-fails
[ H{ } mixin-forget-test-g ] must-fail
[ ] [
{
@ -205,7 +209,7 @@ DEFER: mixin-forget-test-g
parse-stream drop
] unit-test
[ { } mixin-forget-test-g ] unit-test-fails
[ { } mixin-forget-test-g ] must-fail
[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test
! Method flattening interfered with mixin update

2
core/combinators/combinators-tests.factor
View File

@ -38,7 +38,7 @@ namespaces combinators words ;
! Interpreted
[ "two" ] [ 2 \ case-test-1 word-def call ] unit-test
[ "x" case-test-1 ] unit-test-fails
[ "x" case-test-1 ] must-fail
: case-test-2
{

20
core/compiler/test/alien.factor
View File

@ -13,7 +13,7 @@ FUNCTION: int ffi_test_1 ;
FUNCTION: int ffi_test_2 int x int y ;
[ 5 ] [ 2 3 ffi_test_2 ] unit-test
[ "hi" 3 ffi_test_2 ] unit-test-fails
[ "hi" 3 ffi_test_2 ] must-fail
FUNCTION: int ffi_test_3 int x int y int z int t ;
[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
@ -26,8 +26,8 @@ FUNCTION: double ffi_test_5 ;
FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
[ "a" 2 3 4 5 6 7 ffi_test_9 ] unit-test-fails
[ 1 2 3 4 5 6 "a" ffi_test_9 ] unit-test-fails
[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
C-STRUCT: foo
{ "int" "x" }
@ -53,7 +53,7 @@ FUNCTION: char* ffi_test_15 char* x char* y ;
[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
[ 1 2 ffi_test_15 ] unit-test-fails
[ 1 2 ffi_test_15 ] must-fail
C-STRUCT: bar
{ "long" "x" }
@ -75,7 +75,7 @@ FUNCTION: tiny ffi_test_17 int x ;
[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
[ t ] [ [ [ alien-indirect ] infer ] catch inference-error? ] unit-test
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
: indirect-test-1
"int" { } "cdecl" alien-indirect ;
@ -84,7 +84,7 @@ FUNCTION: tiny ffi_test_17 int x ;
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
[ -1 indirect-test-1 ] unit-test-fails
[ -1 indirect-test-1 ] must-fail
: indirect-test-2
"int" { "int" "int" } "cdecl" alien-indirect data-gc ;
@ -120,7 +120,7 @@ unit-test
FUNCTION: double ffi_test_6 float x float y ;
[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
[ "a" "b" ffi_test_6 ] unit-test-fails
[ "a" "b" ffi_test_6 ] must-fail
FUNCTION: double ffi_test_7 double x double y ;
[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
@ -157,7 +157,7 @@ FUNCTION: long ffi_test_22 long x longlong y longlong z ;
[ 987655432 ]
[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
[ 1111 f 123456789 ffi_test_22 ] unit-test-fails
[ 1111 f 123456789 ffi_test_22 ] must-fail
C-STRUCT: rect
{ "float" "x" }
@ -177,7 +177,7 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] unit-test-fails
[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
@ -292,7 +292,7 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
[ ] [ callback-1 callback_test_1 ] unit-test
: callback-2 "void" { } "cdecl" [ [ 5 throw ] catch drop ] alien-callback ;
: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
[ ] [ callback-2 callback_test_1 ] unit-test

4
core/compiler/test/intrinsics.factor
View File

@ -422,11 +422,11 @@ cell 8 = [
[
B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
] unit-test-fails
] must-fail
[
B{ 0 0 0 0 } [ { c-ptr } declare <void*> ] compile-call
] unit-test-fails
] must-fail
[
4 5

15
core/compiler/test/optimizer.factor
View File

@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private
continuations ;
continuations growable ;
IN: temporary
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
@ -136,7 +136,7 @@ TUPLE: pred-test ;
GENERIC: void-generic ( obj -- * )
: breakage "hi" void-generic ;
[ t ] [ \ breakage compiled? ] unit-test
[ breakage ] unit-test-fails
[ breakage ] must-fail
! regression
: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
@ -247,7 +247,7 @@ M: slice foozul ;
GENERIC: detect-number ( obj -- obj )
M: number detect-number ;
[ 10 f [ <array> 0 + detect-number ] compile-call ] unit-test-fails
[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
! Regression
[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
@ -291,3 +291,12 @@ TUPLE: silly-tuple a b ;
: construct-empty-bug construct-empty ;
[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
! Make sure we have sane heuristics
: should-inline? method method-word flat-length 10 <= ;
[ t ] [ \ fixnum \ shift should-inline? ] unit-test
[ f ] [ \ array \ equal? should-inline? ] unit-test
[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test

43
core/compiler/test/redefine.factor
View File

@ -92,8 +92,6 @@ DEFER: x-4
[ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test
[ t ] [ \ x-3 "compiled-uses" word-prop [ drop interned? ] assoc-all? ] unit-test
DEFER: g-test-1
DEFER: g-test-3
@ -237,7 +235,7 @@ DEFER: flushable-test-2
: bx ax ;
[ \ bx forget ] with-compilation-unit
[ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test
[ f ] [ \ bx \ ax compiled-usage key? ] unit-test
DEFER: defer-redefine-test-2
@ -245,8 +243,45 @@ DEFER: defer-redefine-test-2
[ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test
[ defer-redefine-test-2 ] unit-test-fails
[ defer-redefine-test-2 ] must-fail
[ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test
[ 2 1 ] [ defer-redefine-test-2 ] unit-test
! Cross-referencing issue
: compiled-xref-a ;
: compiled-xref-c ; inline
GENERIC: compiled-xref-b ( a -- b )
TUPLE: c-1 ;
M: c-1 compiled-xref-b compiled-xref-a compiled-xref-c ;
TUPLE: c-2 ;
M: c-2 compiled-xref-b drop 3 ;
[ t ] [
\ compiled-xref-a compiled-crossref get key?
] unit-test
[ ] [
[
\ compiled-xref-a forget
] with-compilation-unit
] unit-test
[ f ] [
\ compiled-xref-a compiled-crossref get key?
] unit-test
[ ] [
"IN: temporary : compiled-xref-c ; FORGET: { c-2 compiled-xref-b }" eval
] unit-test
[ f ] [
\ compiled-xref-a compiled-crossref get key?
] unit-test

4
core/compiler/test/simple.factor
View File

@ -57,8 +57,8 @@ IN: temporary
! Make sure error reporting works
[ [ dup ] compile-call ] unit-test-fails
[ [ drop ] compile-call ] unit-test-fails
[ [ dup ] compile-call ] must-fail
[ [ drop ] compile-call ] must-fail
! Regression

8
core/compiler/test/stack-trace.factor
View File

@ -10,7 +10,7 @@ words splitting ;
: foo 3 throw 7 ;
: bar foo 4 ;
: baz bar 5 ;
[ 3 ] [ [ baz ] catch ] unit-test
[ baz ] [ 3 = ] must-fail-with
[ t ] [
symbolic-stack-trace
[ word? ] subset
@ -22,11 +22,11 @@ words splitting ;
: stack-trace-contains? symbolic-stack-trace memq? ;
[ t ] [
[ { 1 "hi" } bleh ] catch drop \ + stack-trace-contains?
[ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains?
] unit-test
[ t f ] [
[ { "hi" } bleh ] catch drop
[ { "hi" } bleh ] ignore-errors
\ + stack-trace-contains?
\ > stack-trace-contains?
] unit-test
@ -34,6 +34,6 @@ words splitting ;
: quux [ t [ "hi" throw ] when ] times ;
[ t ] [
[ 10 quux ] catch drop
[ 10 quux ] ignore-errors
\ (each-integer) stack-trace-contains?
] unit-test

12
core/continuations/continuations-docs.factor
View File

@ -23,10 +23,9 @@ $nl
"Two words raise an error in the innermost error handler for the current dynamic extent:"
{ $subsection throw }
{ $subsection rethrow }
"A set of words establish an error handler:"
"Two words for establishing an error handler:"
{ $subsection cleanup }
{ $subsection recover }
{ $subsection catch }
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
{ $subsection "errors-restartable" }
{ $subsection "errors-post-mortem" } ;
@ -147,12 +146,7 @@ HELP: throw
{ $values { "error" object } }
{ $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ;
HELP: catch
{ $values { "try" quotation } { "error/f" object } }
{ $description "Calls the " { $snippet "try" } " quotation. If an error is thrown in the dynamic extent of the quotation, restores the data stack and pushes the error. If the quotation returns successfully, outputs " { $link f } " without restoring the data stack." }
{ $notes "This word cannot differentiate between the case of " { $link f } " being thrown, and no error being thrown. You should never throw " { $link f } ", and you should also use other error handling combinators where possible." } ;
{ catch cleanup recover } related-words
{ cleanup recover } related-words
HELP: cleanup
{ $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } }
@ -166,7 +160,7 @@ HELP: rethrow
{ $values { "error" object } }
{ $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." }
{ $notes
"This word is intended to be used in conjunction with " { $link recover } " or " { $link catch } " to implement error handlers which perform an action and pass the error to the next outermost error handler."
"This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler."
}
{ $examples
"The " { $link with-parser } " catches errors, annotates them with file name and line number information, and rethrows them:"

42
core/continuations/continuations-tests.factor
View File

@ -25,13 +25,11 @@ IN: temporary
[ t ] [ 10 callcc1-test 10 reverse >vector = ] unit-test
[ t ] [ callcc-namespace-test ] unit-test
[ f ] [ [ ] catch ] unit-test
[ 5 ] [ [ 5 throw ] catch ] unit-test
[ 5 throw ] [ 5 = ] must-fail-with
[ t ] [
[ "Hello" throw ] catch drop
global [ error get ] bind
[ "Hello" throw ] ignore-errors
error get-global
"Hello" =
] unit-test
@ -41,13 +39,13 @@ IN: temporary
"!!! The following error is part of the test" print
[ [ "2 car" ] eval ] catch print-error
[ ] [ [ [ "2 car" ] eval ] [ print-error ] recover ] unit-test
[ f throw ] unit-test-fails
[ f throw ] must-fail
! Weird PowerPC bug.
[ ] [
[ "4" throw ] catch drop
[ "4" throw ] ignore-errors
data-gc
data-gc
] unit-test
@ -56,10 +54,10 @@ IN: temporary
[ f ] [ { "A" "B" } kernel-error? ] unit-test
! ! See how well callstack overflow is handled
! [ clear drop ] unit-test-fails
! [ clear drop ] must-fail
!
! : callstack-overflow callstack-overflow f ;
! [ callstack-overflow ] unit-test-fails
! [ callstack-overflow ] must-fail
: don't-compile-me { } [ ] each ;
@ -84,24 +82,20 @@ SYMBOL: error-counter
[ 1 ] [ always-counter get ] unit-test
[ 0 ] [ error-counter get ] unit-test
[ "a" ] [
[
[ "a" throw ]
[ always-counter inc ]
[ error-counter inc ] cleanup
] catch
] unit-test
[
[ "a" throw ]
[ always-counter inc ]
[ error-counter inc ] cleanup
] [ "a" = ] must-fail-with
[ 2 ] [ always-counter get ] unit-test
[ 1 ] [ error-counter get ] unit-test
[ "a" ] [
[
[ ]
[ always-counter inc "a" throw ]
[ error-counter inc ] cleanup
] catch
] unit-test
[
[ ]
[ always-counter inc "a" throw ]
[ error-counter inc ] cleanup
] [ "a" = ] must-fail-with
[ 3 ] [ always-counter get ] unit-test
[ 1 ] [ error-counter get ] unit-test

10
core/continuations/continuations.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays vectors kernel kernel.private sequences
namespaces math splitting sorting quotations assocs ;
@ -17,9 +17,6 @@ SYMBOL: restarts
: c> ( -- continuation ) catchstack* pop ;
: (catch) ( quot -- newquot )
[ swap >c call c> drop ] curry ; inline
: dummy ( -- obj )
#! Optimizing compiler assumes stack won't be messed with
#! in-transit. To ensure that a value is actually reified
@ -120,11 +117,8 @@ PRIVATE>
catchstack* empty? [ die ] when
dup save-error c> continue-with ;
: catch ( try -- error/f )
(catch) [ f ] compose callcc1 ; inline
: recover ( try recovery -- )
>r (catch) r> ifcc ; inline
>r [ swap >c call c> drop ] curry r> ifcc ; inline
: cleanup ( try cleanup-always cleanup-error -- )
over >r compose [ dip rethrow ] curry

2
core/float-arrays/float-arrays-tests.factor
View File

@ -7,4 +7,4 @@ USING: float-arrays tools.test ;
[ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize-float-array ] unit-test
[ -10 F{ } resize-float-array ] unit-test-fails
[ -10 F{ } resize-float-array ] must-fail

5
core/generator/generator.factor
View File

@ -3,8 +3,9 @@
USING: arrays assocs classes combinators cpu.architecture
effects generator.fixup generator.registers generic hashtables
inference inference.backend inference.dataflow io kernel
kernel.private layouts math namespaces optimizer prettyprint
quotations sequences system threads words vectors ;
kernel.private layouts math namespaces optimizer
optimizer.specializers prettyprint quotations sequences system
threads words vectors ;
IN: generator
SYMBOL: compile-queue

45
core/generic/generic-tests.factor
View File

@ -16,7 +16,7 @@ M: word class-of drop "word" ;
[ "fixnum" ] [ 5 class-of ] unit-test
[ "word" ] [ \ class-of class-of ] unit-test
[ 3.4 class-of ] unit-test-fails
[ 3.4 class-of ] must-fail
[ "Hello world" ] [ 4 foobar foobar ] unit-test
[ "Goodbye cruel world" ] [ 4 foobar ] unit-test
@ -90,7 +90,7 @@ M: number union-containment drop 2 ;
"IN: temporary GENERIC: unhappy ( x -- x )" eval
[
"IN: temporary M: dictionary unhappy ;" eval
] unit-test-fails
] must-fail
[ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test
GENERIC# complex-combination 1 ( a b -- c )
@ -155,9 +155,7 @@ M: string my-hook "a string" ;
[ "an integer" ] [ 3 my-var set my-hook ] unit-test
[ "a string" ] [ my-hook my-var set my-hook ] unit-test
[ T{ no-method f 1.0 my-hook } ] [
1.0 my-var set [ my-hook ] catch
] unit-test
[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
GENERIC: tag-and-f ( x -- x x )
@ -203,3 +201,40 @@ TUPLE: redefinition-test-tuple ;
redefinition-test-generic ,
] { } make all-equal?
] unit-test
! Issues with forget
GENERIC: generic-forget-test-1
M: integer generic-forget-test-1 / ;
[ t ] [
\ / usage [ word? ] subset
[ word-name "generic-forget-test-1/integer" = ] contains?
] unit-test
[ ] [
[ \ generic-forget-test-1 forget ] with-compilation-unit
] unit-test
[ f ] [
\ / usage [ word? ] subset
[ word-name "generic-forget-test-1/integer" = ] contains?
] unit-test
GENERIC: generic-forget-test-2
M: sequence generic-forget-test-2 = ;
[ t ] [
\ = usage [ word? ] subset
[ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test
[ ] [
[ { sequence generic-forget-test-2 } forget ] with-compilation-unit
] unit-test
[ f ] [
\ = usage [ word? ] subset
[ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test

7
core/generic/generic.factor
View File

@ -102,7 +102,9 @@ M: method-spec definition
first2 method dup [ method-def ] when ;
: forget-method ( class generic -- )
check-method [ delete-at ] with-methods ;
check-method
[ delete-at* ] with-methods
[ method-word forget ] [ drop ] if ;
M: method-spec forget* first2 forget-method ;
@ -145,5 +147,8 @@ M: generic subwords
swap "default-method" word-prop add
[ method-word ] map ;
M: generic forget-word
dup subwords [ forget-word ] each (forget-word) ;
: xref-generics ( -- )
all-words [ subwords [ xref ] each ] each ;

8
core/growable/growable-tests.factor
View File

@ -9,16 +9,16 @@ IN: temporary
! overflow bugs
[ "hi" most-positive-fixnum 2 * 2 + V{ } clone set-nth ]
unit-test-fails
must-fail
[ most-positive-fixnum 2 * 2 + { 1 } clone nth ]
unit-test-fails
must-fail
[ most-positive-fixnum 2 * 2 + V{ } clone lengthen ]
unit-test-fails
must-fail
[ most-positive-fixnum 2 * 2 + V{ } clone set-length ]
unit-test-fails
must-fail
[ ] [
10 V{ } [ set-length ] keep

6
core/hashtables/hashtables-tests.factor
View File

@ -127,9 +127,9 @@ H{ } "x" set
! Another crash discovered by erg
[ ] [
H{ } clone
[ 1 swap set-at ] catch drop
[ 2 swap set-at ] catch drop
[ 3 swap set-at ] catch drop
[ 1 swap set-at ] ignore-errors
[ 2 swap set-at ] ignore-errors
[ 3 swap set-at ] ignore-errors
drop
] unit-test

4
core/heaps/heaps-tests.factor
View File

@ -5,8 +5,8 @@ USING: arrays kernel math namespaces tools.test
heaps heaps.private ;
IN: temporary
[ <min-heap> heap-pop ] unit-test-fails
[ <max-heap> heap-pop ] unit-test-fails
[ <min-heap> heap-pop ] must-fail
[ <max-heap> heap-pop ] must-fail
[ t ] [ <min-heap> heap-empty? ] unit-test
[ f ] [ <min-heap> 1 t pick heap-push heap-empty? ] unit-test

72
core/inference/inference-tests.factor
View File

@ -12,14 +12,14 @@ IN: temporary
{ 1 2 } [ dup ] unit-test-effect
{ 1 2 } [ [ dup ] call ] unit-test-effect
[ [ call ] infer ] unit-test-fails
[ [ call ] infer ] must-fail
{ 2 4 } [ 2dup ] unit-test-effect
{ 1 0 } [ [ ] [ ] if ] unit-test-effect
[ [ if ] infer ] unit-test-fails
[ [ [ ] if ] infer ] unit-test-fails
[ [ [ 2 ] [ ] if ] infer ] unit-test-fails
[ [ if ] infer ] must-fail
[ [ [ ] if ] infer ] must-fail
[ [ [ 2 ] [ ] if ] infer ] must-fail
{ 4 3 } [ [ rot ] [ -rot ] if ] unit-test-effect
{ 4 3 } [
@ -42,7 +42,7 @@ IN: temporary
[
[ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer
] unit-test-fails
] must-fail
! Test inference of termination of control flow
: termination-test-1
@ -54,10 +54,10 @@ IN: temporary
: infinite-loop infinite-loop ;
[ [ infinite-loop ] infer ] unit-test-fails
[ [ infinite-loop ] infer ] must-fail
: no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ;
[ [ no-base-case-1 ] infer ] unit-test-fails
[ [ no-base-case-1 ] infer ] must-fail
: simple-recursion-1 ( obj -- obj )
dup [ simple-recursion-1 ] [ ] if ;
@ -72,7 +72,7 @@ IN: temporary
: bad-recursion-2 ( obj -- obj )
dup [ dup first swap second bad-recursion-2 ] [ ] if ;
[ [ bad-recursion-2 ] infer ] unit-test-fails
[ [ bad-recursion-2 ] infer ] must-fail
: funny-recursion ( obj -- obj )
dup [ funny-recursion 1 ] [ 2 ] if drop ;
@ -192,7 +192,7 @@ DEFER: blah4
[ swap slip ] keep swap bad-combinator
] if ; inline
[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails
[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
! Regression
: bad-input#
@ -207,13 +207,13 @@ DEFER: blah4
DEFER: do-crap
: more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
: do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
[ [ do-crap ] infer ] unit-test-fails
[ [ do-crap ] infer ] must-fail
! This one does not
DEFER: do-crap*
: more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
: do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
[ [ do-crap* ] infer ] unit-test-fails
[ [ do-crap* ] infer ] must-fail
! Regression
: too-deep ( a b -- c )
@ -226,7 +226,7 @@ M: fixnum xyz 2array ;
M: float xyz
[ 3 ] 2apply swapd >r 2array swap r> 2array swap ;
[ t ] [ [ [ xyz ] infer ] catch inference-error? ] unit-test
[ [ xyz ] infer ] [ inference-error? ] must-fail-with
! Doug Coleman discovered this one while working on the
! calendar library
@ -277,78 +277,66 @@ DEFER: #1
: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
[ \ #4 word-def infer ] unit-test-fails
[ [ #1 ] infer ] unit-test-fails
[ \ #4 word-def infer ] must-fail
[ [ #1 ] infer ] must-fail
! Similar
DEFER: bar
: foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
: bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
[ [ foo ] infer ] unit-test-fails
[ [ foo ] infer ] must-fail
[ 1234 infer ] unit-test-fails
[ 1234 infer ] must-fail
! This used to hang
[ t ] [
[ [ [ dup call ] dup call ] infer ] catch
inference-error?
] unit-test
[ [ [ dup call ] dup call ] infer ]
[ inference-error? ] must-fail-with
: m dup call ; inline
[ t ] [
[ [ [ m ] m ] infer ] catch inference-error?
] unit-test
[ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with
: m' dup curry call ; inline
[ t ] [
[ [ [ m' ] m' ] infer ] catch inference-error?
] unit-test
[ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with
: m'' [ dup curry ] ; inline
: m''' m'' call call ; inline
[ t ] [
[ [ [ m''' ] m''' ] infer ] catch inference-error?
] unit-test
[ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with
: m-if t over if ; inline
[ t ] [
[ [ [ m-if ] m-if ] infer ] catch inference-error?
] unit-test
[ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with
! This doesn't hang but it's also an example of the
! undedicable case
[ t ] [
[ [ [ [ drop 3 ] swap call ] dup call ] infer ] catch
inference-error?
] unit-test
[ [ [ [ drop 3 ] swap call ] dup call ] infer ]
[ inference-error? ] must-fail-with
! This form should not have a stack effect
: bad-recursion-1 ( a -- b )
dup [ drop bad-recursion-1 5 ] [ ] if ;
[ [ bad-recursion-1 ] infer ] unit-test-fails
[ [ bad-recursion-1 ] infer ] must-fail
: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
[ [ bad-bin ] infer ] unit-test-fails
[ [ bad-bin ] infer ] must-fail
[ t ] [ [ [ r> ] infer ] catch inference-error? ] unit-test
[ [ r> ] infer ] [ inference-error? ] must-fail-with
! Regression
[ t ] [ [ [ get-slots ] infer ] catch inference-error? ] unit-test
[ [ get-slots ] infer ] [ inference-error? ] must-fail-with
! Test some curry stuff
{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect
{ 2 1 } [ [ ] curry 4 [ ] curry if ] unit-test-effect
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] unit-test-fails
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
! Test number protocol
\ bitor must-infer
@ -459,7 +447,7 @@ DEFER: bar
: fooxxx ( a b -- c ) over [ foo ] when ; inline
: barxxx fooxxx ;
[ [ barxxx ] infer ] unit-test-fails
[ [ barxxx ] infer ] must-fail
! A typo
{ 1 0 } [ { [ ] } dispatch ] unit-test-effect

2
core/inference/transforms/transforms-tests.factor
View File

@ -31,4 +31,4 @@ TUPLE: a-tuple x y z ;
: set-slots-test-2
{ set-a-tuple-x set-a-tuple-x } set-slots ;
[ [ set-slots-test-2 ] infer ] unit-test-fails
[ [ set-slots-test-2 ] infer ] must-fail

4
core/io/streams/duplex/duplex-tests.factor
View File

@ -28,13 +28,13 @@ M: unclosable-stream dispose
[ t ] [
<unclosable-stream> <closing-stream> [
<duplex-stream>
[ dup dispose ] catch 2drop
[ dup dispose ] [ 2drop ] recover
] keep closing-stream-closed?
] unit-test
[ t ] [
<closing-stream> [ <unclosable-stream>
<duplex-stream>
[ dup dispose ] catch 2drop
[ dup dispose ] [ 2drop ] recover
] keep closing-stream-closed?
] unit-test

46
core/kernel/kernel-tests.factor
View File

@ -7,25 +7,22 @@ IN: temporary
[ t ] [ [ \ = \ = ] all-equal? ] unit-test
! Don't leak extra roots if error is thrown
[ ] [ 10000 [ [ 3 throw ] catch drop ] times ] unit-test
[ ] [ 10000 [ [ 3 throw ] ignore-errors ] times ] unit-test
[ ] [ 10000 [ [ -1 f <array> ] catch drop ] times ] unit-test
[ ] [ 10000 [ [ -1 f <array> ] ignore-errors ] times ] unit-test
! Make sure we report the correct error on stack underflow
[ { "kernel-error" 11 f f } ]
[ [ clear drop ] catch ] unit-test
[ clear drop ] [ { "kernel-error" 11 f f } = ] must-fail-with
[ ] [ :c ] unit-test
[ { "kernel-error" 13 f f } ]
[ [ { } set-retainstack r> ] catch ] unit-test
[ { } set-retainstack r> ] [ { "kernel-error" 13 f f } = ] must-fail-with
[ ] [ :c ] unit-test
: overflow-d 3 overflow-d ;
[ { "kernel-error" 12 f f } ]
[ [ overflow-d ] catch ] unit-test
[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with
[ ] [ :c ] unit-test
@ -33,24 +30,17 @@ IN: temporary
: overflow-d-alt (overflow-d-alt) overflow-d-alt ;
[ { "kernel-error" 12 f f } ]
[ [ overflow-d-alt ] catch ] unit-test
[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with
[ ] [ [ :c ] string-out drop ] unit-test
: overflow-r 3 >r overflow-r ;
[ { "kernel-error" 14 f f } ]
[ [ overflow-r ] catch ] unit-test
[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with
[ ] [ :c ] unit-test
! : overflow-c overflow-c 3 ;
!
! [ { "kernel-error" 16 f f } ]
! [ [ overflow-c ] catch ] unit-test
[ -7 <byte-array> ] unit-test-fails
[ -7 <byte-array> ] must-fail
[ 2 3 4 1 ] [ 1 2 3 4 roll ] unit-test
[ 1 2 3 4 ] [ 2 3 4 1 -roll ] unit-test
@ -61,27 +51,27 @@ IN: temporary
[ 4 ] [ 4 6 or ] unit-test
[ 6 ] [ f 6 or ] unit-test
[ slip ] unit-test-fails
[ slip ] must-fail
[ ] [ :c ] unit-test
[ 1 slip ] unit-test-fails
[ 1 slip ] must-fail
[ ] [ :c ] unit-test
[ 1 2 slip ] unit-test-fails
[ 1 2 slip ] must-fail
[ ] [ :c ] unit-test
[ 1 2 3 slip ] unit-test-fails
[ 1 2 3 slip ] must-fail
[ ] [ :c ] unit-test
[ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test
[ [ ] keep ] unit-test-fails
[ [ ] keep ] must-fail
[ 6 ] [ 2 [ sq ] keep + ] unit-test
[ [ ] 2keep ] unit-test-fails
[ 1 [ ] 2keep ] unit-test-fails
[ [ ] 2keep ] must-fail
[ 1 [ ] 2keep ] must-fail
[ 3 1 2 ] [ 1 2 [ 2drop 3 ] 2keep ] unit-test
[ 0 ] [ f [ sq ] [ 0 ] if* ] unit-test
@ -100,13 +90,13 @@ IN: temporary
[ ] [ callstack set-callstack ] unit-test
[ 3drop datastack ] unit-test-fails
[ 3drop datastack ] must-fail
[ ] [ :c ] unit-test
! Doesn't compile; important
: foo 5 + 0 [ ] each ;
[ drop foo ] unit-test-fails
[ drop foo ] must-fail
[ ] [ :c ] unit-test
! Regression
@ -117,4 +107,4 @@ IN: temporary
: loop ( obj obj -- )
H{ } values swap >r dup length swap r> 0 -roll (loop) ;
[ loop ] unit-test-fails
[ loop ] must-fail

4
core/listener/listener-tests.factor
View File

@ -22,7 +22,7 @@ IN: temporary
[
"\\ + 1 2 3 4" parse-interactive
"cont" get continue-with
] catch
] ignore-errors
"USE: debugger :1" eval
] callcc1
] unit-test
@ -36,7 +36,7 @@ IN: temporary
[
"USE: vocabs.loader.test.c" parse-interactive
] unit-test-fails
] must-fail
[ ] [
[

4
core/math/integers/integers-tests.factor
View File

@ -121,8 +121,8 @@ unit-test
! We don't care if this fails or returns 0 (its CPU-specific)
! as long as it doesn't crash
[ ] [ [ 0 0 /i ] catch clear ] unit-test
[ ] [ [ 100000000000000000 0 /i ] catch clear ] unit-test
[ ] [ [ 0 0 /i drop ] ignore-errors ] unit-test
[ ] [ [ 100000000000000000 0 /i drop ] ignore-errors ] unit-test
[ -2 ] [ 1 bitnot ] unit-test
[ -2 ] [ 1 >bignum bitnot ] unit-test

6
core/math/parser/parser-tests.factor
View File

@ -105,6 +105,6 @@ unit-test
! [ dup number>string string>number = ] all?
! ] unit-test
[ 1 1 >base ] unit-test-fails
[ 1 0 >base ] unit-test-fails
[ 1 -1 >base ] unit-test-fails
[ 1 1 >base ] must-fail
[ 1 0 >base ] must-fail
[ 1 -1 >base ] must-fail

2
core/memory/memory-tests.factor
View File

@ -4,7 +4,7 @@ IN: temporary
TUPLE: testing x y z ;
[ save-image-and-exit ] unit-test-fails
[ save-image-and-exit ] must-fail
[ ] [
num-types get [

26
core/optimizer/backend/backend.factor
View File

@ -4,7 +4,7 @@ USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.pattern-match generic.standard ;
optimizer.pattern-match generic.standard optimizer.specializers ;
IN: optimizer.backend
SYMBOL: class-substitutions
@ -245,18 +245,32 @@ M: #dispatch optimize-node*
: dispatching-class ( node word -- class )
[ dispatch# node-class# ] keep specific-method ;
: flat-length ( seq -- n )
! A heuristic to avoid excessive inlining
DEFER: (flat-length)
: word-flat-length ( word -- n )
dup get over inline? not or
[ drop 1 ] [ dup dup set word-def (flat-length) ] if ;
: (flat-length) ( seq -- n )
[
dup quotation? over array? or
[ flat-length ] [ drop 1 ] if
{
{ [ dup quotation? ] [ (flat-length) 1+ ] }
{ [ dup array? ] [ (flat-length) ] }
{ [ dup word? ] [ word-flat-length ] }
{ [ t ] [ drop 1 ] }
} cond
] map sum ;
: flat-length ( seq -- n )
[ word-def (flat-length) ] with-scope ;
: will-inline-method ( node word -- method-spec/t quot/t )
#! t indicates failure
tuck dispatching-class dup [
swap [ 2array ] 2keep
method method-word
dup word-def flat-length 6 >=
dup flat-length 10 >=
[ 1quotation ] [ word-def ] if
] [
2drop t t
@ -363,7 +377,7 @@ M: #dispatch optimize-node*
: optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [
>r node-input-classes r> length tail*
>r node-input-classes r> specialized-length tail*
[ types length 1 = ] all?
] [
2drop f

16
core/optimizer/known-words/known-words.factor
View File

@ -124,19 +124,19 @@ float-arrays combinators.private combinators ;
] each
\ push-all
{ { string array } { sbuf vector } }
{ { string sbuf } { array vector } }
"specializer" set-word-prop
\ append
{ { string array } { string array } }
{ { string string } { array array } }
"specializer" set-word-prop
\ subseq
{ fixnum fixnum { string array } }
{ { fixnum fixnum string } { fixnum fixnum array } }
"specializer" set-word-prop
\ reverse-here
{ { string array } }
{ { string } { array } }
"specializer" set-word-prop
\ mismatch
@ -147,9 +147,9 @@ float-arrays combinators.private combinators ;
\ >string { sbuf } "specializer" set-word-prop
\ >array { { string vector } } "specializer" set-word-prop
\ >array { { string } { vector } } "specializer" set-word-prop
\ >vector { { array vector } } "specializer" set-word-prop
\ >vector { { array } { vector } } "specializer" set-word-prop
\ >sbuf { string } "specializer" set-word-prop
@ -163,6 +163,6 @@ float-arrays combinators.private combinators ;
\ assoc-stack { vector } "specializer" set-word-prop
\ >le { { fixnum bignum } fixnum } "specializer" set-word-prop
\ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop
\ >be { { fixnum bignum } fixnum } "specializer" set-word-prop
\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop

29
core/optimizer/optimizer-docs.factor Normal file → Executable file
View File

@ -2,31 +2,6 @@ USING: help.markup help.syntax quotations words math
sequences ;
IN: optimizer
ARTICLE: "specializers" "Word specializers"
"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class."
$nl
"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is a sequence having the same number of elements as the word has inputs; each element takes one of the following forms and gives the compiler a hint about the corresponding parameter:"
{ $table
{ { $snippet { $emphasis "class" } } { "a class word indicates that this parameter is expected to be an instance of the class most of the time." } }
{ { $snippet "{ " { $emphasis "classes..." } " }" } { "a sequence of class words indicates that this parameter is expected to be an instance of one of these classes most of the time." } }
{ { $snippet "number" } { "the " { $link number } " class word has a special behavior. It will result in a version of the word being generated for every primitive numeric type, where this parameter is assumed to have that type. A fast jump table will then determine which version is chosen at run time." } }
{ { $snippet "*" } { "indicates no specialization should be performed on this parameter." } }
}
"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place."
$nl
"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information."
$nl
"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class."
$nl
"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
{ $code
"\\ append"
"{ { string array } { string array } }"
"\"specializer\" set-word-prop"
}
"The specialized version of a word which will be compiled by the compiler can be inspected:"
{ $subsection specialized-def } ;
ARTICLE: "optimizer" "Optimizer"
"The words in the " { $vocab-link "optimizer" } " vocabulary are internal to the compiler and user code has no reason to call them."
$nl
@ -43,7 +18,3 @@ HELP: optimize-1
HELP: optimize
{ $values { "node" "a dataflow graph" } { "newnode" "a dataflow graph" } }
{ $description "Continues to optimize a dataflow graph until a fixed point is reached." } ;
HELP: specialized-def
{ $values { "word" word } { "quot" quotation } }
{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;

43
core/optimizer/optimizer.factor Normal file → Executable file
View File

@ -1,10 +1,7 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private math
namespaces sequences vectors words strings layouts combinators
combinators.private classes optimizer.backend optimizer.def-use
optimizer.known-words optimizer.math inference.class
generic.standard ;
USING: kernel namespaces optimizer.backend optimizer.def-use
optimizer.known-words optimizer.math inference.class ;
IN: optimizer
: optimize-1 ( node -- newnode ? )
@ -22,39 +19,3 @@ IN: optimizer
: optimize ( node -- newnode )
optimize-1 [ optimize ] when ;
: simple-specializer ( quot dispatch# classes -- quot )
swap (dispatch#) [
object add* swap [ 2array ] curry map
object method-alist>quot
] with-variable ;
: dispatch-specializer ( quot dispatch# symbol dispatcher -- quot )
rot (dispatch#) [
[
picker %
,
get swap <array> ,
\ dispatch ,
] [ ] make
] with-variable ;
: tag-specializer ( quot dispatch# -- quot )
num-tags \ tag dispatch-specializer ;
: type-specializer ( quot dispatch# -- quot )
num-types \ type dispatch-specializer ;
: make-specializer ( quot dispatch# spec -- quot )
{
{ [ dup number eq? ] [ drop tag-specializer ] }
{ [ dup object eq? ] [ drop type-specializer ] }
{ [ dup \ * eq? ] [ 2drop ] }
{ [ dup array? ] [ simple-specializer ] }
{ [ t ] [ 1array simple-specializer ] }
} cond ;
: specialized-def ( word -- quot )
dup word-def swap "specializer" word-prop [
[ length ] keep <reversed> [ make-specializer ] 2each
] when* ;

26
core/optimizer/specializers/specializers-docs.factor Executable file
View File

@ -0,0 +1,26 @@
IN: optimizer.specializers
USING: help.markup help.syntax sequences words quotations ;
ARTICLE: "specializers" "Word specializers"
"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class."
$nl
"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is either a sequence of classes, or a sequence of sequences of classes. Each element in the sequence (or the sequence itself, in the former case) is a specialization hint."
$nl
"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place."
$nl
"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information."
$nl
"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class."
$nl
"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
{ $code
"\\ append"
"{ { string string } { array array } }"
"\"specializer\" set-word-prop"
}
"The specialized version of a word which will be compiled by the compiler can be inspected:"
{ $subsection specialized-def } ;
HELP: specialized-def
{ $values { "word" word } { "quot" quotation } }
{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;

41
core/optimizer/specializers/specializers.factor Executable file
View File

@ -0,0 +1,41 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private math
namespaces sequences vectors words strings layouts combinators
combinators.private classes generic.standard assocs ;
IN: optimizer.specializers
: (make-specializer) ( class picker -- quot )
swap "predicate" word-prop append ;
: make-specializer ( classes -- quot )
dup length <reversed>
[ (picker) 2array ] 2map
[ drop object eq? not ] assoc-subset
dup empty? [ drop [ t ] ] [
[ (make-specializer) ] { } assoc>map
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if ;
: tag-specializer ( quot -- newquot )
[
[ dup tag ] %
num-tags get swap <array> ,
\ dispatch ,
] [ ] make ;
: specialized-def ( word -- quot )
dup word-def swap "specializer" word-prop [
dup { number } = [
drop tag-specializer
] [
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
[ declare ] curry pick append
] { } map>assoc
alist>quot
] if
] when* ;
: specialized-length ( specializer -- n )
dup [ array? ] all? [ first ] when length ;

6
core/parser/parser-docs.factor
View File

@ -136,8 +136,6 @@ ARTICLE: "parser-lexer" "The lexer"
{ $subsection <lexer> }
"A word to test of the end of input has been reached:"
{ $subsection still-parsing? }
"A word to get the text of the current line:"
{ $subsection line-text }
"A word to advance the lexer to the next line:"
{ $subsection next-line }
"Two generic words to override the lexer's token boundary detection:"
@ -222,10 +220,6 @@ HELP: <parse-error>
{ $values { "msg" "an error" } { "error" parse-error } }
{ $description "Creates a new " { $link parse-error } ", filling in the location information from the current " { $link lexer } "." } ;
HELP: line-text
{ $values { "lexer" lexer } { "str" string } }
{ $description "Outputs the text of the line being parsed." } ;
HELP: skip
{ $values { "i" "a starting index" } { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "n" integer } }
{ $description "Variant of " { $link find* } " that outputs the length of the sequence instead of " { $link f } " if no elements satisfy the predicate." } ;

78
core/parser/parser-tests.factor
View File

@ -93,12 +93,12 @@ IN: temporary
! Funny bug
[ 2 ] [ "IN: temporary : \0. 2 ; \0." eval ] unit-test
[ "IN: temporary : missing-- ( a b ) ;" eval ] unit-test-fails
[ "IN: temporary : missing-- ( a b ) ;" eval ] must-fail
! These should throw errors
[ "HEX: zzz" eval ] unit-test-fails
[ "OCT: 999" eval ] unit-test-fails
[ "BIN: --0" eval ] unit-test-fails
[ "HEX: zzz" eval ] must-fail
[ "OCT: 999" eval ] must-fail
[ "BIN: --0" eval ] must-fail
! Another funny bug
[ t ] [
@ -205,12 +205,10 @@ IN: temporary
"a" source-files get delete-at
[ t ] [
[
"IN: temporary : x ; : y 3 throw ; this is an error"
<string-reader> "a" parse-stream
] catch parse-error?
] unit-test
[
"IN: temporary : x ; : y 3 throw ; this is an error"
<string-reader> "a" parse-stream
] [ parse-error? ] must-fail-with
[ t ] [
"y" "temporary" lookup >boolean
@ -307,62 +305,50 @@ IN: temporary
"killer?" "temporary" lookup >boolean
] unit-test
[ t ] [
[
"IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?"
<string-reader> "removing-the-predicate" parse-stream
] catch [ redefine-error? ] is?
] unit-test
[
"IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?"
<string-reader> "removing-the-predicate" parse-stream
] [ [ redefine-error? ] is? ] must-fail-with
[ t ] [
[
"IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
<string-reader> "redefining-a-class-1" parse-stream
] catch [ redefine-error? ] is?
] unit-test
[
"IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
<string-reader> "redefining-a-class-1" parse-stream
] [ [ redefine-error? ] is? ] must-fail-with
[ ] [
"IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test"
<string-reader> "redefining-a-class-2" parse-stream drop
] unit-test
[ t ] [
[
"IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop
] catch [ redefine-error? ] is?
] unit-test
[
"IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop
] [ [ redefine-error? ] is? ] must-fail-with
[ ] [
"IN: temporary TUPLE: class-fwd-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop
] unit-test
[ t ] [
[
"IN: temporary \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
] catch [ no-word? ] is?
] unit-test
[
"IN: temporary \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
] [ [ no-word? ] is? ] must-fail-with
[ ] [
"IN: temporary TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
] unit-test
[ t ] [
[
"IN: temporary \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
] catch [ no-word? ] is?
] unit-test
[
"IN: temporary \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
] [ [ no-word? ] is? ] must-fail-with
[ t ] [
[
"IN: temporary : foo ; TUPLE: foo ;"
<string-reader> "redefining-a-class-4" parse-stream drop
] catch [ redefine-error? ] is?
] unit-test
[
"IN: temporary : foo ; TUPLE: foo ;"
<string-reader> "redefining-a-class-4" parse-stream drop
] [ [ redefine-error? ] is? ] must-fail-with
] with-file-vocabs
[

47
core/parser/parser.factor
View File

@ -8,12 +8,17 @@ io.files io.streams.string io.streams.lines vocabs
source-files classes hashtables compiler.errors compiler.units ;
IN: parser
TUPLE: lexer text line column ;
TUPLE: lexer text line line-text line-length column ;
: <lexer> ( text -- lexer ) 1 0 lexer construct-boa ;
: next-line ( lexer -- )
0 over set-lexer-column
dup lexer-line over lexer-text ?nth over set-lexer-line-text
dup lexer-line-text length over set-lexer-line-length
dup lexer-line 1+ swap set-lexer-line ;
: line-text ( lexer -- str )
dup lexer-line 1- swap lexer-text ?nth ;
: <lexer> ( text -- lexer )
0 { set-lexer-text set-lexer-line } lexer construct
dup lexer-text empty? [ dup next-line ] unless ;
: location ( -- loc )
file get lexer get lexer-line 2dup and
@ -50,18 +55,14 @@ t parser-notes set-global
"Note: " write dup print
] when drop ;
: next-line ( lexer -- )
0 over set-lexer-column
dup lexer-line 1+ swap set-lexer-line ;
: skip ( i seq ? -- n )
over >r
[ swap CHAR: \s eq? xor ] curry find* drop
[ r> drop ] [ r> length ] if* ; inline
[ r> drop ] [ r> length ] if* ;
: change-column ( lexer quot -- )
swap
[ dup lexer-column swap line-text rot call ] keep
[ dup lexer-column swap lexer-line-text rot call ] keep
set-lexer-column ; inline
GENERIC: skip-blank ( lexer -- )
@ -73,20 +74,20 @@ GENERIC: skip-word ( lexer -- )
M: lexer skip-word ( lexer -- )
[
2dup nth CHAR: " = [ drop 1+ ] [ f skip ] if
2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
] change-column ;
: still-parsing? ( lexer -- ? )
dup lexer-line swap lexer-text length <= ;
: still-parsing-line? ( lexer -- ? )
dup lexer-column swap line-text length < ;
dup lexer-column swap lexer-line-length < ;
: (parse-token) ( lexer -- str )
[ lexer-column ] keep
[ skip-word ] keep
[ lexer-column ] keep
line-text subseq ;
lexer-line-text subseq ;
: parse-token ( lexer -- str/f )
dup still-parsing? [
@ -139,9 +140,8 @@ TUPLE: parse-error file line col text ;
: <parse-error> ( msg -- error )
file get
lexer get lexer-line
lexer get lexer-column
lexer get line-text
lexer get
{ lexer-line lexer-column lexer-line-text } get-slots
parse-error construct-boa
[ set-delegate ] keep ;
@ -239,22 +239,25 @@ M: no-word summary
word-restarts throw-restarts
dup word-vocabulary (use+) ;
: check-forward ( str word -- word )
: check-forward ( str word -- word/f )
dup forward-reference? [
drop
dup use get
use get
[ at ] with map [ ] subset
[ forward-reference? not ] find nip
[ ] [ no-word ] ?if
] [
nip
] if ;
: search ( str -- word )
dup use get assoc-stack [ check-forward ] [ no-word ] if* ;
: search ( str -- word/f )
dup use get assoc-stack check-forward ;
: scan-word ( -- word/number/f )
scan dup [ dup string>number [ ] [ search ] ?if ] when ;
scan dup [
dup search [ ] [
dup string>number [ ] [ no-word ] ?if
] ?if
] when ;
TUPLE: staging-violation word ;

2
core/quotations/quotations-tests.factor
View File

@ -15,4 +15,4 @@ IN: temporary
[ [ "hi" ] ] [ "hi" 1quotation ] unit-test
[ 1 \ + curry ] unit-test-fails
[ 1 \ + curry ] must-fail

20
core/sequences/sequences-tests.factor
View File

@ -83,8 +83,8 @@ unit-test
[ [ 1 2 3 4 ] ] [ [ 1 2 3 ] [ 4 ] append ] unit-test
[ [ 1 2 3 4 ] ] [ [ 1 2 3 ] { 4 } append ] unit-test
[ "a" -1 append ] unit-test-fails
[ -1 "a" append ] unit-test-fails
[ "a" -1 append ] must-fail
[ -1 "a" append ] must-fail
[ [ ] ] [ 1 [ ] remove ] unit-test
[ [ ] ] [ 1 [ 1 ] remove ] unit-test
@ -119,7 +119,7 @@ unit-test
[ V{ 0 1 4 5 } ] [ 6 >vector 2 4 pick delete-slice ] unit-test
[ 6 >vector 2 8 pick delete-slice ] unit-test-fails
[ 6 >vector 2 8 pick delete-slice ] must-fail
[ V{ } ] [ 6 >vector 0 6 pick delete-slice ] unit-test
@ -173,7 +173,7 @@ unit-test
[ V{ "C" } V{ "c" } ] [ { "a" "b" "C" } { "a" "b" "c" } drop-prefix [ >vector ] 2apply ] unit-test
[ -1 1 "abc" <slice> ] unit-test-fails
[ -1 1 "abc" <slice> ] must-fail
[ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] 2apply ] unit-test
@ -195,8 +195,8 @@ unit-test
! Pathological case
[ "ihbye" ] [ "hi" <reversed> "bye" append ] unit-test
[ -10 "hi" "bye" copy ] unit-test-fails
[ 10 "hi" "bye" copy ] unit-test-fails
[ -10 "hi" "bye" copy ] must-fail
[ 10 "hi" "bye" copy ] must-fail
[ V{ 1 2 3 5 6 } ] [
3 V{ 1 2 3 4 5 6 } clone [ delete-nth ] keep
@ -228,13 +228,13 @@ unit-test
[ SBUF" \0\0\0" ] [ 3 SBUF" " new ] unit-test
[ 0 ] [ f length ] unit-test
[ f first ] unit-test-fails
[ f first ] must-fail
[ 3 ] [ 3 10 nth ] unit-test
[ 3 ] [ 3 10 nth-unsafe ] unit-test
[ -3 10 nth ] unit-test-fails
[ 11 10 nth ] unit-test-fails
[ -3 10 nth ] must-fail
[ 11 10 nth ] must-fail
[ -1./0. 0 delete-nth ] unit-test-fails
[ -1./0. 0 delete-nth ] must-fail
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
[ "" ] [ "" [ CHAR: \s = ] left-trim ] unit-test
[ "" ] [ "" [ CHAR: \s = ] right-trim ] unit-test

2
core/source-files/source-files.factor
View File

@ -38,7 +38,7 @@ uses definitions ;
: (xref-source) ( source-file -- pathname uses )
dup source-file-path <pathname> swap source-file-uses
[ interned? ] subset ;
[ crossref? ] subset ;
: xref-source ( source-file -- )
(xref-source) crossref get add-vertex ;

2
core/splitting/splitting-tests.factor
View File

@ -1,7 +1,7 @@
USING: splitting tools.test ;
IN: temporary
[ { 1 2 3 } 0 group ] unit-test-fails
[ { 1 2 3 } 0 group ] must-fail
[ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test

11
core/strings/strings-tests.factor
View File

@ -4,7 +4,7 @@ IN: temporary
[ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test
[ ] [ 10 [ [ -1000000 <sbuf> ] catch drop ] times ] unit-test
[ ] [ 10 [ [ -1000000 <sbuf> ] ignore-errors ] times ] unit-test
[ "abc" ] [ [ "a" "b" "c" ] [ [ % ] each ] "" make ] unit-test
@ -31,7 +31,7 @@ IN: temporary
[ t ] [ "abc" "abd" <=> 0 < ] unit-test
[ t ] [ "z" "abd" <=> 0 > ] unit-test
[ f ] [ [ 0 10 "hello" subseq ] catch not ] unit-test
[ 0 10 "hello" subseq ] must-fail
[ "Replacing+spaces+with+plus" ]
[
@ -43,8 +43,8 @@ unit-test
[ "05" ] [ "5" 2 CHAR: 0 pad-left ] unit-test
[ "666" ] [ "666" 2 CHAR: 0 pad-left ] unit-test
[ 1 "" nth ] unit-test-fails
[ -6 "hello" nth ] unit-test-fails
[ 1 "" nth ] must-fail
[ -6 "hello" nth ] must-fail
[ t ] [ "hello world" dup >vector >string = ] unit-test
@ -55,8 +55,7 @@ unit-test
[ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test
! Random tester found this
[ { "kernel-error" 3 12 -7 } ]
[ [ 2 -7 resize-string ] catch ] unit-test
[ 2 -7 resize-string ] [ { "kernel-error" 3 12 -7 } = ] must-fail-with
! Make sure 24-bit strings work
"hello world" "s" set

2
core/threads/threads-tests.factor
View File

@ -9,4 +9,4 @@ IN: temporary
yield
[ ] [ 0.3 sleep ] unit-test
[ "hey" sleep ] unit-test-fails
[ "hey" sleep ] must-fail

20
core/tuples/tuples-tests.factor
View File

@ -55,7 +55,7 @@ C: <point> point
"IN: temporary TUPLE: point z y ;" eval
[ "p" get point-x ] unit-test-fails
[ "p" get point-x ] must-fail
[ 200 ] [ "p" get point-y ] unit-test
[ 300 ] [ "p" get "point-z" "temporary" lookup execute ] unit-test
@ -97,7 +97,7 @@ TUPLE: delegate-clone ;
[ f ] [ \ tuple \ delegate-clone class< ] unit-test
! Compiler regression
[ t ] [ [ t length ] catch no-method-object ] unit-test
[ t length ] [ no-method-object t eq? ] must-fail-with
[ "<constructor-test>" ]
[ "TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
@ -123,7 +123,7 @@ TUPLE: yo-momma ;
[ ] [ \ yo-momma forget ] unit-test
[ f ] [ \ yo-momma typemap get values memq? ] unit-test
[ f ] [ \ yo-momma interned? ] unit-test
[ f ] [ \ yo-momma crossref get at ] unit-test
] with-compilation-unit
TUPLE: loc-recording ;
@ -204,15 +204,15 @@ SYMBOL: not-a-tuple-class
[
"IN: temporary C: <not-a-tuple-class> not-a-tuple-class"
eval
] unit-test-fails
] must-fail
[ t ] [
"not-a-tuple-class" "temporary" lookup symbol?
] unit-test
! Missing check
[ not-a-tuple-class construct-boa ] unit-test-fails
[ not-a-tuple-class construct-empty ] unit-test-fails
[ not-a-tuple-class construct-boa ] must-fail
[ not-a-tuple-class construct-empty ] must-fail
TUPLE: erg's-reshape-problem a b c d ;
@ -234,8 +234,6 @@ C: <erg's-reshape-problem> erg's-reshape-problem
[ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test
[ t ] [
[
"IN: temporary SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] catch [ check-tuple? ] is?
] unit-test
[
"IN: temporary SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] [ [ check-tuple? ] is? ] must-fail-with

20
core/vectors/vectors-tests.factor
View File

@ -3,25 +3,25 @@ sequences sequences.private strings tools.test vectors
continuations random growable classes ;
IN: temporary
[ ] [ 10 [ [ -1000000 <vector> ] catch drop ] times ] unit-test
[ ] [ 10 [ [ -1000000 <vector> ] ignore-errors ] times ] unit-test
[ 3 ] [ [ t f t ] length ] unit-test
[ 3 ] [ V{ t f t } length ] unit-test
[ -3 V{ } nth ] unit-test-fails
[ 3 V{ } nth ] unit-test-fails
[ 3 54.3 nth ] unit-test-fails
[ -3 V{ } nth ] must-fail
[ 3 V{ } nth ] must-fail
[ 3 54.3 nth ] must-fail
[ "hey" [ 1 2 ] set-length ] unit-test-fails
[ "hey" V{ 1 2 } set-length ] unit-test-fails
[ "hey" [ 1 2 ] set-length ] must-fail
[ "hey" V{ 1 2 } set-length ] must-fail
[ 3 ] [ 3 0 <vector> [ set-length ] keep length ] unit-test
[ "yo" ] [
"yo" 4 1 <vector> [ set-nth ] keep 4 swap nth
] unit-test
[ 1 V{ } nth ] unit-test-fails
[ -1 V{ } set-length ] unit-test-fails
[ 1 V{ } nth ] must-fail
[ -1 V{ } set-length ] must-fail
[ V{ } ] [ [ ] >vector ] unit-test
[ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test
@ -64,8 +64,8 @@ IN: temporary
[ V{ 2 3 } ] [ "funny-stack" get pop ] unit-test
[ V{ 1 5 } ] [ "funny-stack" get peek ] unit-test
[ V{ 1 5 } ] [ "funny-stack" get pop ] unit-test
[ "funny-stack" get pop ] unit-test-fails
[ "funny-stack" get pop ] unit-test-fails
[ "funny-stack" get pop ] must-fail
[ "funny-stack" get pop ] must-fail
[ ] [ "funky" "funny-stack" get push ] unit-test
[ "funky" ] [ "funny-stack" get pop ] unit-test

31
core/vocabs/loader/loader-tests.factor
View File

@ -18,16 +18,6 @@ debugger compiler.units ;
[ t ]
[ "kernel" f >vocab-link "kernel" vocab = ] unit-test
! This vocab should not exist, but just in case...
[ ] [ [ "core" forget-vocab ] with-compilation-unit ] unit-test
2 [
[ T{ no-vocab f "core" } ]
[ [ "core" require ] catch ] unit-test
] times
[ f ] [ "core" vocab ] unit-test
[ t ] [
"kernel" vocab-files
"kernel" vocab vocab-files
@ -59,7 +49,7 @@ IN: temporary
0 "count-me" set-global
2 [
[ "vocabs.loader.test.a" require ] unit-test-fails
[ "vocabs.loader.test.a" require ] must-fail
[ f ] [ "vocabs.loader.test.a" vocab-source-loaded? ] unit-test
@ -73,14 +63,12 @@ IN: temporary
[ 2 ] [ "count-me" get-global ] unit-test
[ t ] [
[
"IN: vocabs.loader.test.a v-l-t-a-hello"
<string-reader>
"resource:core/vocabs/loader/test/a/a.factor"
parse-stream
] catch [ no-word? ] is?
] unit-test
[
"IN: vocabs.loader.test.a v-l-t-a-hello"
<string-reader>
"resource:core/vocabs/loader/test/a/a.factor"
parse-stream
] [ [ no-word? ] is? ] must-fail-with
0 "count-me" set-global
@ -97,7 +85,7 @@ IN: temporary
] with-compilation-unit
] unit-test
[ "vocabs.loader.test.b" require ] unit-test-fails
[ "vocabs.loader.test.b" require ] must-fail
[ 1 ] [ "count-me" get-global ] unit-test
@ -131,8 +119,7 @@ IN: temporary
[ "kernel" vocab where ] unit-test
[ t ] [
[ "vocabs.loader.test.d" require ] catch
[ :1 ] when
[ "vocabs.loader.test.d" require ] [ :1 ] recover
"vocabs.loader.test.d" vocab-source-loaded?
] unit-test

2
core/vocabs/vocabs-docs.factor Normal file → Executable file
View File

@ -76,7 +76,7 @@ HELP: all-words
HELP: forget-vocab
{ $values { "vocab" string } }
{ $description "Removes a vocabulary. All words in the vocabulary become uninterned." }
{ $description "Removes a vocabulary. All words in the vocabulary are forgotten." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } ;
HELP: load-vocab-hook

16
core/words/words-docs.factor
View File

@ -14,9 +14,7 @@ $nl
{ $subsection lookup }
"Words can output their name and vocabulary:"
{ $subsection word-name }
{ $subsection word-vocabulary }
"Testing if a word object is part of a vocabulary:"
{ $subsection interned? } ;
{ $subsection word-vocabulary } ;
ARTICLE: "uninterned-words" "Uninterned words"
"A word that is not a member of any vocabulary is said to be " { $emphasis "uninterned" } "."
@ -369,18 +367,6 @@ HELP: delimiter?
{ $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." }
{ $notes "Outputs " { $link f } " if the object is not a word." } ;
HELP: interned
{ $class-description "The class of words defined in the " { $link dictionary } "." }
{ $examples
{ $example "\\ + interned? ." "t" }
{ $example "gensym interned? ." "f" }
} ;
HELP: rename-word
{ $values { "word" word } { "newname" string } { "newvocab" string } }
{ $description "Changes the name and vocabulary of a word, and adds it to its new vocabulary." }
{ $side-effects "word" } ;
HELP: make-flushable
{ $values { "word" word } }
{ $description "Declares a word as " { $link POSTPONE: flushable } "." }

19
core/words/words-tests.factor
View File

@ -54,22 +54,14 @@ GENERIC: testing
[ f ] [ \ testing generic? ] unit-test
[ f ] [ gensym interned? ] unit-test
: forgotten ;
: another-forgotten ;
[ f ] [ \ forgotten interned? ] unit-test
FORGET: forgotten
[ f ] [ \ another-forgotten interned? ] unit-test
FORGET: another-forgotten
: another-forgotten ;
[ t ] [ \ + interned? ] unit-test
! I forgot remove-crossref calls!
: fee ;
: foe fee ;
@ -87,8 +79,7 @@ FORGET: foe
] unit-test
[ t ] [
\ * usage [ word? ] subset
[ dup interned? swap method-body? or ] all?
\ * usage [ word? ] subset [ crossref? ] all?
] unit-test
DEFER: calls-a-gensym
@ -119,7 +110,7 @@ M: array freakish ;
[ t ] [ \ bar \ freakish usage member? ] unit-test
DEFER: x
[ t ] [ [ x ] catch undefined? ] unit-test
[ x ] [ undefined? ] must-fail-with
[ ] [ "no-loc" "temporary" create drop ] unit-test
[ f ] [ "no-loc" "temporary" lookup where ] unit-test
@ -150,10 +141,8 @@ SYMBOL: quot-uses-b
[ { + } ] [ \ quot-uses-b uses ] unit-test
[ t ] [
[ "IN: temporary : undef-test ; << undef-test >>" eval ] catch
[ undefined? ] is?
] unit-test
[ "IN: temporary : undef-test ; << undef-test >>" eval ]
[ [ undefined? ] is? ] must-fail-with
[ ] [
"IN: temporary GENERIC: symbol-generic" eval

46
core/words/words.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: words
USING: arrays definitions graphs assocs kernel kernel.private
slots.private math namespaces sequences strings vectors sbufs
quotations assocs hashtables sorting math.parser words.private
vocabs ;
vocabs combinators ;
IN: words
: word ( -- word ) \ word get-global ;
@ -65,13 +65,20 @@ SYMBOL: bootstrapping?
: bootstrap-word ( word -- target )
[ target-word ] [ ] if-bootstrapping ;
PREDICATE: word interned dup target-word eq? ;
: crossref? ( word -- ? )
{
{ [ dup "forgotten" word-prop ] [ f ] }
{ [ dup "method" word-prop ] [ t ] }
{ [ dup word-vocabulary ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;
GENERIC# (quot-uses) 1 ( obj assoc -- )
M: object (quot-uses) 2drop ;
M: interned (quot-uses) dupd set-at ;
M: word (quot-uses)
>r dup crossref? [ dup r> set-at ] [ r> 2drop ] if ;
: seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ;
@ -92,6 +99,7 @@ SYMBOL: compiled-crossref
compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- )
[ drop crossref? ] assoc-subset
2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex* ;
@ -116,9 +124,6 @@ SYMBOL: changed-words
[ no-compilation-unit ] unless*
set-at ;
: crossref? ( word -- ? )
dup word-vocabulary swap "method" word-prop or ;
: define ( word def -- )
[ ] like
over unxref
@ -194,24 +199,17 @@ M: word where "loc" word-prop ;
M: word set-where swap "loc" set-word-prop ;
GENERIC: (forget-word) ( word -- )
GENERIC: forget-word ( word -- )
M: interned (forget-word)
dup word-name swap word-vocabulary vocab-words delete-at ;
: (forget-word) ( word -- )
dup "forgotten" word-prop [
dup delete-xref
dup delete-compiled-xref
dup word-name over word-vocabulary vocab-words delete-at
dup t "forgotten" set-word-prop
] unless drop ;
M: word (forget-word)
drop ;
: rename-word ( word newname newvocab -- )
pick (forget-word)
pick set-word-vocabulary
over set-word-name
reveal ;
: forget-word ( word -- )
dup delete-xref
dup delete-compiled-xref
(forget-word) ;
M: word forget-word (forget-word) ;
M: word forget* forget-word ;

6
extra/benchmark/recursive/recursive.factor Normal file → Executable file
View File

@ -4,8 +4,6 @@ USING: math kernel hints prettyprint io ;
: fib ( m -- n )
dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
! HINTS: fib { fixnum float } ;
!
: ack ( m n -- x )
over zero? [
nip 1+
@ -17,8 +15,6 @@ USING: math kernel hints prettyprint io ;
] if
] if ;
! HINTS: ack fixnum fixnum ;
: tak ( x y z -- t )
pick pick swap < [
[ rot 1- -rot tak ] 3keep
@ -29,8 +25,6 @@ USING: math kernel hints prettyprint io ;
2nip
] if ;
! HINTS: tak { fixnum float } { fixnum float } { fixnum float } ;
: recursive ( n -- )
3 over ack . flush
dup 27.0 + fib . flush

12
extra/bitfields/bitfields-tests.factor
View File

@ -10,12 +10,12 @@ SAFE-BITFIELD: foo bar:5 baz:10 111 bing:2 ;
[ 855 ] [ 21 852 3 <foo> 855 swap with-foo-baz foo-baz ] unit-test
[ 1 ] [ 21 852 3 <foo> 1 swap with-foo-bing foo-bing ] unit-test
[ 100 0 0 <foo> ] unit-test-fails
[ 0 5000 0 <foo> ] unit-test-fails
[ 0 0 10 <foo> ] unit-test-fails
[ 100 0 0 <foo> ] must-fail
[ 0 5000 0 <foo> ] must-fail
[ 0 0 10 <foo> ] must-fail
[ 100 0 with-foo-bar ] unit-test-fails
[ 5000 0 with-foo-baz ] unit-test-fails
[ 10 0 with-foo-bing ] unit-test-fails
[ 100 0 with-foo-bar ] must-fail
[ 5000 0 with-foo-baz ] must-fail
[ 10 0 with-foo-bing ] must-fail
[ BIN: 00101100000000111111 ] [ BIN: 101 BIN: 1000000001 BIN: 11 <foo> ] unit-test

2
extra/bootstrap/io/io.factor
View File

@ -10,5 +10,3 @@ IN: bootstrap.io
{ [ wince? ] [ "windows.ce" ] }
} cond append require
] when
"vocabs.monitor" require

16
extra/calendar/calendar-tests.factor
View File

@ -1,14 +1,14 @@
USING: arrays calendar kernel math sequences tools.test
continuations system ;
[ "invalid timestamp" ] [ [ 2004 12 32 0 0 0 0 make-timestamp ] catch ] unit-test
[ "invalid timestamp" ] [ [ 2004 2 30 0 0 0 0 make-timestamp ] catch ] unit-test
[ "invalid timestamp" ] [ [ 2003 2 29 0 0 0 0 make-timestamp ] catch ] unit-test
[ "invalid timestamp" ] [ [ 2004 -2 9 0 0 0 0 make-timestamp ] catch ] unit-test
[ "invalid timestamp" ] [ [ 2004 12 0 0 0 0 0 make-timestamp ] catch ] unit-test
[ "invalid timestamp" ] [ [ 2004 12 1 24 0 0 0 make-timestamp ] catch ] unit-test
[ "invalid timestamp" ] [ [ 2004 12 1 23 60 0 0 make-timestamp ] catch ] unit-test
[ "invalid timestamp" ] [ [ 2004 12 1 23 59 60 0 0 make-timestamp ] catch ] unit-test
[ 2004 12 32 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
[ 2004 2 30 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
[ 2003 2 29 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
[ 2004 -2 9 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
[ 2004 12 0 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
[ 2004 12 1 24 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
[ 2004 12 1 23 60 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
[ 2004 12 1 23 59 60 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
[ f ] [ 1900 leap-year? ] unit-test
[ t ] [ 1904 leap-year? ] unit-test

4
extra/circular/circular-tests.factor
View File

@ -9,7 +9,7 @@ circular strings ;
[ CHAR: t ] [ "test" <circular> 0 swap nth ] unit-test
[ "test" ] [ "test" <circular> >string ] unit-test
[ "test" <circular> 5 swap nth ] unit-test-fails
[ "test" <circular> 5 swap nth ] must-fail
[ CHAR: e ] [ "test" <circular> 5 swap nth-unsafe ] unit-test
[ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
@ -18,7 +18,7 @@ circular strings ;
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test
[ "fob" ] [ "foo" <circular> CHAR: b 2 pick set-nth >string ] unit-test
[ "foo" <circular> CHAR: b 3 rot set-nth ] unit-test-fails
[ "foo" <circular> CHAR: b 3 rot set-nth ] must-fail
[ "boo" ] [ "foo" <circular> CHAR: b 3 pick set-nth-unsafe >string ] unit-test
[ "ornact" ] [ "factor" <circular> 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test

17
extra/combinators/lib/lib-tests.factor
View File

@ -1,5 +1,5 @@
USING: combinators.lib kernel math math.ranges random sequences
tools.test inference continuations arrays vectors ;
tools.test tools.test.inference continuations arrays vectors ;
IN: temporary
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
@ -8,26 +8,25 @@ IN: temporary
[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test
[ 328350 ] [ 100 [ sq ] sigma ] unit-test
: infers? [ infer drop ] curry catch not ;
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
{ 6 2 } [ 1 2 [ 5 + ] dip ] unit-test
{ 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test
{ t } [ [ [ 99 ] 1 2 3 4 5 5 nslip ] infers? ] unit-test
[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer
{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
{ t } [ [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] infers? ] unit-test
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
{ t } [ [ 1 2 { 3 4 } [ + + ] 2 map-withn ] infers? ] unit-test
[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
{ t } [ [ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] infers? ] unit-test
[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
[ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test
[ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test
[ t ] [ [ [ sq ] 3apply ] infers? ] unit-test
[ [ sq ] 3apply ] must-infer
[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test
[ t ] [ [ [ dup 2^ 2array ] 5 napply ] infers? ] unit-test
[ [ dup 2^ 2array ] 5 napply ] must-infer
! &&

2
extra/concurrency/concurrency-docs.factor
View File

@ -146,7 +146,7 @@ ARTICLE: { "concurrency" "exceptions" } "Exceptions"
"A process can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the process will terminate. For example:"
{ $code "[ 1 0 / \"This will not print\" print ] spawn" }
"Processes can be linked so that a parent process can receive the exception that caused the child process to terminate. In this way 'supervisor' processes can be created that are notified when child processes terminate and possibly restart them.\n\nThe easiest way to form this link is using " { $link spawn-link } ". This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent process can catch it:"
{ $code "[\n [ 1 0 / \"This will not print\" print ] spawn-link drop\n receive\n] catch [ \"Exception caught.\" print ] when" }
{ $code "[\n [ 1 0 / \"This will not print\" print ] spawn-link drop\n receive\n] [ \"Exception caught.\" print ] recover" }
"Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ;
ARTICLE: { "concurrency" "futures" } "Futures"

15
extra/concurrency/concurrency-tests.factor
View File

@ -67,15 +67,12 @@ IN: temporary
] unit-test
[ "crash" ] [
[
[
[
"crash" throw
] spawn-link drop
receive
]
catch
] unit-test
"crash" throw
] spawn-link drop
receive
] [ "crash" = ] must-fail-with
[ 50 ] [
[ 50 ] future ?future
@ -115,7 +112,7 @@ SYMBOL: value
! this is fixed (via a timeout).
! [
! [ "this should propogate" throw ] future ?future
! ] unit-test-fails
! ] must-fail
[ ] [
[ "this should not propogate" throw ] future drop

2
extra/concurrency/concurrency.factor
View File

@ -166,7 +166,7 @@ M: process send ( message process -- )
PRIVATE>
: spawn-link ( quot -- process )
[ catch [ rethrow-linked ] when* ] curry
[ [ rethrow-linked ] recover ] curry
[ ((spawn)) ] curry (spawn-link) ; inline
<PRIVATE

2
extra/coroutines/coroutines-tests.factor
View File

@ -10,7 +10,7 @@ USING: coroutines kernel sequences prettyprint tools.test math ;
[ 1+ coyield* ] cocreate ;
test1 dup *coresume . dup *coresume . dup *coresume . dup *coresume 2drop
[ test2 42 over coresume . dup *coresume . drop ] unit-test-fails
[ test2 42 over coresume . dup *coresume . drop ] must-fail
{ 43 } [ 42 test2 coresume ] unit-test
: test3 ( -- co )

8
extra/crypto/xor/xor-tests.factor
View File

@ -2,10 +2,10 @@ USING: continuations crypto.xor kernel strings tools.test ;
IN: temporary
! No key
[ T{ no-xor-key f } ] [ [ "" dup xor-crypt ] catch ] unit-test
[ T{ no-xor-key f } ] [ [ { } dup xor-crypt ] catch ] unit-test
[ T{ no-xor-key f } ] [ [ V{ } dup xor-crypt ] catch ] unit-test
[ T{ no-xor-key f } ] [ [ "" "asdf" dupd xor-crypt xor-crypt ] catch ] unit-test
[ "" dup xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with
[ { } dup xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with
[ V{ } dup xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with
[ "" "asdf" dupd xor-crypt xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with
! a xor a = 0
[ "\0\0\0\0\0\0\0" ] [ "abcdefg" dup xor-crypt ] unit-test

1
extra/db/db.factor
View File

@ -10,7 +10,6 @@ C: <db> db ( handle -- obj )
! HOOK: db-create db ( str -- )
! HOOK: db-drop db ( str -- )
GENERIC: db-open ( db -- )
GENERIC: db-close ( db -- )
TUPLE: statement sql params handle bound? ;

22
unmaintained/mysql/libmysql.factor → extra/db/mysql/ffi/ffi.factor
View File

@ -1,27 +1,18 @@
! See http://factorcode.org/license.txt
! Copyright (C) 2007 Berlin Brown
! Date: 1/17/2007
!
! libs/mysql/libmysql.factor
!
! Copyright (C) 2007 Berlin Brown, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
! Adapted from mysql.h and mysql.c
! Tested with MySQL version - 5.0.24a
USING: alien alien.syntax combinators kernel system ;
IN: db.mysql.ffi
IN: mysql
USING: alien kernel ;
"mysql" {
<< "mysql" {
{ [ win32? ] [ "libmySQL.dll" "stdcall" ] }
{ [ macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] }
{ [ unix? ] [ "libmysqlclient.so.14" "cdecl" ] }
} cond add-library
} cond add-library >>
LIBRARY: mysql
! ===============================================
! mysql.c
! ===============================================
FUNCTION: void* mysql_init ( void* mysql ) ;
FUNCTION: char* mysql_error ( void* mysql ) ;
FUNCTION: void* mysql_real_connect ( void* mysql, char* host, char* user, char* passwd, char* db, int port, char* unixsocket, long clientflag ) ;
@ -32,4 +23,3 @@ FUNCTION: void mysql_free_result ( void* result ) ;
FUNCTION: char** mysql_fetch_row ( void* result ) ;
FUNCTION: int mysql_num_fields ( void* result ) ;
FUNCTION: ulong mysql_affected_rows ( void* mysql ) ;

78
extra/db/mysql/lib/lib.factor Normal file
View File

@ -0,0 +1,78 @@
! Copyright (C) 2007 Berlin Brown, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for license.
! Adapted from mysql.h and mysql.c
! Tested with MySQL version - 5.0.24a
USING: kernel alien io prettyprint sequences
namespaces arrays math db.mysql.ffi system ;
IN: db.mysql.lib
SYMBOL: my-conn
TUPLE: mysql-db handle host user password db port ;
TUPLE: mysql-statement ;
TUPLE: mysql-result-set ;
: new-mysql ( -- conn )
f mysql_init ;
: mysql-error ( mysql -- )
[ mysql_error throw ] when* ;
: mysql-connect ( mysql-connection -- )
new-mysql over set-mysql-db-handle
dup {
mysql-db-handle
mysql-db-host
mysql-db-user
mysql-db-password
mysql-db-db
mysql-db-port
} get-slots f 0 mysql_real_connect mysql-error ;
! =========================================================
! Low level mysql utility definitions
! =========================================================
: (mysql-query) ( mysql-connection query -- ret )
>r mysql-db-handle r> mysql_query ;
! : (mysql-result) ( mysql-connection -- ret )
! [ mysql-db-handle mysql_use_result ] keep
! [ set-mysql-connection-resulthandle ] keep ;
! : (mysql-affected-rows) ( mysql-connection -- n )
! mysql-connection-mysqlconn mysql_affected_rows ;
! : (mysql-free-result) ( mysql-connection -- )
! mysql-connection-resulthandle drop ;
! : (mysql-row) ( mysql-connection -- row )
! mysql-connection-resulthandle mysql_fetch_row ;
! : (mysql-num-cols) ( mysql-connection -- n )
! mysql-connection-resulthandle mysql_num_fields ;
! : mysql-char*-nth ( index object -- str )
! #! Utility based on 'char*-nth' to perform an additional sanity check on the value
! #! extracted from the array of strings.
! void*-nth [ alien>char-string ] [ "" ] if* ;
! : mysql-row>seq ( object n -- seq )
! [ swap mysql-char*-nth ] map-with ;
! : (mysql-result>seq) ( seq -- seq )
! my-conn get (mysql-row) dup [
! my-conn get (mysql-num-cols) mysql-row>seq
! over push
! (mysql-result>seq)
! ] [ drop ] if
! ! Perform needed cleanup on fetched results
! my-conn get (mysql-free-result) ;
! : mysql-query ( query -- ret )
! >r my-conn get r> (mysql-query) drop
! my-conn get (mysql-result) ;
! : mysql-command ( query -- n )
! mysql-query drop
! my-conn get (mysql-affected-rows) ;

58
extra/db/mysql/mysql.factor Normal file
View File

@ -0,0 +1,58 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for license.
USING: alien continuations io kernel prettyprint sequences
db db.mysql.ffi ;
IN: db.mysql
TUPLE: mysql-db handle host user password db port ;
TUPLE: mysql-statement ;
TUPLE: mysql-result-set ;
M: mysql-db db-open ( mysql-db -- )
;
M: mysql-db dispose ( mysql-db -- )
mysql-db-handle mysql_close ;
M: mysql-db <simple-statement> ( str -- statement )
;
M: mysql-db <prepared-statement> ( str -- statement )
;
M: mysql-statement prepare-statement ( statement -- )
;
M: mysql-statement bind-statement* ( statement -- )
;
M: mysql-statement rebind-statement ( statement -- )
;
M: mysql-statement execute-statement ( statement -- )
;
M: mysql-statement query-results ( query -- result-set )
;
M: mysql-result-set #rows ( result-set -- n )
;
M: mysql-result-set #columns ( result-set -- n )
;
M: mysql-result-set row-column ( result-set n -- obj )
;
M: mysql-result-set advance-row ( result-set -- ? )
;
M: mysql-db begin-transaction ( -- )
;
M: mysql-db commit-transaction ( -- )
;
M: mysql-db rollback-transaction ( -- )
;

1
extra/db/postgresql/ffi/ffi.factor
View File

@ -1,6 +1,5 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
! adapted from libpq-fe.h version 7.4.7
! tested on debian linux with postgresql 8.1
USING: alien alien.syntax combinators system ;

4
extra/db/postgresql/postgresql-tests.factor
View File

@ -14,7 +14,7 @@ IN: temporary
[ ] [
test-db [
[ "drop table person;" sql-command ] catch drop
[ "drop table person;" sql-command ] ignore-errors
"create table person (name varchar(30), country varchar(30));"
sql-command
@ -83,7 +83,7 @@ IN: temporary
"oops" throw
] with-transaction
] with-db
] unit-test-fails
] must-fail
[ 3 ] [
test-db [

49
extra/db/sqlite/sqlite-tests.factor
View File

@ -1,42 +1,28 @@
USING: io io.files io.launcher kernel namespaces
prettyprint tools.test db.sqlite db db.sql sequences
prettyprint tools.test db.sqlite db sequences
continuations ;
IN: temporary
! "sqlite3 -init test.txt test.db"
IN: scratchpad
: test.db "extra/db/sqlite/test.db" resource-path ;
IN: temporary
: (create-db) ( -- str )
[
"sqlite3 -init " %
test.db %
" " %
test.db %
] "" make ;
[ ] [ [ test.db delete-file ] ignore-errors ] unit-test
: create-db ( -- ) (create-db) run-process drop ;
[ ] [
test.db [
"create table person (name varchar(30), country varchar(30))" sql-command
"insert into person values('John', 'America')" sql-command
"insert into person values('Jane', 'New Zealand')" sql-command
] with-sqlite
] unit-test
[ ] [ test.db delete-file ] unit-test
[ ] [ create-db ] unit-test
[
{
{ "John" "America" }
{ "Jane" "New Zealand" }
}
] [
[ { { "John" "America" } { "Jane" "New Zealand" } } ] [
test.db [
"select * from person" sql-query
] with-sqlite
] unit-test
[
{ { "John" "America" } }
] [
[ { { "John" "America" } } ] [
test.db [
"select * from person where name = :name and country = :country"
<simple-statement> [
@ -52,15 +38,10 @@ IN: temporary
] with-sqlite
] unit-test
[
{
{ "1" "John" "America" }
{ "2" "Jane" "New Zealand" }
}
] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
[ { { "1" "John" "America" } { "2" "Jane" "New Zealand" } } ]
[ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
[
] [
[ ] [
test.db [
"insert into person(name, country) values('Jimmy', 'Canada')"
sql-command
@ -83,7 +64,7 @@ IN: temporary
"oops" throw
] with-transaction
] with-sqlite
] unit-test-fails
] must-fail
[ 3 ] [
test.db [

2
extra/db/sqlite/sqlite.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays assocs classes compiler db db.sql
USING: alien arrays assocs classes compiler db
hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings tuples alien.c-types
continuations db.sqlite.lib db.sqlite.ffi ;

4
extra/destructors/destructors-tests.factor
View File

@ -36,7 +36,7 @@ M: dummy-destructor destruct ( obj -- )
dup destroy-always
"foo" throw
] with-destructors
] catch drop dummy-obj-destroyed?
] ignore-errors dummy-obj-destroyed?
] unit-test
[ t ] [
@ -45,6 +45,6 @@ M: dummy-destructor destruct ( obj -- )
dup destroy-later
"foo" throw
] with-destructors
] catch drop dummy-obj-destroyed?
] ignore-errors dummy-obj-destroyed?
] unit-test

7
extra/hardware-info/hardware-info.factor
View File

@ -1,12 +1,13 @@
USING: alien.syntax kernel math prettyprint system
combinators vocabs.loader hardware-info.backend ;
USING: alien.syntax kernel math prettyprint
combinators vocabs.loader hardware-info.backend system ;
IN: hardware-info
: kb. ( x -- ) 10 2^ /f . ;
: megs. ( x -- ) 20 2^ /f . ;
: gigs. ( x -- ) 30 2^ /f . ;
<< {
<<
{
{ [ windows? ] [ "hardware-info.windows" ] }
{ [ linux? ] [ "hardware-info.linux" ] }
{ [ macosx? ] [ "hardware-info.macosx" ] }

6
extra/hardware-info/windows/backend/backend.factor
View File

@ -1,6 +0,0 @@
IN: hardware-info.windows.backend
TUPLE: wince ;
TUPLE: winnt ;
UNION: windows wince winnt ;

4
extra/hardware-info/windows/ce/ce.factor
View File

@ -2,8 +2,8 @@ USING: alien.c-types hardware-info kernel math namespaces
windows windows.kernel32 hardware-info.backend ;
IN: hardware-info.windows.ce
TUPLE: wince ;
T{ wince } os set-global
TUPLE: wince-os ;
T{ wince-os } os set-global
: memory-status ( -- MEMORYSTATUS )
"MEMORYSTATUS" <c-object>

24
extra/hardware-info/windows/nt/nt.factor
View File

@ -1,16 +1,15 @@
USING: alien alien.c-types hardware-info.windows.backend
USING: alien alien.c-types
kernel libc math namespaces hardware-info.backend
windows windows.advapi32 windows.kernel32 ;
IN: hardware-info.windows.nt
TUPLE: winnt ;
T{ winnt } os set-global
TUPLE: winnt-os ;
T{ winnt-os } os set-global
: system-info ( -- SYSTEM_INFO )
"SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
M: winnt cpus ( -- n )
M: winnt-os cpus ( -- n )
system-info SYSTEM_INFO-dwNumberOfProcessors ;
: memory-status ( -- MEMORYSTATUSEX )
@ -18,25 +17,25 @@ M: winnt cpus ( -- n )
"MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength
[ GlobalMemoryStatusEx ] keep swap zero? [ win32-error ] when ;
M: winnt memory-load ( -- n )
M: winnt-os memory-load ( -- n )
memory-status MEMORYSTATUSEX-dwMemoryLoad ;
M: winnt physical-mem ( -- n )
M: winnt-os physical-mem ( -- n )
memory-status MEMORYSTATUSEX-ullTotalPhys ;
M: winnt available-mem ( -- n )
M: winnt-os available-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailPhys ;
M: winnt total-page-file ( -- n )
M: winnt-os total-page-file ( -- n )
memory-status MEMORYSTATUSEX-ullTotalPageFile ;
M: winnt available-page-file ( -- n )
M: winnt-os available-page-file ( -- n )
memory-status MEMORYSTATUSEX-ullAvailPageFile ;
M: winnt total-virtual-mem ( -- n )
M: winnt-os total-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullTotalVirtual ;
M: winnt available-virtual-mem ( -- n )
M: winnt-os available-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailVirtual ;
: computer-name ( -- string )
@ -54,4 +53,3 @@ M: winnt available-virtual-mem ( -- n )
] [
[ alien>u16-string ] keep free
] if ;

7
extra/hardware-info/windows/windows.factor
View File

@ -1,7 +1,7 @@
USING: alien alien.c-types kernel libc math namespaces
windows windows.kernel32 windows.advapi32
hardware-info.windows.backend
words combinators vocabs.loader hardware-info.backend ;
words combinators vocabs.loader hardware-info.backend
system ;
IN: hardware-info.windows
: system-info ( -- SYSTEM_INFO )
@ -63,7 +63,8 @@ IN: hardware-info.windows
: system-windows-directory ( -- str )
\ GetSystemWindowsDirectory get-directory ;
<<
{
{ [ wince? ] [ "hardware-info.windows.ce" ] }
{ [ winnt? ] [ "hardware-info.windows.nt" ] }
} cond [ require ] when*
} cond [ require ] when* >>

2
extra/help/crossref/crossref-tests.factor
View File

@ -50,7 +50,7 @@ io.streams.string continuations debugger compiler.units ;
[
"IN: azz USE: help.syntax USE: help.markup ARTICLE: \"yyy\" \"YYY\" ; ARTICLE: \"xxx\" \"XXX\" { $subsection \"yyy\" } ; ARTICLE: \"yyy\" \"YYY\" ;"
<string-reader> "parent-test" parse-stream drop
] catch [ :1 ] when
] [ :1 ] recover
] unit-test
[ "xxx" ] [ "yyy" article-parent ] unit-test

2
extra/help/handbook/handbook.factor
View File

@ -32,6 +32,8 @@ $nl
{ { $snippet "with-" { $emphasis "foo" } } { "performs some kind of initialization and cleanup related to " { $snippet "foo" } ", usually in a new dynamic scope" } { $links with-scope with-stream } }
{ { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } }
}
{ $heading "Stack effect conventions" }
"Stack effect conventions are documented in " { $link "effect-declaration" } "."
{ $heading "Glossary of terms" }
"Common terminology and abbreviations used throughout Factor and its documentation:"
{ $table

8
extra/inverse/inverse-tests.factor
View File

@ -3,7 +3,7 @@ math.functions math.constants ;
IN: inverse-tests
[ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
[ { 3 4 } [ dup 2array ] undo ] unit-test-fails
[ { 3 4 } [ dup 2array ] undo ] must-fail
TUPLE: foo bar baz ;
@ -15,7 +15,7 @@ C: <foo> foo
[ t ] [ { 3 3 } [ 2same ] matches? ] unit-test
[ f ] [ { 3 4 } [ 2same ] matches? ] unit-test
[ [ 2same ] matches? ] unit-test-fails
[ [ 2same ] matches? ] must-fail
: something ( array -- num )
{
@ -25,9 +25,9 @@ C: <foo> foo
[ 5 ] [ { 1 2 2 } something ] unit-test
[ 6 ] [ { 2 3 } something ] unit-test
[ { 1 } something ] unit-test-fails
[ { 1 } something ] must-fail
[ 1 2 [ eq? ] undo ] unit-test-fails
[ 1 2 [ eq? ] undo ] must-fail
: f>c ( *fahrenheit -- *celsius )
32 - 1.8 / ;

2
extra/io/buffers/buffers-tests.factor
View File

@ -75,5 +75,5 @@ sequences tools.test namespaces ;
"b" get buffer-free
100 <buffer> "b" set
[ 1000 "b" get n>buffer ] unit-test-fails
[ 1000 "b" get n>buffer ] must-fail
"b" get buffer-free

4
extra/io/mmap/mmap-tests.factor
View File

@ -1,9 +1,9 @@
USING: io io.mmap io.files kernel tools.test continuations sequences ;
IN: temporary
[ "mmap-test-file.txt" resource-path delete-file ] catch drop
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
[ ] [ "mmap-test-file.txt" resource-path <file-writer> [ "12345" write ] with-stream ] unit-test
[ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test
[ "22345" ] [ "mmap-test-file.txt" resource-path file-contents ] unit-test
[ "mmap-test-file.txt" resource-path delete-file ] catch drop
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors

4
extra/io/unix/files/files.factor
View File

@ -6,8 +6,8 @@ alien ;
IN: io.unix.files
M: unix-io cwd
MAXPATHLEN dup <byte-array> getcwd
[ alien>char-string ] [ (io-error) ] if* ;
MAXPATHLEN dup <byte-array> swap
getcwd [ (io-error) ] unless* ;
M: unix-io cd
chdir io-error ;

8
extra/io/unix/launcher/launcher-tests.factor
View File

@ -1,8 +1,8 @@
IN: temporary
USING: io.unix.launcher tools.test ;
[ "" tokenize-command ] unit-test-fails
[ " " tokenize-command ] unit-test-fails
[ "" tokenize-command ] must-fail
[ " " tokenize-command ] must-fail
[ { "a" } ] [ "a" tokenize-command ] unit-test
[ { "abc" } ] [ "abc" tokenize-command ] unit-test
[ { "abc" } ] [ "abc " tokenize-command ] unit-test
@ -14,8 +14,8 @@ USING: io.unix.launcher tools.test ;
[ { "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test
[ { "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test
[ { "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test
[ "'abc def' \"hey" tokenize-command ] unit-test-fails
[ "'abc def" tokenize-command ] unit-test-fails
[ "'abc def' \"hey" tokenize-command ] must-fail
[ "'abc def" tokenize-command ] must-fail
[ { "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test
[

4
extra/io/unix/linux/linux.factor
View File

@ -3,7 +3,7 @@
USING: kernel io.backend io.monitors io.monitors.private io.files
io.buffers io.nonblocking io.unix.backend io.unix.select
io.unix.launcher unix.linux.inotify assocs namespaces threads
continuations init math alien.c-types alien ;
continuations init math alien.c-types alien vocabs.loader ;
IN: io.unix.linux
TUPLE: linux-io ;
@ -135,3 +135,5 @@ M: linux-io init-io ( -- )
T{ linux-io } set-io-backend
[ start-wait-thread ] "io.unix.linux" add-init-hook
"vocabs.monitor" require

20
extra/io/unix/unix-tests.factor
View File

@ -7,7 +7,7 @@ IN: temporary
[
[
"unix-domain-socket-test" resource-path delete-file
] catch drop
] ignore-errors
"unix-domain-socket-test" resource-path <local>
<server> [
@ -36,7 +36,7 @@ yield
! Unix domain datagram sockets
[
"unix-domain-datagram-test" resource-path delete-file
] catch drop
] ignore-errors
: server-addr "unix-domain-datagram-test" resource-path <local> ;
: client-addr "unix-domain-datagram-test-2" resource-path <local> ;
@ -75,7 +75,7 @@ yield
[
"unix-domain-datagram-test-2" resource-path delete-file
] catch drop
] ignore-errors
client-addr <datagram>
"d" set
@ -110,7 +110,7 @@ client-addr <datagram>
[
"unix-domain-datagram-test-3" resource-path delete-file
] catch drop
] ignore-errors
"unix-domain-datagram-test-2" resource-path delete-file
@ -118,29 +118,29 @@ client-addr <datagram>
[
B{ 1 2 3 } "unix-domain-datagram-test-3" <local> "d" get send
] unit-test-fails
] must-fail
[ ] [ "d" get dispose ] unit-test
! See what happens on send/receive after close
[ "d" get receive ] unit-test-fails
[ "d" get receive ] must-fail
[ B{ 1 2 } server-addr "d" get send ] unit-test-fails
[ B{ 1 2 } server-addr "d" get send ] must-fail
! Invalid parameter tests
[
image <file-reader> [ stdio get accept ] with-stream
] unit-test-fails
] must-fail
[
image <file-reader> [ stdio get receive ] with-stream
] unit-test-fails
] must-fail
[
image <file-reader> [
B{ 1 2 } server-addr
stdio get send
] with-stream
] unit-test-fails
] must-fail

3
extra/io/windows/nt/nt.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USE: vocabs.loader
USE: io.windows
USE: io.windows.nt.backend
USE: io.windows.nt.files
@ -11,3 +12,5 @@ USE: io.windows.mmap
USE: io.backend
T{ windows-nt-io } set-io-backend
"vocabs.monitor" require

2
extra/irc/irc.factor
View File

@ -189,7 +189,7 @@ SYMBOL: line
: with-infinite-loop ( quot timeout -- quot timeout )
"looping" print flush
over catch drop dup sleep with-infinite-loop ;
over [ drop ] recover dup sleep with-infinite-loop ;
: start-irc ( irc-client -- )
! [ [ do-irc ] curry 3000 with-infinite-loop ] with-scope ;

4
extra/math/complex/complex-tests.factor
View File

@ -2,8 +2,8 @@ USING: kernel math math.constants math.functions tools.test
prettyprint ;
IN: temporary
[ 1 C{ 0 1 } rect> ] unit-test-fails
[ C{ 0 1 } 1 rect> ] unit-test-fails
[ 1 C{ 0 1 } rect> ] must-fail
[ C{ 0 1 } 1 rect> ] must-fail
[ f ] [ C{ 5 12.5 } 5 = ] unit-test
[ t ] [ C{ 1.0 2.0 } C{ 1 2 } = ] unit-test

2
extra/math/functions/functions-tests.factor
View File

@ -73,7 +73,7 @@ IN: temporary
[ 3 ] [ 5 7 mod-inv ] unit-test
[ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test
[ 2 10 mod-inv ] unit-test-fails
[ 2 10 mod-inv ] must-fail
[ t ] [ 0 0 ^ fp-nan? ] unit-test
[ 1 ] [ 10 0 ^ ] unit-test

30
extra/math/vectors/vectors.factor
View File

@ -27,20 +27,20 @@ IN: math.vectors
: set-axis ( u v axis -- w )
dup length [ >r zero? pick pick ? r> swap nth ] 2map 2nip ;
HINTS: vneg { float-array array } ;
HINTS: norm-sq { float-array array } ;
HINTS: norm { float-array array } ;
HINTS: normalize { float-array array } ;
HINTS: vneg { float-array } { array } ;
HINTS: norm-sq { float-array } { array } ;
HINTS: norm { float-array } { array } ;
HINTS: normalize { float-array } { array } ;
HINTS: n*v * { float-array array } ;
HINTS: v*n { float-array array } * ;
HINTS: n/v * { float-array array } ;
HINTS: v/n { float-array array } * ;
HINTS: n*v { object float-array } { object array } ;
HINTS: v*n { float-array object } { array object } ;
HINTS: n/v { object float-array } { array } ;
HINTS: v/n { float-array object } { array object } ;
HINTS: v+ { float-array array } { float-array array } ;
HINTS: v- { float-array array } { float-array array } ;
HINTS: v* { float-array array } { float-array array } ;
HINTS: v/ { float-array array } { float-array array } ;
HINTS: vmax { float-array array } { float-array array } ;
HINTS: vmin { float-array array } { float-array array } ;
HINTS: v. { float-array array } { float-array array } ;
HINTS: v+ { float-array float-array } { array array } ;
HINTS: v- { float-array float-array } { array array } ;
HINTS: v* { float-array float-array } { array array } ;
HINTS: v/ { float-array float-array } { array array } ;
HINTS: vmax { float-array float-array } { array array } ;
HINTS: vmin { float-array float-array } { array array } ;
HINTS: v. { float-array float-array } { array array } ;

2
extra/memoize/memoize-tests.factor
View File

@ -7,4 +7,4 @@ MEMO: fib ( m -- n )
[ 89 ] [ 10 fib ] unit-test
[ "USING: kernel math memoize ; MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] unit-test-fails
[ "USING: kernel math memoize ; MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail

2
extra/multi-methods/multi-methods-tests.factor
View File

@ -52,7 +52,7 @@ METHOD: beats? { thing thing } f ;
: play ( obj1 obj2 -- ? ) beats? 2nip ;
[ { } 3 play ] unit-test-fails
[ { } 3 play ] must-fail
[ t ] [ error get no-method? ] unit-test
[ ] [ error get error. ] unit-test
[ t ] [ T{ paper } T{ scissors } play ] unit-test

4
extra/multiline/multiline.factor Normal file → Executable file
View File

@ -4,7 +4,7 @@ USING: namespaces parser kernel sequences words quotations math ;
IN: multiline
: next-line-text ( -- str )
lexer get dup next-line line-text ;
lexer get dup next-line lexer-line-text ;
: (parse-here) ( -- )
next-line-text dup ";" =
@ -19,7 +19,7 @@ IN: multiline
parse-here 1quotation define ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index )
lexer get line-text 2dup start
lexer get lexer-line-text 2dup start
[ rot dupd >r >r swap subseq % r> r> length + ] [
rot tail % "\n" % 0
lexer get next-line swap (parse-multiline-string)

2
extra/ogg/theora/theora.factor
View File

@ -6,7 +6,7 @@ IN: ogg.theora
<<
"theora" {
{ [ win32? ] [ "libtheora.dll" ] }
{ [ win32? ] [ "theora.dll" ] }
{ [ macosx? ] [ "libtheora.0.dylib" ] }
{ [ unix? ] [ "libtheora.so" ] }
} cond "cdecl" add-library

2
extra/ogg/vorbis/vorbis.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel system combinators alien alien.syntax ;
USING: kernel system combinators alien alien.syntax ogg ;
IN: ogg.vorbis
<<

2
extra/parser-combinators/parser-combinators-tests.factor
View File

@ -76,7 +76,7 @@ IN: scratchpad
[
"begin1" "begin" token some parse
] unit-test-fails
] must-fail
{ "begin" } [
"begin" "begin" token some parse

Some files were not shown because too many files have changed in this diff Show More