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

Merge branch 'master' of http://factorcode.org/git/factor into experimental

db4
Alex Chapman 2008-04-27 22:41:26 +10:00
parent bd548d5423 c88cf361e7
commit a502ab882a
394 changed files with 2740 additions and 1887 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

750
core/alien/compiler/compiler-tests.factor
View File

@ -1,375 +1,375 @@
IN: alien.compiler.tests
USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences inference words
arrays parser quotations continuations inference.backend effects
namespaces.private io io.streams.string memory system threads
tools.test math ;
FUNCTION: void ffi_test_0 ;
[ ] [ ffi_test_0 ] unit-test
FUNCTION: int ffi_test_1 ;
[ 3 ] [ ffi_test_1 ] unit-test
FUNCTION: int ffi_test_2 int x int y ;
[ 5 ] [ 2 3 ffi_test_2 ] unit-test
[ "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
FUNCTION: float ffi_test_4 ;
[ 1.5 ] [ ffi_test_4 ] unit-test
FUNCTION: double ffi_test_5 ;
[ 1.5 ] [ ffi_test_5 ] unit-test
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 ] must-fail
[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
C-STRUCT: foo
{ "int" "x" }
{ "int" "y" }
;
: make-foo ( x y -- foo )
"foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
FUNCTION: int ffi_test_11 int a foo b int c ;
[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
FUNCTION: foo ffi_test_14 int x int y ;
[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
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 ] must-fail
C-STRUCT: bar
{ "long" "x" }
{ "long" "y" }
{ "long" "z" }
;
FUNCTION: bar ffi_test_16 long x long y long z ;
[ 11 6 -7 ] [
11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
] unit-test
C-STRUCT: tiny
{ "int" "x" }
;
FUNCTION: tiny ffi_test_17 int x ;
[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
: indirect-test-1
"int" { } "cdecl" alien-indirect ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
[ -1 indirect-test-1 ] must-fail
: indirect-test-2
"int" { "int" "int" } "cdecl" alien-indirect gc ;
{ 3 1 } [ indirect-test-2 ] must-infer-as
[ 5 ]
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
unit-test
: indirect-test-3
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect
gc ;
<< "f-stdcall" f "stdcall" add-library >>
[ f ] [ "f-stdcall" load-library ] unit-test
[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
: ffi_test_18 ( w x y z -- int )
"int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
alien-invoke gc ;
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
: ffi_test_19 ( x y z -- bar )
"bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
alien-invoke gc ;
[ 11 6 -7 ] [
11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
] 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 ] must-fail
FUNCTION: double ffi_test_7 double x double y ;
[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
FUNCTION: double ffi_test_8 double x float y double z float t int w ;
[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
FUNCTION: void ffi_test_20 double x1, double x2, double x3,
double y1, double y2, double y3,
double z1, double z2, double z3 ;
[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
! Make sure XT doesn't get clobbered in stack frame
: ffi_test_31
"void"
f "ffi_test_31"
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
alien-invoke gc 3 ;
[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
FUNCTION: longlong ffi_test_21 long x long y ;
[ 121932631112635269 ]
[ 123456789 987654321 ffi_test_21 ] unit-test
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 ] must-fail
C-STRUCT: rect
{ "float" "x" }
{ "float" "y" }
{ "float" "w" }
{ "float" "h" }
;
: <rect>
"rect" <c-object>
[ set-rect-h ] keep
[ set-rect-w ] keep
[ set-rect-y ] keep
[ set-rect-x ] keep ;
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 ] must-fail
FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
! Test odd-size structs
C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
FUNCTION: test-struct-1 ffi_test_24 ;
[ B{ 1 } ] [ ffi_test_24 ] unit-test
C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
FUNCTION: test-struct-2 ffi_test_25 ;
[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
FUNCTION: test-struct-3 ffi_test_26 ;
[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
FUNCTION: test-struct-4 ffi_test_27 ;
[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
FUNCTION: test-struct-5 ffi_test_28 ;
[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
FUNCTION: test-struct-6 ffi_test_29 ;
[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
FUNCTION: test-struct-7 ffi_test_30 ;
[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
FUNCTION: double ffi_test_32 test-struct-8 x int y ;
[ 9.0 ] [
"test-struct-8" <c-object>
1.0 over set-test-struct-8-x
2.0 over set-test-struct-8-y
3 ffi_test_32
] unit-test
C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
FUNCTION: double ffi_test_33 test-struct-9 x int y ;
[ 9.0 ] [
"test-struct-9" <c-object>
1.0 over set-test-struct-9-x
2.0 over set-test-struct-9-y
3 ffi_test_33
] unit-test
C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
FUNCTION: double ffi_test_34 test-struct-10 x int y ;
[ 9.0 ] [
"test-struct-10" <c-object>
1.0 over set-test-struct-10-x
2 over set-test-struct-10-y
3 ffi_test_34
] unit-test
C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
FUNCTION: double ffi_test_35 test-struct-11 x int y ;
[ 9.0 ] [
"test-struct-11" <c-object>
1 over set-test-struct-11-x
2 over set-test-struct-11-y
3 ffi_test_35
] unit-test
C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
: make-struct-12
"test-struct-12" <c-object>
[ set-test-struct-12-x ] keep ;
FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
! Test callbacks
: callback-1 "void" { } "cdecl" [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
[ t ] [ callback-1 alien? ] unit-test
: callback_test_1 "void" { } "cdecl" alien-indirect ;
[ ] [ callback-1 callback_test_1 ] unit-test
: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
[ ] [ callback-2 callback_test_1 ] unit-test
: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
[ t ] [
namestack*
3 "x" set callback-3 callback_test_1
namestack* eq?
] unit-test
[ 5 ] [
[
3 "x" set callback-3 callback_test_1 "x" get
] with-scope
] unit-test
: callback-4
"void" { } "cdecl" [ "Hello world" write ] alien-callback
gc ;
[ "Hello world" ] [
[ callback-4 callback_test_1 ] with-string-writer
] unit-test
: callback-5
"void" { } "cdecl" [ gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5 callback_test_1
] unit-test
: callback-5a
"void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
! Hack; if we're on ARM, we probably don't have much RAM, so
! skip this test.
! cpu "arm" = [
! [ "testing" ] [
! "testing" callback-5a callback_test_1
! ] unit-test
! ] unless
: callback-6
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
: callback-7
"void" { } "cdecl" [ 1000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
[ f ] [ namespace global eq? ] unit-test
: callback-8
"void" { } "cdecl" [
[ continue ] callcc0
] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test
: callback-9
"int" { "int" "int" "int" } "cdecl" [
+ + 1+
] alien-callback ;
FUNCTION: void ffi_test_36_point_5 ( ) ;
[ ] [ ffi_test_36_point_5 ] unit-test
FUNCTION: int ffi_test_37 ( void* func ) ;
[ 1 ] [ callback-9 ffi_test_37 ] unit-test
[ 7 ] [ callback-9 ffi_test_37 ] unit-test
IN: alien.compiler.tests
USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences inference words
arrays parser quotations continuations inference.backend effects
namespaces.private io io.streams.string memory system threads
tools.test math ;
FUNCTION: void ffi_test_0 ;
[ ] [ ffi_test_0 ] unit-test
FUNCTION: int ffi_test_1 ;
[ 3 ] [ ffi_test_1 ] unit-test
FUNCTION: int ffi_test_2 int x int y ;
[ 5 ] [ 2 3 ffi_test_2 ] unit-test
[ "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
FUNCTION: float ffi_test_4 ;
[ 1.5 ] [ ffi_test_4 ] unit-test
FUNCTION: double ffi_test_5 ;
[ 1.5 ] [ ffi_test_5 ] unit-test
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 ] must-fail
[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
C-STRUCT: foo
{ "int" "x" }
{ "int" "y" }
;
: make-foo ( x y -- foo )
"foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
FUNCTION: int ffi_test_11 int a foo b int c ;
[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
FUNCTION: foo ffi_test_14 int x int y ;
[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
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 ] must-fail
C-STRUCT: bar
{ "long" "x" }
{ "long" "y" }
{ "long" "z" }
;
FUNCTION: bar ffi_test_16 long x long y long z ;
[ 11 6 -7 ] [
11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
] unit-test
C-STRUCT: tiny
{ "int" "x" }
;
FUNCTION: tiny ffi_test_17 int x ;
[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
: indirect-test-1
"int" { } "cdecl" alien-indirect ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
[ -1 indirect-test-1 ] must-fail
: indirect-test-2
"int" { "int" "int" } "cdecl" alien-indirect gc ;
{ 3 1 } [ indirect-test-2 ] must-infer-as
[ 5 ]
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
unit-test
: indirect-test-3
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect
gc ;
<< "f-stdcall" f "stdcall" add-library >>
[ f ] [ "f-stdcall" load-library ] unit-test
[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
: ffi_test_18 ( w x y z -- int )
"int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
alien-invoke gc ;
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
: ffi_test_19 ( x y z -- bar )
"bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
alien-invoke gc ;
[ 11 6 -7 ] [
11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
] 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 ] must-fail
FUNCTION: double ffi_test_7 double x double y ;
[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
FUNCTION: double ffi_test_8 double x float y double z float t int w ;
[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
FUNCTION: void ffi_test_20 double x1, double x2, double x3,
double y1, double y2, double y3,
double z1, double z2, double z3 ;
[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
! Make sure XT doesn't get clobbered in stack frame
: ffi_test_31
"void"
f "ffi_test_31"
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
alien-invoke gc 3 ;
[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
FUNCTION: longlong ffi_test_21 long x long y ;
[ 121932631112635269 ]
[ 123456789 987654321 ffi_test_21 ] unit-test
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 ] must-fail
C-STRUCT: rect
{ "float" "x" }
{ "float" "y" }
{ "float" "w" }
{ "float" "h" }
;
: <rect>
"rect" <c-object>
[ set-rect-h ] keep
[ set-rect-w ] keep
[ set-rect-y ] keep
[ set-rect-x ] keep ;
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 ] must-fail
FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
! Test odd-size structs
C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
FUNCTION: test-struct-1 ffi_test_24 ;
[ B{ 1 } ] [ ffi_test_24 ] unit-test
C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
FUNCTION: test-struct-2 ffi_test_25 ;
[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
FUNCTION: test-struct-3 ffi_test_26 ;
[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
FUNCTION: test-struct-4 ffi_test_27 ;
[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
FUNCTION: test-struct-5 ffi_test_28 ;
[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
FUNCTION: test-struct-6 ffi_test_29 ;
[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
FUNCTION: test-struct-7 ffi_test_30 ;
[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
FUNCTION: double ffi_test_32 test-struct-8 x int y ;
[ 9.0 ] [
"test-struct-8" <c-object>
1.0 over set-test-struct-8-x
2.0 over set-test-struct-8-y
3 ffi_test_32
] unit-test
C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
FUNCTION: double ffi_test_33 test-struct-9 x int y ;
[ 9.0 ] [
"test-struct-9" <c-object>
1.0 over set-test-struct-9-x
2.0 over set-test-struct-9-y
3 ffi_test_33
] unit-test
C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
FUNCTION: double ffi_test_34 test-struct-10 x int y ;
[ 9.0 ] [
"test-struct-10" <c-object>
1.0 over set-test-struct-10-x
2 over set-test-struct-10-y
3 ffi_test_34
] unit-test
C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
FUNCTION: double ffi_test_35 test-struct-11 x int y ;
[ 9.0 ] [
"test-struct-11" <c-object>
1 over set-test-struct-11-x
2 over set-test-struct-11-y
3 ffi_test_35
] unit-test
C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
: make-struct-12
"test-struct-12" <c-object>
[ set-test-struct-12-x ] keep ;
FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
! Test callbacks
: callback-1 "void" { } "cdecl" [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
[ t ] [ callback-1 alien? ] unit-test
: callback_test_1 "void" { } "cdecl" alien-indirect ;
[ ] [ callback-1 callback_test_1 ] unit-test
: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
[ ] [ callback-2 callback_test_1 ] unit-test
: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
[ t ] [
namestack*
3 "x" set callback-3 callback_test_1
namestack* eq?
] unit-test
[ 5 ] [
[
3 "x" set callback-3 callback_test_1 "x" get
] with-scope
] unit-test
: callback-4
"void" { } "cdecl" [ "Hello world" write ] alien-callback
gc ;
[ "Hello world" ] [
[ callback-4 callback_test_1 ] with-string-writer
] unit-test
: callback-5
"void" { } "cdecl" [ gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5 callback_test_1
] unit-test
: callback-5a
"void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
! Hack; if we're on ARM, we probably don't have much RAM, so
! skip this test.
! cpu "arm" = [
! [ "testing" ] [
! "testing" callback-5a callback_test_1
! ] unit-test
! ] unless
: callback-6
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
: callback-7
"void" { } "cdecl" [ 1000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
[ f ] [ namespace global eq? ] unit-test
: callback-8
"void" { } "cdecl" [
[ continue ] callcc0
] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test
: callback-9
"int" { "int" "int" "int" } "cdecl" [
+ + 1+
] alien-callback ;
FUNCTION: void ffi_test_36_point_5 ( ) ;
[ ] [ ffi_test_36_point_5 ] unit-test
FUNCTION: int ffi_test_37 ( void* func ) ;
[ 1 ] [ callback-9 ffi_test_37 ] unit-test
[ 7 ] [ callback-9 ffi_test_37 ] unit-test

2
core/alien/syntax/syntax.factor
View File

@ -40,7 +40,7 @@ PRIVATE>
: FUNCTION:
scan "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] subset
[ "()" subseq? not ] filter
define-function ; parsing
: TYPEDEF:

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

@ -96,7 +96,7 @@ $nl
{ $subsection assoc-each }
{ $subsection assoc-map }
{ $subsection assoc-push-if }
{ $subsection assoc-subset }
{ $subsection assoc-filter }
{ $subsection assoc-contains? }
{ $subsection assoc-all? }
"Three additional combinators:"
@ -203,7 +203,7 @@ HELP: assoc-push-if
{ $values { "accum" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" object } { "value" object } }
{ $description "If the quotation yields true when applied to the key/value pair, adds the key/value pair at the end of " { $snippet "accum" } "." } ;
HELP: assoc-subset
HELP: assoc-filter
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
@ -281,7 +281,7 @@ HELP: assoc-union
HELP: assoc-diff
{ $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } }
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " whose key is not contained in " { $snippet "assoc1" } "." }
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc1" } " whose key is not contained in " { $snippet "assoc2" } "." }
;
HELP: remove-all
{ $values { "assoc" assoc } { "seq" "a sequence" } { "subseq" "a new sequence" } }

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

@ -30,10 +30,10 @@ continuations ;
[ t ] [ H{ { 1 1 } { 2 2 } } [ = ] assoc-all? ] unit-test
[ f ] [ H{ { 1 2 } { 2 2 } } [ = ] assoc-all? ] unit-test
[ H{ } ] [ H{ { t f } { f t } } [ 2drop f ] assoc-subset ] unit-test
[ H{ } ] [ H{ { t f } { f t } } [ 2drop f ] assoc-filter ] unit-test
[ H{ { 3 4 } { 4 5 } { 6 7 } } ] [
H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } }
[ drop 3 >= ] assoc-subset
[ drop 3 >= ] assoc-filter
] unit-test
[ 21 ] [

8
core/assocs/assocs.factor
View File

@ -50,7 +50,7 @@ M: assoc assoc-find
: assoc-pusher ( quot -- quot' accum )
V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline
: assoc-subset ( assoc quot -- subassoc )
: assoc-filter ( assoc quot -- subassoc )
over >r assoc-pusher >r assoc-each r> r> assoc-like ; inline
: assoc-contains? ( assoc quot -- ? )
@ -110,7 +110,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
] { } assoc>map hashcode* ;
: assoc-intersect ( assoc1 assoc2 -- intersection )
swap [ nip key? ] curry assoc-subset ;
swap [ nip key? ] curry assoc-filter ;
: update ( assoc1 assoc2 -- )
swap [ swapd set-at ] curry assoc-each ;
@ -120,10 +120,10 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
[ rot update ] keep [ swap update ] keep ;
: assoc-diff ( assoc1 assoc2 -- diff )
swap [ nip key? not ] curry assoc-subset ;
[ nip key? not ] curry assoc-filter ;
: remove-all ( assoc seq -- subseq )
swap [ key? not ] curry subset ;
swap [ key? not ] curry filter ;
: (substitute)
[ dupd at* [ nip ] [ drop ] if ] curry ; inline

4
core/bootstrap/compiler/compiler.factor
View File

@ -5,7 +5,7 @@ namespaces parser kernel kernel.private classes classes.private
arrays hashtables vectors classes.tuple sbufs inference.dataflow
hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words generator command-line
vocabs io prettyprint libc compiler.units ;
vocabs io prettyprint libc compiler.units math.order ;
IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a
@ -74,6 +74,6 @@ nl
malloc calloc free memcpy
} compile
vocabs [ words [ compiled? not ] subset compile "." write flush ] each
vocabs [ words [ compiled? not ] filter compile "." write flush ] each
" done" print flush

4
core/bootstrap/image/image.factor
View File

@ -8,7 +8,7 @@ splitting growable classes classes.builtin classes.tuple
classes.tuple.private words.private io.binary io.files vocabs
vocabs.loader source-files definitions debugger float-arrays
quotations.private sequences.private combinators
io.encodings.binary ;
io.encodings.binary math.order ;
IN: bootstrap.image
: my-arch ( -- arch )
@ -305,7 +305,7 @@ M: float-array ' float-array emit-dummy-array ;
! Tuples
: (emit-tuple) ( tuple -- pointer )
[ tuple>array 1 tail-slice ]
[ tuple>array rest-slice ]
[ class transfer-word tuple-layout ] bi prefix [ ' ] map
tuple type-number dup [ emit-seq ] emit-object ;

2
core/bootstrap/primitives.factor
View File

@ -157,7 +157,7 @@ num-types get f <array> builtins set
! Catch-all class for providing a default method.
"object" "kernel" create
[ f builtins get [ ] subset union-class define-class ]
[ f builtins get [ ] filter union-class define-class ]
[ [ drop t ] "predicate" set-word-prop ]
bi

6
core/bootstrap/stage2.factor
View File

@ -22,13 +22,13 @@ SYMBOL: bootstrap-time
xref-sources ;
: load-components ( -- )
"exclude" "include"
[ get-global " " split [ empty? not ] subset ] bi@
"include" "exclude"
[ get-global " " split [ empty? not ] filter ] bi@
diff
[ "bootstrap." prepend require ] each ;
: count-words ( pred -- )
all-words swap subset length number>string write ;
all-words swap filter length number>string write ;
: print-report ( time -- )
1000 /i

4
core/classes/algebra/algebra.factor
View File

@ -183,7 +183,7 @@ C: <anonymous-complement> anonymous-complement
: largest-class ( seq -- n elt )
dup [
[ 2dup class< >r swap class< not r> and ]
with subset empty?
with filter empty?
] curry find [ "Topological sort failed" throw ] unless* ;
: sort-classes ( seq -- newseq )
@ -193,7 +193,7 @@ C: <anonymous-complement> anonymous-complement
[ ] unfold nip ;
: min-class ( class seq -- class/f )
over [ classes-intersect? ] curry subset
over [ classes-intersect? ] curry filter
dup empty? [ 2drop f ] [
tuck [ class< ] with all? [ peek ] [ drop f ] if
] if ;

4
core/classes/classes-docs.factor
View File

@ -55,7 +55,7 @@ HELP: class
{ $values { "object" object } { "class" class } }
{ $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." }
{ $class-description "The class of all class words." }
{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
HELP: classes
{ $values { "seq" "a sequence of class words" } }
@ -63,7 +63,7 @@ HELP: classes
HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: update-map
{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;

2
core/classes/classes.factor
View File

@ -33,7 +33,7 @@ PREDICATE: class < word
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) all-words [ class? ] subset ;
: classes ( -- seq ) all-words [ class? ] filter ;
: predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ;

2
core/classes/mixin/mixin.factor
View File

@ -31,7 +31,7 @@ TUPLE: check-mixin-class mixin ;
>r >r check-mixin-class 2dup members memq? r> r> if ; inline
: change-mixin-class ( class mixin quot -- )
[ members swap bootstrap-word ] swap compose keep
[ members swap bootstrap-word ] prepose keep
swap redefine-mixin-class ; inline
: add-mixin-instance ( class mixin -- )

2
core/classes/singleton/singleton-docs.factor
View File

@ -18,7 +18,7 @@ HELP: SINGLETON:
"Defines a new singleton class. The class word itself is the sole instance of the singleton class."
}
{ $examples
{ $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
{ $example "USING: classes.singleton kernel io ;" "IN: scratchpad" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
} ;
HELP: define-singleton-class

1
core/classes/tuple/tuple-docs.factor
View File

@ -341,6 +341,7 @@ HELP: new
{ $examples
{ $example
"USING: kernel prettyprint ;"
"IN: scratchpad"
"TUPLE: employee number name department ;"
"employee new ."
"T{ employee f f f f }"

4
core/classes/tuple/tuple-tests.factor
View File

@ -4,7 +4,7 @@ namespaces quotations sequences.private classes continuations
generic.standard effects classes.tuple classes.tuple.private
arrays vectors strings compiler.units accessors classes.algebra
calendar prettyprint io.streams.string splitting inspector
columns ;
columns math.order ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
@ -88,7 +88,7 @@ C: <empty> empty
[ t length ] [ object>> t eq? ] must-fail-with
[ "<constructor-test>" ]
[ "TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
[ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
TUPLE: size-test a b c d ;

2
core/classes/tuple/tuple.factor
View File

@ -166,7 +166,7 @@ M: tuple-class update-class
3tri ;
: subclasses ( class -- classes )
class-usages keys [ tuple-class? ] subset ;
class-usages keys [ tuple-class? ] filter ;
: each-subclass ( class quot -- )
>r subclasses r> each ; inline

4
core/combinators/combinators.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: combinators
USING: arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors
hashtables sorting words sets ;
hashtables sorting words sets math.order ;
IN: combinators
: cleave ( x seq -- )
[ call ] with each ;

4
core/command-line/command-line.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: command-line
USING: init continuations debugger hashtables io kernel
kernel.private namespaces parser sequences strings system
splitting io.files ;
IN: command-line
: run-bootstrap-init ( -- )
"user-init" get [
@ -54,7 +54,7 @@ SYMBOL: main-vocab-hook
"none" "run" set-global ;
: parse-command-line ( -- )
cli-args [ cli-arg ] subset
cli-args [ cli-arg ] filter
"script" get [ script-mode ] when
ignore-cli-args? [ drop ] [ [ run-file ] each ] if
"e" get [ eval ] when* ;

2
core/compiler/errors/errors.factor
View File

@ -27,7 +27,7 @@ SYMBOL: with-compiler-errors?
: errors-of-type ( type -- assoc )
compiler-errors get-global
swap [ >r nip compiler-error-type r> eq? ] curry
assoc-subset ;
assoc-filter ;
: compiler-errors. ( type -- )
errors-of-type >alist sort-keys

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

@ -1,11 +1,11 @@
IN: compiler.tests
USING: arrays compiler.units kernel kernel.private math
math.constants math.private sequences strings tools.test words
continuations sequences.private hashtables.private byte-arrays
strings.private system random layouts vectors.private
sbufs.private strings.private slots.private alien
sbufs.private strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings
namespaces libc sequences.private io.encodings.ascii ;
IN: compiler.tests
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test

4
core/compiler/tests/stack-trace.factor
View File

@ -13,11 +13,11 @@ words splitting sorting ;
[ baz ] [ 3 = ] must-fail-with
[ t ] [
symbolic-stack-trace
[ word? ] subset
[ word? ] filter
{ baz bar foo throw } tail?
] unit-test
: bleh [ 3 + ] map [ 0 > ] subset ;
: bleh [ 3 + ] map [ 0 > ] filter ;
: stack-trace-contains? symbolic-stack-trace memq? ;

4
core/compiler/units/units.factor
View File

@ -53,7 +53,7 @@ GENERIC: definitions-changed ( assoc obj -- )
[ definitions-changed ] with each ;
: changed-vocabs ( assoc -- vocabs )
[ drop word? ] assoc-subset
[ drop word? ] assoc-filter
[ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ;
: updated-definitions ( -- assoc )
@ -73,7 +73,7 @@ SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
: call-recompile-hook ( -- )
changed-definitions get keys [ word? ] subset
changed-definitions get keys [ word? ] filter
compiled-usages recompile-hook get call ;
: call-update-tuples-hook ( -- )

2
core/cpu/ppc/architecture/architecture.factor
View File

@ -4,7 +4,7 @@ USING: alien.c-types cpu.ppc.assembler cpu.architecture generic
kernel kernel.private math memory namespaces sequences words
assocs generator generator.registers generator.fixup system
layouts classes words.private alien combinators
compiler.constants ;
compiler.constants math.order ;
IN: cpu.ppc.architecture
! PowerPC register assignments

4
core/cpu/ppc/assembler/assembler.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: generator.fixup generic kernel memory namespaces
words math math.bitfields math.order io.binary ;
IN: cpu.ppc.assembler
USING: generator.fixup generic kernel math memory namespaces
words math.bitfields io.binary ;
! See the Motorola or IBM documentation for details. The opcode
! names are standard, and the operand order is the same as in

2
core/cpu/x86/64/64.factor
View File

@ -181,7 +181,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >>
: split-struct ( pairs -- seq )
[
[ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split [ empty? not ] subset ;
] { } make { t } split [ empty? not ] filter ;
: flatten-large-struct ( type -- )
heap-size cell align

3
core/cpu/x86/architecture/architecture.factor
View File

@ -3,7 +3,8 @@
USING: alien alien.c-types alien.compiler arrays
cpu.x86.assembler cpu.architecture kernel kernel.private math
memory namespaces sequences words generator generator.registers
generator.fixup system layouts combinators compiler.constants ;
generator.fixup system layouts combinators compiler.constants
math.order ;
IN: cpu.x86.architecture
HOOK: ds-reg cpu

2
core/cpu/x86/assembler/assembler.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generator.fixup io.binary kernel
combinators kernel.private math namespaces parser sequences
words system layouts ;
words system layouts math.order ;
IN: cpu.x86.assembler
! A postfix assembler for x86 and AMD64.

9
core/debugger/debugger.factor
View File

@ -6,7 +6,8 @@ strings io.styles vectors words system splitting math.parser
classes.tuple continuations continuations.private combinators
generic.math io.streams.duplex classes.builtin classes
compiler.units generic.standard vocabs threads threads.private
init kernel.private libc io.encodings accessors ;
init kernel.private libc io.encodings mirrors accessors
math.order ;
IN: debugger
GENERIC: error. ( error -- )
@ -289,6 +290,12 @@ M: encode-error summary drop "Character encoding error" ;
M: decode-error summary drop "Character decoding error" ;
M: no-such-slot summary drop "No such slot" ;
M: immutable-slot summary drop "Slot is immutable" ;
M: bad-create summary drop "Bad parameters to create" ;
<PRIVATE
: init-debugger ( -- )

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

@ -1,6 +1,6 @@
IN: definitions.tests
USING: tools.test generic kernel definitions sequences
compiler.units words ;
IN: definitions.tests
GENERIC: some-generic ( a -- b )

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

@ -79,7 +79,7 @@ IN: dlists.tests
[ dlist-push-all ] keep
[ dlist-delete-all ] keep
dlist>array
] 2keep diff assert-same-elements
] 2keep swap diff assert-same-elements
] unit-test
[ ] [

2
core/dlists/dlists.factor
View File

@ -153,7 +153,7 @@ PRIVATE>
drop ;
: dlist-each ( dlist quot -- )
[ obj>> ] swap compose dlist-each-node ; inline
[ obj>> ] prepose dlist-each-node ; inline
: dlist-slurp ( dlist quot -- )
over dlist-empty?

2
core/generator/fixup/fixup.factor
View File

@ -3,7 +3,7 @@
USING: arrays generic assocs hashtables
kernel kernel.private math namespaces sequences words
quotations strings alien.strings layouts system combinators
math.bitfields words.private cpu.architecture ;
math.bitfields words.private cpu.architecture math.order ;
IN: generator.fixup
: no-stack-frame -1 ; inline

8
core/generator/registers/registers.factor
View File

@ -4,7 +4,7 @@ USING: arrays assocs classes classes.private classes.algebra
combinators cpu.architecture generator.fixup hashtables kernel
layouts math namespaces quotations sequences system vectors
words effects alien byte-arrays bit-arrays float-arrays
accessors sets ;
accessors sets math.order ;
IN: generator.registers
SYMBOL: +input+
@ -314,7 +314,7 @@ M: phantom-retainstack finalize-height
: (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved
[ phantom-locs* ] [ stack>> ] bi zip
[ live-loc? ] assoc-subset
[ live-loc? ] assoc-filter
values ;
: live-locs ( -- seq )
@ -372,7 +372,7 @@ M: value (lazy-load)
: (compute-free-vregs) ( used class -- vector )
#! Find all vregs in 'class' which are not in 'used'.
[ vregs length reverse ] keep
[ <vreg> ] curry map diff
[ <vreg> ] curry map swap diff
>vector ;
: compute-free-vregs ( -- )
@ -484,7 +484,7 @@ M: loc lazy-store
: substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-subset >hashtable
[ substitute-vreg? ] assoc-filter >hashtable
[ >r stack>> r> substitute-here ] curry each-phantom ;
: set-operand ( value var -- )

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

@ -143,7 +143,7 @@ GENERIC: generic-forget-test-1
M: integer generic-forget-test-1 / ;
[ t ] [
\ / usage [ word? ] subset
\ / usage [ word? ] filter
[ word-name "generic-forget-test-1/integer" = ] contains?
] unit-test
@ -152,7 +152,7 @@ M: integer generic-forget-test-1 / ;
] unit-test
[ f ] [
\ / usage [ word? ] subset
\ / usage [ word? ] filter
[ word-name "generic-forget-test-1/integer" = ] contains?
] unit-test
@ -161,7 +161,7 @@ GENERIC: generic-forget-test-2
M: sequence generic-forget-test-2 = ;
[ t ] [
\ = usage [ word? ] subset
\ = usage [ word? ] filter
[ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test
@ -170,7 +170,7 @@ M: sequence generic-forget-test-2 = ;
] unit-test
[ f ] [
\ = usage [ word? ] subset
\ = usage [ word? ] filter
[ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test

4
core/generic/generic.factor
View File

@ -35,7 +35,7 @@ PREDICATE: method-spec < pair
GENERIC: effective-method ( ... generic -- method )
: next-method-class ( class generic -- class/f )
order [ class< ] with subset reverse dup length 1 =
order [ class< ] with filter reverse dup length 1 =
[ drop f ] [ second ] if ;
: next-method ( class generic -- class/f )
@ -137,7 +137,7 @@ M: method-body forget*
all-words [
"methods" word-prop keys
swap [ key? ] curry contains?
] with subset ;
] with filter ;
: implementors ( class -- seq )
dup associate implementors* ;

2
core/generic/math/math.factor
View File

@ -3,7 +3,7 @@
USING: arrays generic hashtables kernel kernel.private
math namespaces sequences words quotations layouts combinators
sequences.private classes classes.builtin classes.algebra
definitions ;
definitions math.order ;
IN: generic.math
PREDICATE: math-class < class

4
core/generic/standard/engines/engines.factor
View File

@ -26,8 +26,8 @@ M: method-body engine>quot 1quotation ;
alist>quot ;
: split-methods ( assoc class -- first second )
[ [ nip class< not ] curry assoc-subset ]
[ [ nip class< ] curry assoc-subset ] 2bi ;
[ [ nip class< not ] curry assoc-filter ]
[ [ nip class< ] curry assoc-filter ] 2bi ;
: convert-methods ( assoc class word -- assoc' )
over >r >r split-methods dup assoc-empty? [

4
core/generic/standard/engines/predicate/predicate.factor
View File

@ -17,8 +17,8 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
{
{ [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
{ [ dup length 1 = ] [ first second { } ] }
{ [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] }
[ [ first second ] [ 1 tail-slice ] bi ]
{ [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
[ [ first second ] [ rest-slice ] bi ]
} cond ;
: sort-methods ( assoc -- assoc' )

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

@ -10,7 +10,7 @@ continuations ;
[ ] [ 1000 [ dup sq ] H{ } map>assoc "testhash" set ] unit-test
[ V{ } ]
[ 1000 [ dup sq swap "testhash" get at = not ] subset ]
[ 1000 [ dup sq swap "testhash" get at = not ] filter ]
unit-test
[ t ]

3
core/heaps/heaps-docs.factor
View File

@ -1,4 +1,5 @@
USING: heaps.private help.markup help.syntax kernel math assocs ;
USING: heaps.private help.markup help.syntax kernel math assocs
math.order ;
IN: heaps
ARTICLE: "heaps" "Heaps"

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

@ -3,7 +3,7 @@
USING: arrays kernel math namespaces tools.test
heaps heaps.private math.parser random assocs sequences sorting
accessors ;
accessors math.order ;
IN: heaps.tests
[ <min-heap> heap-pop ] must-fail

2
core/heaps/heaps.factor
View File

@ -2,7 +2,7 @@
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences arrays assocs sequences.private
growable accessors ;
growable accessors math.order ;
IN: heaps
MIXIN: priority-queue

6
core/inference/backend/backend.factor
View File

@ -4,7 +4,7 @@ USING: inference.dataflow inference.state arrays generic io
io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes
continuations debugger assocs combinators compiler.errors
generic.standard.engines.tuple accessors ;
generic.standard.engines.tuple accessors math.order ;
IN: inference.backend
: recursive-label ( word -- label/f )
@ -261,7 +261,7 @@ TUPLE: cannot-unify-specials ;
: balanced? ( in out -- ? )
[ dup [ length - ] [ 2drop f ] if ] 2map
[ ] subset all-equal? ;
[ ] filter all-equal? ;
TUPLE: unbalanced-branches-error quots in out ;
@ -281,7 +281,7 @@ TUPLE: unbalanced-branches-error quots in out ;
2dup balanced? [
over supremum -rot
[ >r dupd r> unify-inputs ] 2map
[ ] subset unify-stacks
[ ] filter unify-stacks
rot drop
] [
unbalanced-branches-error

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

@ -5,7 +5,7 @@ sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units
system layouts vectors optimizer.math.partial accessors
optimizer.inlining ;
optimizer.inlining math.order ;
[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test

2
core/inference/class/class.factor
View File

@ -153,7 +153,7 @@ M: pair constraint-satisfied?
first constraint-satisfied? ;
: extract-keys ( seq assoc -- newassoc )
[ dupd at ] curry H{ } map>assoc [ nip ] assoc-subset f assoc-like ;
[ dupd at ] curry H{ } map>assoc [ nip ] assoc-filter f assoc-like ;
: annotate-node ( node -- )
#! Annotate the node with the currently-inferred set of

2
core/inference/dataflow/dataflow.factor
View File

@ -300,7 +300,7 @@ SYMBOL: node-stack
dup in-d>> first node-class ;
: active-children ( node -- seq )
children>> [ last-node ] map [ #terminate? not ] subset ;
children>> [ last-node ] map [ #terminate? not ] filter ;
DEFER: #tail?

2
core/inspector/inspector.factor
View File

@ -96,7 +96,7 @@ SYMBOL: +editable+
: namestack. ( seq -- )
[
[ global eq? not ] subset
[ global eq? not ] filter
[ keys ] map concat prune
] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ;

4
core/io/files/files-tests.factor
View File

@ -135,13 +135,13 @@ strings accessors io.encodings.utf8 ;
[ { { "kernel" t } } ] [
"core" resource-path [
"." directory [ first "kernel" = ] subset
"." directory [ first "kernel" = ] filter
] with-directory
] unit-test
[ { { "kernel" t } } ] [
"resource:core" [
"." directory [ first "kernel" = ] subset
"." directory [ first "kernel" = ] filter
] with-directory
] unit-test

10
core/io/files/files.factor
View File

@ -3,7 +3,7 @@
USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations io.encodings
io.encodings.binary init accessors ;
io.encodings.binary init accessors math.order ;
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
@ -54,7 +54,7 @@ HOOK: (file-appender) io-backend ( path -- stream )
[ path-separator? ] left-trim ;
: last-path-separator ( path -- n ? )
[ length 1- ] keep [ path-separator? ] find-last* ;
[ length 1- ] keep [ path-separator? ] find-last-from ;
HOOK: root-directory? io-backend ( path -- ? )
@ -92,7 +92,7 @@ ERROR: no-parent-directory path ;
: append-path-empty ( path1 path2 -- path' )
{
{ [ dup head.? ] [
1 tail left-trim-separators append-path-empty
rest left-trim-separators append-path-empty
] }
{ [ dup head..? ] [ drop no-parent-directory ] }
[ nip ]
@ -122,7 +122,7 @@ PRIVATE>
{ [ over empty? ] [ append-path-empty ] }
{ [ dup empty? ] [ drop ] }
{ [ dup absolute-path? ] [ nip ] }
{ [ dup head.? ] [ 1 tail left-trim-separators append-path ] }
{ [ dup head.? ] [ rest left-trim-separators append-path ] }
{ [ dup head..? ] [
2 tail left-trim-separators
>r parent-directory r> append-path
@ -232,7 +232,7 @@ HOOK: make-directory io-backend ( path -- )
dup string?
[ tuck append-path directory? 2array ] [ nip ] if
] with map
[ first { "." ".." } member? not ] subset ;
[ first { "." ".." } member? not ] filter ;
: directory ( path -- seq )
normalize-directory dup (directory) fixup-directory ;

2
core/io/streams/string/string.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel math namespaces sequences sbufs strings
generic splitting growable continuations io.streams.plain
io.encodings io.encodings.private ;
io.encodings io.encodings.private math.order ;
IN: io.streams.string
M: growable dispose drop ;

23
core/kernel/kernel-docs.factor
View File

@ -1,7 +1,7 @@
USING: generic help.markup help.syntax math memory
namespaces sequences kernel.private layouts sorting classes
kernel.private vectors combinators quotations strings words
assocs arrays ;
assocs arrays math.order ;
IN: kernel
ARTICLE: "shuffle-words" "Shuffle words"
@ -393,29 +393,8 @@ HELP: identity-tuple
{ $unchecked-example "T{ foo } dup clone = ." "f" }
} ;
HELP: <=>
{ $values { "obj1" object } { "obj2" object } { "n" real } }
{ $contract
"Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings."
$nl
"The output value is one of the following:"
{ $list
{ "positive - indicating that " { $snippet "obj1" } " follows " { $snippet "obj2" } }
{ "zero - indicating that " { $snippet "obj1" } " is equal to " { $snippet "obj2" } }
{ "negative - indicating that " { $snippet "obj1" } " precedes " { $snippet "obj2" } }
}
"The default implementation treats the two objects as sequences, and recursively compares their elements. So no extra work is required to compare sequences lexicographically."
} ;
{ <=> compare natural-sort sort-keys sort-values } related-words
HELP: compare
{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "n" integer } }
{ $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." }
{ $examples
{ $example "USING: kernel prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "3" }
} ;
HELP: clone
{ $values { "obj" object } { "cloned" "a new object" } }
{ $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;

7
core/kernel/kernel.factor
View File

@ -133,8 +133,6 @@ M: identity-tuple equal? 2drop f ;
: = ( obj1 obj2 -- ? )
2dup eq? [ 2drop t ] [ equal? ] if ; inline
GENERIC: <=> ( obj1 obj2 -- n )
GENERIC: clone ( obj -- cloned )
M: object clone ;
@ -158,6 +156,9 @@ M: callstack clone (clone) ;
: with ( param obj quot -- obj curry )
swapd [ swapd call ] 2curry ; inline
: prepose ( quot1 quot2 -- curry )
swap compose ; inline
: 3compose ( quot1 quot2 quot3 -- curry )
compose compose ; inline
@ -176,8 +177,6 @@ M: callstack clone (clone) ;
: either? ( x y quot -- ? ) bi@ or ; inline
: compare ( obj1 obj2 quot -- n ) bi@ <=> ; inline
: most ( x y quot -- z )
>r 2dup r> call [ drop ] [ nip ] if ; inline

2
core/layouts/layouts.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel assocs classes
kernel.private ;
math.order kernel.private ;
IN: layouts
SYMBOL: tag-mask

2
core/math/intervals/intervals-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax math ;
USING: help.markup help.syntax math math.order ;
IN: math.intervals
ARTICLE: "math-intervals-new" "Creating intervals"

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

@ -1,5 +1,5 @@
USING: math.intervals kernel sequences words math arrays
prettyprint tools.test random vocabs combinators ;
USING: math.intervals kernel sequences words math math.order
arrays prettyprint tools.test random vocabs combinators ;
IN: math.intervals.tests
[ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test

2
core/math/intervals/intervals.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
USING: kernel sequences arrays math combinators ;
USING: kernel sequences arrays math combinators math.order ;
IN: math.intervals
TUPLE: interval from to ;

39
core/math/math-docs.factor
View File

@ -79,28 +79,6 @@ HELP: >=
{ $values { "x" real } { "y" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
HELP: before?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: after?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: before=?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: after=?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
{ before? after? before=? after=? } related-words
HELP: +
{ $values { "x" number } { "y" number } { "z" number } }
@ -275,19 +253,6 @@ HELP: recip
{ $description "Computes a number's multiplicative inverse." }
{ $errors "Throws an error if " { $snippet "x" } " is the integer 0." } ;
HELP: max
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Outputs the greatest of two real numbers." } ;
HELP: min
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Outputs the smallest of two real numbers." } ;
HELP: between?
{ $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
{ $notes "As per the closed interval notation, the end-points are included in the interval." } ;
HELP: rem
{ $values { "x" integer } { "y" integer } { "z" integer } }
{ $description
@ -333,10 +298,6 @@ HELP: times
{ $description "Calls the quotation " { $snippet "n" } " times." }
{ $notes "If you need to pass the current index to the quotation, use " { $link each } "." } ;
HELP: [-]
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Subtracts " { $snippet "y" } " from " { $snippet "x" } ". If the result is less than zero, outputs zero." } ;
HELP: fp-nan?
{ $values { "x" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;

22
core/math/math.factor
View File

@ -17,11 +17,6 @@ MATH: <= ( x y -- ? ) foldable
MATH: > ( x y -- ? ) foldable
MATH: >= ( x y -- ? ) foldable
: after? ( obj1 obj2 -- ? ) <=> 0 > ; inline
: before? ( obj1 obj2 -- ? ) <=> 0 < ; inline
: after=? ( obj1 obj2 -- ? ) <=> 0 >= ; inline
: before=? ( obj1 obj2 -- ? ) <=> 0 <= ; inline
MATH: + ( x y -- z ) foldable
MATH: - ( x y -- z ) foldable
MATH: * ( x y -- z ) foldable
@ -61,23 +56,14 @@ M: object zero? drop f ;
: sq ( x -- y ) dup * ; inline
: neg ( x -- -x ) 0 swap - ; inline
: recip ( x -- y ) 1 swap / ; inline
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
: ?1+ [ 1+ ] [ 0 ] if* ; inline
: /f ( x y -- z ) >r >float r> >float float/f ; inline
: max ( x y -- z ) [ > ] most ; inline
: min ( x y -- z ) [ < ] most ; inline
: between? ( x y z -- ? )
pick >= [ >= ] [ 2drop f ] if ; inline
: rem ( x y -- z ) tuck mod over + swap mod ; foldable
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
: [-] ( x y -- z ) - 0 max ; inline
: 2^ ( n -- 2^n ) 1 swap shift ; inline
: even? ( n -- ? ) 1 bitand zero? ;
@ -96,13 +82,9 @@ M: number equal? number= ;
M: real hashcode* nip >fixnum ;
M: real <=> - ;
! real and sequence overlap. we disambiguate:
M: integer hashcode* nip >fixnum ;
M: integer <=> - ;
GENERIC: fp-nan? ( x -- ? )
M: object fp-nan?
@ -161,7 +143,7 @@ PRIVATE>
iterate-prep (each-integer) ; inline
: times ( n quot -- )
[ drop ] swap compose each-integer ; inline
[ drop ] prepose each-integer ; inline
: find-integer ( n quot -- i )
iterate-prep (find-integer) ; inline

5
core/mirrors/mirrors-docs.factor
View File

@ -30,6 +30,7 @@ HELP: <mirror>
{ $examples
{ $example
"USING: assocs mirrors prettyprint ;"
"IN: scratchpad"
"TUPLE: circle center radius ;"
"C: <circle> circle"
"{ 100 50 } 15 <circle> <mirror> >alist ."
@ -37,10 +38,6 @@ HELP: <mirror>
}
} ;
HELP: >mirror<
{ $values { "mirror" mirror } { "obj" object } { "slots" "a sequence of " { $link slot-spec } " instances" } }
{ $description "Pushes the object being viewed in the mirror together with its slots." } ;
HELP: make-mirror
{ $values { "obj" object } { "assoc" assoc } }
{ $description "Creates an assoc which reflects the internal structure of the object." } ;

14
core/mirrors/mirrors-tests.factor
View File

@ -1,4 +1,4 @@
USING: mirrors tools.test assocs kernel arrays ;
USING: mirrors tools.test assocs kernel arrays accessors ;
IN: mirrors.tests
TUPLE: foo bar baz ;
@ -14,3 +14,15 @@ C: <foo> foo
[ 3 ] [
3 "baz" 1 2 <foo> [ <mirror> set-at ] keep foo-baz
] unit-test
[ 3 "hi" 1 2 <foo> <mirror> set-at ] [
[ no-such-slot? ]
[ name>> "hi" = ]
[ object>> foo? ] tri and and
] must-fail-with
[ 3 "numerator" 1/2 <mirror> set-at ] [
[ immutable-slot? ]
[ name>> "numerator" = ]
[ object>> 1/2 = ] tri and and
] must-fail-with

29
core/mirrors/mirrors.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel sequences generic words
arrays classes slots slots.private classes.tuple math vectors
quotations sorting prettyprint ;
quotations sorting prettyprint accessors ;
IN: mirrors
: all-slots ( class -- slots )
@ -16,33 +16,32 @@ TUPLE: mirror object slots ;
: <mirror> ( object -- mirror )
dup object-slots mirror boa ;
: >mirror< ( mirror -- obj slots )
dup mirror-object swap mirror-slots ;
ERROR: no-such-slot object name ;
: mirror@ ( slot-name mirror -- obj slot-spec )
>mirror< swapd slot-named ;
ERROR: immutable-slot object name ;
M: mirror at*
mirror@ dup [ slot-spec-offset slot t ] [ 2drop f f ] if ;
[ nip object>> ] [ slots>> slot-named ] 2bi
dup [ offset>> slot t ] [ 2drop f f ] if ;
M: mirror set-at ( val key mirror -- )
mirror@ dup [
dup slot-spec-writer [
slot-spec-offset set-slot
[ nip object>> ] [ drop ] [ slots>> slot-named ] 2tri dup [
dup writer>> [
nip offset>> set-slot
] [
"Immutable slot" throw
drop immutable-slot
] if
] [
"No such slot" throw
drop no-such-slot
] if ;
M: mirror delete-at ( key mirror -- )
f -rot set-at ;
M: mirror >alist ( mirror -- alist )
>mirror<
[ [ slot-spec-offset slot ] with map ] keep
[ slot-spec-name ] map swap zip ;
[ slots>> [ name>> ] map ]
[ [ object>> ] [ slots>> ] bi [ offset>> slot ] with map ] bi
zip ;
M: mirror assoc-size mirror-slots length ;
@ -50,7 +49,7 @@ INSTANCE: mirror assoc
: sort-assoc ( assoc -- alist )
>alist
[ dup first unparse-short swap ] { } map>assoc
[ [ first unparse-short ] keep ] { } map>assoc
sort-keys values ;
GENERIC: make-mirror ( obj -- assoc )

2
core/namespaces/namespaces-docs.factor
View File

@ -87,7 +87,7 @@ HELP: +@
{ $description "Adds " { $snippet "n" } " to the value of the variable. A variable value of " { $link f } " is interpreted as being zero." }
{ $side-effects "variable" }
{ $examples
{ $example "USING: namespaces prettyprint ;" "SYMBOL: foo\n1 foo +@\n10 foo +@\nfoo get ." "11" }
{ $example "USING: namespaces prettyprint ;" "IN: scratchpad" "SYMBOL: foo\n1 foo +@\n10 foo +@\nfoo get ." "11" }
} ;
HELP: inc

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

@ -1,5 +1,5 @@
IN: namespaces.tests
USING: kernel namespaces tools.test words ;
IN: namespaces.tests
H{ } clone "test-namespace" set

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

@ -87,7 +87,7 @@ M: node optimize-node* drop t f ;
: compute-value-substitutions ( #call/#merge #return/#values -- assoc )
[ out-d>> ] [ in-d>> ] bi* 2array unify-lengths flip
[ = not ] assoc-subset >hashtable ;
[ = not ] assoc-filter >hashtable ;
: cleanup-inlining ( #return/#values -- newnode changed? )
dup node-successor [

4
core/optimizer/control/control.factor
View File

@ -75,7 +75,7 @@ USE: prettyprint
M: #call-label collect-label-info*
node-param label-info get at
node-stack get over third tail
[ [ #label? ] subset [ node-param ] map ] keep
[ [ #label? ] filter [ node-param ] map ] keep
[ node-successor #tail? ] all? 2array
swap second push ;
@ -91,7 +91,7 @@ SYMBOL: potential-loops
: remove-non-tail-calls ( -- )
label-info get
[ nip second [ second ] all? ] assoc-subset
[ nip second [ second ] all? ] assoc-filter
[ first ] assoc-map
potential-loops set ;

4
core/optimizer/def-use/def-use.factor
View File

@ -56,7 +56,7 @@ UNION: #killable
: purge-invariants ( stacks -- seq )
#! Output a sequence of values which are not present in the
#! same position in each sequence of the stacks sequence.
unify-lengths flip [ all-eq? not ] subset concat ;
unify-lengths flip [ all-eq? not ] filter concat ;
M: #label node-def-use
[
@ -75,7 +75,7 @@ M: #branch node-def-use
dup branch-def-use (node-def-use) ;
: compute-dead-literals ( -- values )
def-use get [ >r value? r> empty? and ] assoc-subset ;
def-use get [ >r value? r> empty? and ] assoc-filter ;
DEFER: kill-nodes
SYMBOL: dead-literals

4
core/optimizer/math/partial/partial.factor
View File

@ -85,7 +85,7 @@ PREDICATE: math-partial < word
: define-math-ops ( op -- )
{ fixnum bignum float }
[ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
[ nip ] assoc-subset
[ nip ] assoc-filter
[ word-def peek ] assoc-map % ;
SYMBOL: math-ops
@ -155,7 +155,7 @@ SYMBOL: fast-math-ops
[ drop math-class-max swap specific-method >boolean ] if ;
: (derived-ops) ( word assoc -- words )
swap [ rot first eq? nip ] curry assoc-subset values ;
swap [ rot first eq? nip ] curry assoc-filter values ;
: derived-ops ( word -- words )
[ 1array ]

2
core/optimizer/specializers/specializers.factor
View File

@ -12,7 +12,7 @@ IN: optimizer.specializers
: make-specializer ( classes -- quot )
dup length <reversed>
[ (picker) 2array ] 2map
[ drop object eq? not ] assoc-subset
[ drop object eq? not ] assoc-filter
dup empty? [ drop [ t ] ] [
[ (make-specializer) ] { } assoc>map
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce

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

@ -51,9 +51,11 @@ ARTICLE: "vocabulary-search-errors" "Word lookup errors"
ARTICLE: "vocabulary-search" "Vocabulary search path"
"When the parser reads a token, it attempts to look up a word named by that token. The lookup is performed by searching each vocabulary in the search path, in order."
$nl
"For a source file the vocabulary search path starts off with two vocabularies:"
{ $code "syntax\nscratchpad" }
"The " { $vocab-link "syntax" } " vocabulary consists of a set of parsing words for reading Factor data and defining new words. The " { $vocab-link "scratchpad" } " vocabulary is the default vocabulary for new word definitions."
"For a source file the vocabulary search path starts off with one vocabulary:"
{ $code "syntax" }
"The " { $vocab-link "syntax" } " vocabulary consists of a set of parsing words for reading Factor data and defining new words."
$nl
"In the listener, the " { $vocab-link "scratchpad" } " is the default vocabulary for new word definitions. However, when loading source files, there is no default vocabulary. Defining words before declaring a vocabulary with " { $link POSTPONE: IN: } " results in an error."
$nl
"At the interactive listener, the default search path contains many more vocabularies. Details on the default search path and parser invocation are found in " { $link "parser" } "."
$nl
@ -294,6 +296,10 @@ HELP: use
HELP: in
{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ;
HELP: current-vocab
{ $values { "str" "a vocabulary" } }
{ $description "Returns the vocabulary stored in the " { $link in } " symbol. Throws an error if the current vocabulary is " { $link f } "." } ;
HELP: (use+)
{ $values { "vocab" "an assoc mapping strings to words" } }
{ $description "Adds an assoc at the front of the search path." }
@ -323,7 +329,7 @@ HELP: set-in
$parsing-note ;
HELP: create-in
{ $values { "string" "a word name" } { "word" "a new word" } }
{ $values { "str" "a word name" } { "word" "a new word" } }
{ $description "Creates a word in the current vocabulary. Until re-defined, the word throws an error when invoked." }
$parsing-note ;
@ -451,7 +457,7 @@ HELP: bootstrap-syntax
HELP: with-file-vocabs
{ $values { "quot" quotation } }
{ $description "Calls the quotation in a scope with the initial the vocabulary search path for parsing a file. This consists of the " { $snippet "syntax" } " vocabulary together with the " { $snippet "scratchpad" } " vocabulary." } ;
{ $description "Calls the quotation in a scope with the initial the vocabulary search path for parsing a file. This consists of just the " { $snippet "syntax" } " vocabulary." } ;
HELP: parse-fresh
{ $values { "lines" "a sequence of strings" } { "quot" quotation } }

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

@ -3,6 +3,7 @@ io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations
sorting classes.tuple compiler.units debugger vocabs
vocabs.loader accessors ;
IN: parser.tests
[
@ -429,3 +430,5 @@ must-fail-with
[
"USE: this-better-not-exist" eval
] must-fail
[ ": foo ;" eval ] [ error>> no-current-vocab? ] must-fail-with

40
core/parser/parser.factor
View File

@ -63,7 +63,7 @@ t parser-notes set-global
: skip ( i seq ? -- n )
over >r
[ swap CHAR: \s eq? xor ] curry find* drop
[ swap CHAR: \s eq? xor ] curry find-from drop
[ r> drop ] [ r> length ] if* ;
: change-lexer-column ( lexer quot -- )
@ -132,7 +132,7 @@ name>char-hook global [
"{" ?head-slice [
CHAR: } over index cut-slice
>r >string name>char-hook get call r>
1 tail-slice
rest-slice
] [
6 cut-slice >r hex> r>
] if ;
@ -146,7 +146,7 @@ name>char-hook global [
: (parse-string) ( str -- m )
dup [ "\"\\" member? ] find dup [
>r cut-slice >r % r> 1 tail-slice r>
>r cut-slice >r % r> rest-slice r>
dup CHAR: " = [
drop slice-from
] [
@ -207,7 +207,7 @@ SYMBOL: in
: add-use ( seq -- ) [ use+ ] each ;
: set-use ( seq -- )
[ vocab-words ] map [ ] subset >vector use set ;
[ vocab-words ] map [ ] filter >vector use set ;
: check-vocab-string ( name -- name )
dup string?
@ -233,8 +233,16 @@ PREDICATE: unexpected-eof < unexpected
: parse-tokens ( end -- seq )
100 <vector> swap (parse-tokens) >array ;
: create-in ( string -- word )
in get create dup set-word dup save-location ;
ERROR: no-current-vocab ;
M: no-current-vocab summary ( obj -- )
drop "Current vocabulary is f, use IN:" ;
: current-vocab ( -- str )
in get [ no-current-vocab ] unless* ;
: create-in ( str -- word )
current-vocab create dup set-word dup save-location ;
: CREATE ( -- word ) scan create-in ;
@ -243,7 +251,7 @@ PREDICATE: unexpected-eof < unexpected
: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
: create-class-in ( word -- word )
in get create
current-vocab create
dup save-class-location
dup predicate-word dup set-word save-location ;
@ -262,7 +270,7 @@ M: no-word-error summary
: no-word ( name -- newword )
dup no-word-error boa
swap words-named [ forward-reference? not ] subset
swap words-named [ forward-reference? not ] filter
word-restarts throw-restarts
dup word-vocabulary (use+) ;
@ -270,7 +278,7 @@ M: no-word-error summary
dup forward-reference? [
drop
use get
[ at ] with map [ ] subset
[ at ] with map [ ] filter
[ forward-reference? not ] find nip
] [
nip
@ -337,6 +345,11 @@ M: invalid-slot-name summary
[ >r tuple parse-tuple-slots r> prefix ]
} case 3dup check-slot-shadowing ;
ERROR: not-in-a-method-error ;
M: not-in-a-method-error summary
drop "call-next-method can only be called in a method definition" ;
ERROR: staging-violation word ;
M: staging-violation summary
@ -440,8 +453,7 @@ SYMBOL: bootstrap-syntax
: with-file-vocabs ( quot -- )
[
"scratchpad" in set
{ "syntax" "scratchpad" } set-use
f in set { "syntax" } set-use
bootstrap-syntax get [ use get push ] when*
call
] with-scope ; inline
@ -506,10 +518,10 @@ SYMBOL: interactive-vocabs
] if ;
: filter-moved ( assoc1 assoc2 -- seq )
assoc-diff [
swap assoc-diff [
drop where dup [ first ] when
file get source-file-path =
] assoc-subset keys ;
] assoc-filter keys ;
: removed-definitions ( -- assoc1 assoc2 )
new-definitions old-definitions
@ -524,7 +536,7 @@ SYMBOL: interactive-vocabs
: reset-removed-classes ( -- )
removed-classes
filter-moved [ class? ] subset [ reset-class ] each ;
filter-moved [ class? ] filter [ reset-class ] each ;
: fix-class-words ( -- )
#! If a class word had a compound definition which was

2
core/prettyprint/backend/backend.factor
View File

@ -3,7 +3,7 @@
USING: arrays byte-arrays bit-arrays generic hashtables io
assocs kernel math namespaces sequences strings sbufs io.styles
vectors words prettyprint.config prettyprint.sections quotations
io io.files math.parser effects classes.tuple
io io.files math.parser effects classes.tuple math.order
classes.tuple.private classes float-arrays ;
IN: prettyprint.backend

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

@ -242,8 +242,16 @@ HELP: definer
{ $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } }
{ $contract "Outputs the parsing words which delimit the definition." }
{ $examples
{ $example "USING: definitions prettyprint ;" ": foo ; \\ foo definer . ." ";\nPOSTPONE: :" }
{ $example "USING: definitions prettyprint ;" "SYMBOL: foo \\ foo definer . ." "f\nPOSTPONE: SYMBOL:" }
{ $example "USING: definitions prettyprint ;"
"IN: scratchpad"
": foo ; \\ foo definer . ."
";\nPOSTPONE: :"
}
{ $example "USING: definitions prettyprint ;"
"IN: scratchpad"
"SYMBOL: foo \\ foo definer . ."
"f\nPOSTPONE: SYMBOL:"
}
}
{ $notes "This word is used in the implementation of " { $link see } "." } ;

2
core/prettyprint/prettyprint.factor
View File

@ -45,7 +45,7 @@ sets ;
] if ;
: vocabs. ( in use -- )
dupd remove [ { "syntax" "scratchpad" } member? not ] subset
dupd remove [ { "syntax" "scratchpad" } member? not ] filter
use. in. ;
: with-use ( obj quot -- )

4
core/prettyprint/sections/sections.factor
View File

@ -171,7 +171,7 @@ M: block section-fits? ( section -- ? )
line-limit? [ drop t ] [ call-next-method ] if ;
: pprint-sections ( block advancer -- )
swap sections>> [ line-break? not ] subset
swap sections>> [ line-break? not ] filter
unclip pprint-section [
dup rot call pprint-section
] with each ; inline
@ -310,7 +310,7 @@ M: f section-end-group? drop f ;
2dup 1+ swap ?nth next set
swap nth dup split-before dup , split-after
] with each
] { } make { t } split [ empty? not ] subset ;
] { } make { t } split [ empty? not ] filter ;
: break-group? ( seq -- ? )
[ first section-fits? ] [ peek section-fits? not ] bi and ;

6
core/quotations/quotations.factor
View File

@ -50,14 +50,14 @@ M: curry nth
INSTANCE: curry immutable-sequence
M: compose length
dup compose-first length
swap compose-second length + ;
[ compose-first length ]
[ compose-second length ] bi + ;
M: compose nth
2dup compose-first length < [
compose-first
] [
[ compose-first length - ] keep compose-second
[ compose-first length - ] [ compose-second ] bi
] if nth ;
INSTANCE: compose immutable-sequence

45
core/sequences/sequences-docs.factor
View File

@ -1,5 +1,5 @@
USING: arrays bit-arrays help.markup help.syntax
sequences.private vectors strings sbufs kernel math ;
USING: arrays bit-arrays help.markup help.syntax math
sequences.private vectors strings sbufs kernel math.order ;
IN: sequences
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
@ -92,6 +92,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
{ $subsection subseq }
{ $subsection head }
{ $subsection tail }
{ $subsection rest }
{ $subsection head* }
{ $subsection tail* }
"Taking a sequence apart into a head and a tail:"
@ -105,6 +106,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
{ $subsection <slice> }
{ $subsection head-slice }
{ $subsection tail-slice }
{ $subsection rest-slice }
{ $subsection head-slice* }
{ $subsection tail-slice* }
"Taking a sequence apart into a head and a tail:"
@ -127,7 +129,7 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
{ $subsection unfold }
"Filtering:"
{ $subsection push-if }
{ $subsection subset } ;
{ $subsection filter } ;
ARTICLE: "sequences-tests" "Testing sequences"
"Testing for an empty sequence:"
@ -153,17 +155,17 @@ ARTICLE: "sequences-tests" "Testing sequences"
ARTICLE: "sequences-search" "Searching sequences"
"Finding the index of an element:"
{ $subsection index }
{ $subsection index* }
{ $subsection index-from }
{ $subsection last-index }
{ $subsection last-index* }
{ $subsection last-index-from }
"Finding the start of a subsequence:"
{ $subsection start }
{ $subsection start* }
"Finding the index of an element satisfying a predicate:"
{ $subsection find }
{ $subsection find* }
{ $subsection find-from }
{ $subsection find-last }
{ $subsection find-last* } ;
{ $subsection find-last-from } ;
ARTICLE: "sequences-destructive" "Destructive operations"
"These words modify their input, instead of creating a new sequence."
@ -500,9 +502,9 @@ HELP: find
{ $snippet "( elt -- ? )" } }
{ "i" "the index of the first match, or f" }
{ "elt" "the first matching element, or " { $link f } } }
{ $description "A simpler variant of " { $link find* } " where the starting index is 0." } ;
{ $description "A simpler variant of " { $link find-from } " where the starting index is 0." } ;
HELP: find*
HELP: find-from
{ $values { "n" "a starting index" }
{ "seq" sequence }
{ "quot" "a quotation with stack effect "
@ -513,9 +515,9 @@ HELP: find*
HELP: find-last
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $description "A simpler variant of " { $link find-last* } " where the starting index is one less than the length of the sequence." } ;
{ $description "A simpler variant of " { $link find-last-from } " where the starting index is one less than the length of the sequence." } ;
HELP: find-last*
HELP: find-last-from
{ $values { "n" "a starting index" } { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $description "Applies the quotation to each element of the sequence in reverse order, until it outputs a true value or the start of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ;
@ -530,9 +532,9 @@ HELP: all?
HELP: push-if
{ $values { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } }
{ $description "Adds the element at the end of the sequence if the quotation yields a true value." }
{ $notes "This word is a factor of " { $link subset } "." } ;
{ $notes "This word is a factor of " { $link filter } "." } ;
HELP: subset
HELP: filter
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "subseq" "a new sequence" } }
{ $description "Applies the quotation to each element in turn, and outputs a new sequence containing the elements of the original sequence for which the quotation output a true value." } ;
@ -562,9 +564,9 @@ HELP: index
{ $values { "obj" object } { "seq" sequence } { "n" "an index" } }
{ $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ". If no element is found, outputs " { $link f } "." } ;
{ index index* last-index last-index* member? memq? } related-words
{ index index-from last-index last-index-from member? memq? } related-words
HELP: index*
HELP: index-from
{ $values { "obj" object } { "i" "a start index" } { "seq" sequence } { "n" "an index" } }
{ $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ", starting the search from the " { $snippet "i" } "th element. If no element is found, outputs " { $link f } "." } ;
@ -572,7 +574,7 @@ HELP: last-index
{ $values { "obj" object } { "seq" sequence } { "n" "an index" } }
{ $description "Outputs the index of the last element in the sequence equal to " { $snippet "obj" } "; the sequence is traversed back to front. If no element is found, outputs " { $link f } "." } ;
HELP: last-index*
HELP: last-index-from
{ $values { "obj" object } { "i" "a start index" } { "seq" sequence } { "n" "an index" } }
{ $description "Outputs the index of the last element in the sequence equal to " { $snippet "obj" } ", traversing the sequence backwards starting from the " { $snippet "i" } "th element and finishing at the first. If no element is found, outputs " { $link f } "." } ;
@ -834,6 +836,12 @@ HELP: tail-slice
{ $description "Outputs a virtual sequence sharing storage with all elements from the " { $snippet "n" } "th index until the end of the input sequence." }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: rest-slice
{ $values { "seq" sequence } { "slice" "a slice" } }
{ $description "Outputs a virtual sequence sharing storage with all elements from the 1st index until the end of the input sequence." }
{ $notes "Equivalent to " { $snippet "1 tail" } }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: head-slice*
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "slice" "a slice" } }
{ $description "Outputs a virtual sequence sharing storage with all elements of " { $snippet "seq" } " until the " { $snippet "n" } "th element from the end. In other words, it outputs a sequence of the first " { $snippet "l-n" } " elements of the input sequence, where " { $snippet "l" } " is its length." }
@ -854,6 +862,11 @@ HELP: tail
{ $description "Outputs a new sequence consisting of the input sequence with the first n items removed." }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: rest
{ $values { "seq" sequence } { "tailseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of the input sequence with the first item removed." }
{ $errors "Throws an error on an empty sequence." } ;
HELP: head*
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "headseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of all elements of " { $snippet "seq" } " until the " { $snippet "n" } "th element from the end. In other words, it outputs a sequence of the first " { $snippet "l-n" } " elements of the input sequence, where " { $snippet "l" } " is its length." }

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

@ -27,7 +27,7 @@ IN: sequences.tests
[ "hello world" "aeiou" [ member? ] curry find ] unit-test
[ 4 CHAR: o ]
[ 3 "hello world" "aeiou" [ member? ] curry find* ] unit-test
[ 3 "hello world" "aeiou" [ member? ] curry find-from ] unit-test
[ f ] [ 3 [ ] member? ] unit-test
[ f ] [ 3 [ 1 2 ] member? ] unit-test
@ -39,18 +39,18 @@ IN: sequences.tests
[ 4 ] [ CHAR: x "tuvwxyz" >vector index ] unit-test
[ f ] [ CHAR: x 5 "tuvwxyz" >vector index* ] unit-test
[ f ] [ CHAR: x 5 "tuvwxyz" >vector index-from ] unit-test
[ f ] [ CHAR: a 0 "tuvwxyz" >vector index* ] unit-test
[ f ] [ CHAR: a 0 "tuvwxyz" >vector index-from ] unit-test
[ f ] [ [ "Hello" { } 0.75 ] [ string? ] all? ] unit-test
[ t ] [ [ ] [ ] all? ] unit-test
[ t ] [ [ "hi" t 0.5 ] [ ] all? ] unit-test
[ [ 1 2 3 ] ] [ [ 1 4 2 5 3 6 ] [ 4 < ] subset ] unit-test
[ { 4 2 6 } ] [ { 1 4 2 5 3 6 } [ 2 mod 0 = ] subset ] unit-test
[ [ 1 2 3 ] ] [ [ 1 4 2 5 3 6 ] [ 4 < ] filter ] unit-test
[ { 4 2 6 } ] [ { 1 4 2 5 3 6 } [ 2 mod 0 = ] filter ] unit-test
[ [ 3 ] ] [ [ 1 2 3 ] 2 [ swap < ] curry subset ] unit-test
[ [ 3 ] ] [ [ 1 2 3 ] 2 [ swap < ] curry filter ] unit-test
[ "hello world how are you" ]
[ { "hello" "world" "how" "are" "you" } " " join ]
@ -169,9 +169,9 @@ unit-test
[ 3 "a" ] [ { "a" "b" "c" "a" "d" } [ "a" = ] find-last ] unit-test
[ f f ] [ 100 { 1 2 3 } [ 1 = ] find* ] unit-test
[ f f ] [ 100 { 1 2 3 } [ 1 = ] find-last* ] unit-test
[ f f ] [ -1 { 1 2 3 } [ 1 = ] find* ] unit-test
[ f f ] [ 100 { 1 2 3 } [ 1 = ] find-from ] unit-test
[ f f ] [ 100 { 1 2 3 } [ 1 = ] find-last-from ] unit-test
[ f f ] [ -1 { 1 2 3 } [ 1 = ] find-from ] unit-test
[ 0 ] [ { "a" "b" "c" } { "A" "B" "C" } mismatch ] unit-test
@ -187,9 +187,6 @@ unit-test
[ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] bi@ ] unit-test
[ -1 ] [ "ab" "abc" <=> ] unit-test
[ 1 ] [ "abc" "ab" <=> ] unit-test
[ 1 4 9 16 16 V{ f 1 4 9 16 } ] [
V{ } clone "cache-test" set
1 "cache-test" get [ sq ] cache-nth

80
core/sequences/sequences.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private slots.private math math.private
math.order ;
IN: sequences
USING: kernel kernel.private slots.private math math.private ;
MIXIN: sequence
@ -36,7 +37,7 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
: set-third ( third seq -- ) 2 swap set-nth ; inline
: set-fourth ( fourth seq -- ) 3 swap set-nth ; inline
: push ( elt seq -- ) dup length swap set-nth ;
: push ( elt seq -- ) [ length ] [ set-nth ] bi ;
: bounds-check? ( n seq -- ? )
length 1- 0 swap between? ; inline
@ -100,13 +101,13 @@ M: integer nth-unsafe drop ;
INSTANCE: integer immutable-sequence
: first2-unsafe
[ 0 swap nth-unsafe ] keep 1 swap nth-unsafe ; inline
[ 0 swap nth-unsafe 1 ] [ nth-unsafe ] bi ; inline
: first3-unsafe
[ first2-unsafe ] keep 2 swap nth-unsafe ; inline
[ first2-unsafe 2 ] [ nth-unsafe ] bi ; inline
: first4-unsafe
[ first3-unsafe ] keep 3 swap nth-unsafe ; inline
[ first3-unsafe 3 ] [ nth-unsafe ] bi ; inline
: exchange-unsafe ( m n seq -- )
[ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck
@ -179,7 +180,7 @@ M: reversed length reversed-seq length ;
INSTANCE: reversed virtual-sequence
: reverse ( seq -- newseq ) [ <reversed> ] keep like ;
: reverse ( seq -- newseq ) [ <reversed> ] [ like ] bi ;
! A slice of another sequence.
TUPLE: slice from to seq ;
@ -201,7 +202,7 @@ ERROR: slice-error reason ;
M: slice virtual-seq slice-seq ;
M: slice virtual@ [ slice-from + ] keep slice-seq ;
M: slice virtual@ [ slice-from + ] [ slice-seq ] bi ;
M: slice length dup slice-to swap slice-from - ;
@ -209,6 +210,8 @@ M: slice length dup slice-to swap slice-from - ;
: tail-slice ( seq n -- slice ) (tail) <slice> ;
: rest-slice ( seq -- slice ) 1 tail-slice ;
: head-slice* ( seq n -- slice ) from-end head-slice ;
: tail-slice* ( seq n -- slice ) from-end tail-slice ;
@ -248,12 +251,14 @@ INSTANCE: repetition immutable-sequence
PRIVATE>
: subseq ( from to seq -- subseq )
[ check-slice prepare-subseq (copy) ] keep like ;
[ check-slice prepare-subseq (copy) ] [ like ] bi ;
: head ( seq n -- headseq ) (head) subseq ;
: tail ( seq n -- tailseq ) (tail) subseq ;
: rest ( seq -- tailseq ) 1 tail ;
: head* ( seq n -- headseq ) from-end head ;
: tail* ( seq n -- tailseq ) from-end tail ;
@ -267,11 +272,12 @@ M: sequence clone-like
M: immutable-sequence clone-like like ;
: push-all ( src dest -- ) [ length ] keep copy ;
: push-all ( src dest -- ) [ length ] [ copy ] bi ;
: ((append)) ( seq1 seq2 accum -- accum )
[ >r over length r> copy ] keep
[ 0 swap copy ] keep ; inline
[ >r over length r> copy ]
[ 0 swap copy ]
[ ] tri ; inline
: (append) ( seq1 seq2 exemplar -- newseq )
>r over length over length + r>
@ -279,8 +285,8 @@ M: immutable-sequence clone-like like ;
: (3append) ( seq1 seq2 seq3 exemplar -- newseq )
>r pick length pick length pick length + + r> [
[ >r pick length pick length + r> copy ] keep
((append))
[ >r pick length pick length + r> copy ]
[ ((append)) ] bi
] new-like ; inline
: append ( seq1 seq2 -- newseq ) over (append) ;
@ -323,7 +329,7 @@ M: immutable-sequence clone-like like ;
: (find) ( seq quot quot' -- i elt )
pick >r >r (each) r> call r> finish-find ; inline
: (find*) ( n seq quot quot' -- i elt )
: (find-from) ( n seq quot quot' -- i elt )
>r >r 2dup bounds-check? [
r> r> (find)
] [
@ -332,7 +338,7 @@ M: immutable-sequence clone-like like ;
: (monotonic) ( seq quot -- ? )
[ 2dup nth-unsafe rot 1+ rot nth-unsafe ]
swap compose curry ; inline
prepose curry ; inline
: (interleave) ( n elt between quot -- )
roll zero? [ nip ] [ swapd 2slip ] if call ; inline
@ -373,14 +379,14 @@ PRIVATE>
: 2all? ( seq1 seq2 quot -- ? )
(2each) all-integers? ; inline
: find* ( n seq quot -- i elt )
[ (find-integer) ] (find*) ; inline
: find-from ( n seq quot -- i elt )
[ (find-integer) ] (find-from) ; inline
: find ( seq quot -- i elt )
[ find-integer ] (find) ; inline
: find-last* ( n seq quot -- i elt )
[ nip find-last-integer ] (find*) ; inline
: find-last-from ( n seq quot -- i elt )
[ nip find-last-integer ] (find-from) ; inline
: find-last ( seq quot -- i elt )
[ >r 1- r> find-last-integer ] (find) ; inline
@ -394,7 +400,7 @@ PRIVATE>
: pusher ( quot -- quot accum )
V{ } clone [ [ push-if ] 2curry ] keep ; inline
: subset ( seq quot -- subseq )
: filter ( seq quot -- subseq )
over >r pusher >r each r> r> like ; inline
: monotonic? ( seq quot -- ? )
@ -414,14 +420,14 @@ PRIVATE>
: index ( obj seq -- n )
[ = ] with find drop ;
: index* ( obj i seq -- n )
rot [ = ] curry find* drop ;
: index-from ( obj i seq -- n )
rot [ = ] curry find-from drop ;
: last-index ( obj seq -- n )
[ = ] with find-last drop ;
: last-index* ( obj i seq -- n )
rot [ = ] curry find-last* drop ;
: last-index-from ( obj i seq -- n )
rot [ = ] curry find-last-from drop ;
: contains? ( seq quot -- ? )
find drop >boolean ; inline
@ -433,7 +439,7 @@ PRIVATE>
[ eq? ] with contains? ;
: remove ( obj seq -- newseq )
[ = not ] with subset ;
[ = not ] with filter ;
: cache-nth ( i seq quot -- elt )
2over ?nth dup [
@ -472,7 +478,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: move ( to from seq -- )
2over number=
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
[ 3drop ] [ [ nth swap ] [ set-nth ] bi ] if ; inline
: (delete) ( elt store scan seq -- elt store scan seq )
2dup length < [
@ -497,9 +503,9 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
[ 0 swap copy ] keep
] new-like ;
: peek ( seq -- elt ) dup length 1- swap nth ;
: peek ( seq -- elt ) [ length 1- ] [ nth ] bi ;
: pop* ( seq -- ) dup length 1- swap set-length ;
: pop* ( seq -- ) [ length 1- ] [ set-length ] bi ;
: move-backward ( shift from to seq -- )
2over number= [
@ -519,7 +525,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: (open-slice) ( shift from to seq ? -- )
[
>r >r 1- r> 1- r> move-forward
>r [ 1- ] bi@ r> move-forward
] [
>r >r over - r> r> move-backward
] if ;
@ -544,7 +550,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
copy ;
: pop ( seq -- elt )
dup length 1- swap [ nth ] 2keep set-length ;
[ length 1- ] [ [ nth ] [ set-length ] 2bi ] bi ;
: all-equal? ( seq -- ? ) [ = ] monotonic? ;
@ -609,7 +615,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
] if ;
: cut-slice ( seq n -- before after )
[ head-slice ] 2keep tail-slice ;
[ head-slice ] [ tail-slice ] 2bi ;
: midpoint@ ( seq -- n ) length 2/ ; inline
@ -634,10 +640,10 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
] if ; inline
: cut ( seq n -- before after )
[ head ] 2keep tail ;
[ head ] [ tail ] 2bi ;
: cut* ( seq n -- before after )
[ head* ] 2keep tail* ;
[ head* ] [ tail* ] 2bi ;
<PRIVATE
@ -650,7 +656,7 @@ PRIVATE>
: start* ( subseq seq n -- i )
pick length pick length swap - 1+
[ (start) ] find*
[ (start) ] find-from
swap >r 3drop r> ;
: start ( subseq seq -- i ) 0 start* ; inline
@ -662,10 +668,10 @@ PRIVATE>
tuck tail-slice >r tail-slice r> ;
: unclip ( seq -- rest first )
dup 1 tail swap first ;
[ rest ] [ first ] bi ;
: unclip-slice ( seq -- rest first )
dup 1 tail-slice swap first ;
[ rest-slice ] [ first ] bi ;
: <flat-slice> ( seq -- slice )
dup slice? [ { } like ] when 0 over length rot <slice> ;
@ -680,7 +686,7 @@ PRIVATE>
[ 1+ head ] [ 0 head ] if* ; inline
: trim ( seq quot -- newseq )
[ left-trim ] keep right-trim ; inline
[ left-trim ] [ right-trim ] bi ; inline
: sum ( seq -- n ) 0 [ + ] binary-reduce ;
: product ( seq -- n ) 1 [ * ] binary-reduce ;

4
core/sets/sets-docs.factor
View File

@ -39,9 +39,9 @@ HELP: all-unique?
HELP: diff
{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq2" } " but not " { $snippet "seq1" } ", comparing elements for equality."
{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq1" } " but not " { $snippet "seq2" } ", comparing elements for equality."
} { $examples
{ $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } diff ." "{ 4 }" }
{ $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } diff ." "{ 1 }" }
} ;
HELP: intersect

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

@ -11,7 +11,7 @@ IN: sets.tests
[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } intersect ] unit-test
[ { } ] [ { } { } diff ] unit-test
[ { 4 } ] [ { 1 2 3 } { 2 3 4 } diff ] unit-test
[ { 1 } ] [ { 1 2 3 } { 2 3 4 } diff ] unit-test
[ V{ } ] [ { } { } union ] unit-test
[ V{ 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test

4
core/sets/sets.factor
View File

@ -22,10 +22,10 @@ IN: sets
dup length <hashtable> [ (all-unique?) ] curry all? ;
: intersect ( seq1 seq2 -- newseq )
unique [ key? ] curry subset ;
unique [ key? ] curry filter ;
: diff ( seq1 seq2 -- newseq )
swap unique [ key? not ] curry subset ;
unique [ key? not ] curry filter ;
: union ( seq1 seq2 -- newseq )
append prune ;

2
core/slots/deprecated/deprecated.factor
View File

@ -86,7 +86,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
{ [ over string? ] [ >r dupd r> short-slot ] }
{ [ over array? ] [ long-slot ] }
} cond
] 2map [ ] subset nip ;
] 2map [ ] filter nip ;
: slot-of-reader ( reader specs -- spec/f )
[ slot-spec-reader eq? ] with find nip ;

5
core/sorting/sorting-docs.factor
View File

@ -1,5 +1,6 @@
USING: sorting help.markup help.syntax kernel words math
sequences ;
USING: help.markup help.syntax kernel words math
sequences math.order ;
IN: sorting
ARTICLE: "sequences-sorting" "Sorting and binary search"
"Sorting and binary search combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- n )" } " that order the two given elements and output a value whose sign denotes the result:"

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

@ -1,5 +1,5 @@
USING: sorting sequences kernel math random tools.test
vectors ;
USING: sorting sequences kernel math math.order random
tools.test vectors ;
IN: sorting.tests
[ [ ] ] [ [ ] natural-sort ] unit-test

2
core/sorting/sorting.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math sequences vectors
USING: arrays kernel math sequences vectors math.order
sequences sequences.private growable ;
IN: sorting

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

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

4
core/splitting/splitting.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces strings arrays vectors sequences
sets ;
sets math.order ;
IN: splitting
TUPLE: groups seq n sliced? ;
@ -61,7 +61,7 @@ INSTANCE: groups sequence
dup [ swap ] when ;
: (split) ( separators n seq -- )
3dup rot [ member? ] curry find* drop
3dup rot [ member? ] curry find-from drop
[ [ swap subseq , ] 2keep 1+ swap (split) ]
[ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline

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

@ -1,4 +1,4 @@
USING: continuations kernel math namespaces strings
USING: continuations kernel math math.order namespaces strings
strings.private sbufs tools.test sequences vectors arrays memory
prettyprint io.streams.null ;
IN: strings.tests
@ -31,6 +31,8 @@ IN: strings.tests
[ t ] [ "abc" "abd" before? ] unit-test
[ t ] [ "z" "abd" after? ] unit-test
[ "abc" ] [ "abc" "abd" min ] unit-test
[ "z" ] [ "z" "abd" max ] unit-test
[ 0 10 "hello" subseq ] must-fail

5
core/syntax/syntax-docs.factor
View File

@ -190,7 +190,7 @@ HELP: delimiter
HELP: parsing
{ $syntax ": foo ... ; parsing" }
{ $description "Declares the most recently defined word as a parsing word." }
{ $examples "In the below example, the " { $snippet "world" } " word is never called, however its body references a parsing word which executes immediately:" { $example "USE: io" "<< : hello \"Hello parser!\" print ; parsing >>\n: world hello ;" "Hello parser!" } } ;
{ $examples "In the below example, the " { $snippet "world" } " word is never called, however its body references a parsing word which executes immediately:" { $example "USE: io" "IN: scratchpad" "<< : hello \"Hello parser!\" print ; parsing >>\n: world hello ;" "Hello parser!" } } ;
HELP: inline
{ $syntax ": foo ... ; inline" }
@ -338,7 +338,7 @@ HELP: SYMBOL:
{ $syntax "SYMBOL: word" }
{ $values { "word" "a new word to define" } }
{ $description "Defines a new symbol word in the current vocabulary. Symbols push themselves on the stack when executed, and are used to identify variables (see " { $link "namespaces" } ") as well as for storing crufties in word properties (see " { $link "word-props" } ")." }
{ $examples { $example "USE: prettyprint" "SYMBOL: foo\nfoo ." "foo" } } ;
{ $examples { $example "USE: prettyprint" "IN: scratchpad" "SYMBOL: foo\nfoo ." "foo" } } ;
{ define-symbol POSTPONE: SYMBOL: } related-words
@ -472,6 +472,7 @@ HELP: HOOK:
{ $examples
{ $example
"USING: io namespaces ;"
"IN: scratchpad"
"SYMBOL: transport"
"TUPLE: land-transport ;"
"TUPLE: air-transport ;"

10
core/syntax/syntax.factor
View File

@ -189,8 +189,12 @@ IN: bootstrap.syntax
] define-syntax
"call-next-method" [
current-class get literalize parsed
current-generic get literalize parsed
\ (call-next-method) parsed
current-class get current-generic get
2dup [ word? ] both? [
[ literalize parsed ] bi@
\ (call-next-method) parsed
] [
not-in-a-method-error
] if
] define-syntax
] with-compilation-unit

5
core/threads/threads.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license.
IN: threads
USING: arrays hashtables heaps kernel kernel.private math
namespaces sequences vectors continuations continuations.private
dlists assocs system combinators init boxes accessors ;
dlists assocs system combinators init boxes accessors
math.order ;
IN: threads
SYMBOL: initial-thread

4
core/vocabs/vocabs.factor
View File

@ -76,14 +76,14 @@ SYMBOL: load-vocab-hook ! ( name -- )
: words-named ( str -- seq )
dictionary get values
[ vocab-words at ] with map
[ ] subset ;
[ ] filter ;
: child-vocab? ( prefix name -- ? )
2dup = pick empty? or
[ 2drop t ] [ swap CHAR: . suffix head? ] if ;
: child-vocabs ( vocab -- seq )
vocab-name vocabs [ child-vocab? ] with subset ;
vocab-name vocabs [ child-vocab? ] with filter ;
TUPLE: vocab-link name ;

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

@ -197,7 +197,7 @@ HELP: execute ( word -- )
{ $values { "word" word } }
{ $description "Executes a word." }
{ $examples
{ $example "USING: kernel io words ;" ": twice dup execute execute ;\n: hello \"Hello\" print ;\n\\ hello twice" "Hello\nHello" }
{ $example "USING: kernel io words ;" "IN: scratchpad" ": twice dup execute execute ;\n: hello \"Hello\" print ;\n\\ hello twice" "Hello\nHello" }
} ;
HELP: word-props ( word -- props )
@ -278,7 +278,7 @@ HELP: reset-generic
$low-level-note
{ $side-effects "word" } ;
HELP: <word>
HELP: <word> ( name vocab -- word )
{ $values { "name" string } { "vocab" string } { "word" word } }
{ $description "Allocates an uninterned word with the specified name and vocabulary, and a blank word property hashtable. User code should call " { $link gensym } " to create uninterned words and " { $link create } " to create interned words." } ;
@ -300,7 +300,7 @@ HELP: word
HELP: set-word
{ $values { "word" word } }
{ $description "Sets the recently defined word. Usually you would call " { $link save-location } " on a newly-defined word instead, which will in turn call this word." } ;
{ $description "Sets the recently defined word." } ;
HELP: lookup
{ $values { "name" string } { "vocab" string } { "word" "a word or " { $link f } } }

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

@ -68,7 +68,7 @@ FORGET: another-forgotten
: foe fee ;
: fie foe ;
[ t ] [ \ fee usage [ word? ] subset empty? ] unit-test
[ t ] [ \ fee usage [ word? ] filter empty? ] unit-test
[ t ] [ \ foe usage empty? ] unit-test
[ f ] [ \ foe crossref get key? ] unit-test
@ -80,7 +80,7 @@ FORGET: foe
] unit-test
[ t ] [
\ * usage [ word? ] subset [ crossref? ] all?
\ * usage [ word? ] filter [ crossref? ] all?
] unit-test
DEFER: calls-a-gensym

11
core/words/words.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions graphs assocs kernel kernel.private
slots.private math namespaces sequences strings vectors sbufs
quotations assocs hashtables sorting words.private vocabs ;
quotations assocs hashtables sorting words.private vocabs
math.order ;
IN: words
: word ( -- word ) \ word get-global ;
@ -101,7 +102,7 @@ SYMBOL: compiled-crossref
compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- )
[ drop compiled-crossref? ] assoc-subset
[ drop compiled-crossref? ] assoc-filter
2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex* ;
@ -121,7 +122,7 @@ SYMBOL: +called+
: compiled-usages ( words -- seq )
[ [ dup ] H{ } map>assoc dup ] keep [
compiled-usage [ nip +inlined+ eq? ] assoc-subset update
compiled-usage [ nip +inlined+ eq? ] assoc-filter update
] with each keys ;
<PRIVATE
@ -135,9 +136,9 @@ SYMBOL: visited
[ reset-on-redefine reset-props ]
[ dup visited get set-at ]
[
crossref get at keys [ word? ] subset [
crossref get at keys [ word? ] filter [
reset-on-redefine [ word-prop ] with contains?
] subset
] filter
[ (redefined) ] each
] tri
] if ;

2
extra/alarms/alarms.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays calendar combinators generic init kernel math
namespaces sequences heaps boxes threads debugger quotations
assocs ;
assocs math.order ;
IN: alarms
TUPLE: alarm quot time interval entry ;

3
extra/ascii/ascii-tests.factor
View File

@ -1,5 +1,5 @@
IN: ascii.tests
USING: ascii tools.test sequences kernel math ;
IN: ascii.tests
[ t ] [ CHAR: a letter? ] unit-test
[ f ] [ CHAR: A letter? ] unit-test
@ -8,7 +8,6 @@ USING: ascii tools.test sequences kernel math ;
[ t ] [ CHAR: 0 digit? ] unit-test
[ f ] [ CHAR: x digit? ] unit-test
[ 4 ] [
0 "There are Four Upper Case characters"
[ LETTER? [ 1+ ] when ] each

2
extra/ascii/ascii.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences math kernel ;
USING: kernel math math.order sequences ;
IN: ascii
: blank? ( ch -- ? ) " \t\n\r" member? ; inline

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