diff --git a/.gitignore b/.gitignore index f2cf3de119..290f075aae 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ _darcs *.obj *.o +*.s *.exe Factor/factor *.a diff --git a/build-support/factor.sh b/build-support/factor.sh index 4bcd9e3086..70c522f6cd 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -439,7 +439,7 @@ install_build_system_port() { } usage() { - echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap|make-target" + echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target" echo "If you are behind a firewall, invoke as:" echo "env GIT_PROTOCOL=http $0 " } diff --git a/core/alien/alien.factor b/core/alien/alien.factor index f664e1175a..cc37b85103 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -28,12 +28,6 @@ M: f expired? drop t ; : ( address -- alien ) f { simple-c-ptr } declare ; inline -: alien>native-string ( alien -- string ) - os windows? [ alien>u16-string ] [ alien>char-string ] if ; - -: dll-path ( dll -- string ) - (dll-path) alien>native-string ; - M: alien equal? over alien? [ 2dup [ expired? ] either? [ diff --git a/core/alien/arrays/arrays-docs.factor b/core/alien/arrays/arrays-docs.factor index f3f27d0739..09a09cdc6f 100755 --- a/core/alien/arrays/arrays-docs.factor +++ b/core/alien/arrays/arrays-docs.factor @@ -18,7 +18,6 @@ ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays" { $subsection >c-ushort-array } { $subsection >c-void*-array } { $subsection c-bool-array> } -{ $subsection c-char*-array> } { $subsection c-char-array> } { $subsection c-double-array> } { $subsection c-float-array> } @@ -30,7 +29,6 @@ ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays" { $subsection c-uint-array> } { $subsection c-ulong-array> } { $subsection c-ulonglong-array> } -{ $subsection c-ushort*-array> } { $subsection c-ushort-array> } { $subsection c-void*-array> } ; @@ -61,9 +59,7 @@ ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays" { $subsection double-nth } { $subsection set-double-nth } { $subsection void*-nth } -{ $subsection set-void*-nth } -{ $subsection char*-nth } -{ $subsection ushort*-nth } ; +{ $subsection set-void*-nth } ; ARTICLE: "c-arrays" "C arrays" "C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "." diff --git a/core/alien/arrays/arrays.factor b/core/alien/arrays/arrays.factor index 402b01550b..0f756e0ad0 100644 --- a/core/alien/arrays/arrays.factor +++ b/core/alien/arrays/arrays.factor @@ -1,8 +1,7 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays alien.c-types alien.structs -sequences math kernel generator.registers -namespaces libc ; +sequences math kernel namespaces libc cpu.architecture ; IN: alien.arrays UNION: value-type array struct-type ; @@ -27,7 +26,9 @@ M: array stack-size drop "void*" stack-size ; M: value-type c-type-reg-class drop int-regs ; -M: value-type c-type-prep drop f ; +M: value-type c-type-boxer-quot drop f ; + +M: value-type c-type-unboxer-quot drop f ; M: value-type c-type-getter drop [ swap ] ; diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor index 8d2b03467b..3cd5afef33 100755 --- a/core/alien/c-types/c-types-docs.factor +++ b/core/alien/c-types/c-types-docs.factor @@ -62,28 +62,6 @@ HELP: { malloc-object } related-words -HELP: string>char-alien ( string -- array ) -{ $values { "string" string } { "array" byte-array } } -{ $description "Copies the string to a new byte array, converting it to 8-bit ASCII and adding a trailing null byte." } -{ $errors "Throws an error if the string contains null characters, or characters beyond the 8-bit range." } ; - -{ string>char-alien alien>char-string malloc-char-string } related-words - -HELP: alien>char-string ( c-ptr -- string ) -{ $values { "c-ptr" c-ptr } { "string" string } } -{ $description "Reads a null-terminated 8-bit C string from the specified address." } ; - -HELP: string>u16-alien ( string -- array ) -{ $values { "string" string } { "array" byte-array } } -{ $description "Copies the string to a new byte array in UCS-2 format with a trailing null byte." } -{ $errors "Throws an error if the string contains null characters." } ; - -{ string>u16-alien alien>u16-string malloc-u16-string } related-words - -HELP: alien>u16-string ( c-ptr -- string ) -{ $values { "c-ptr" c-ptr } { "string" string } } -{ $description "Reads a null-terminated UCS-2 string from the specified address." } ; - HELP: memory>byte-array { $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } } { $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ; @@ -111,18 +89,6 @@ HELP: malloc-byte-array { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } { $errors "Throws an error if memory allocation fails." } ; -HELP: malloc-char-string -{ $values { "string" string } { "alien" c-ptr } } -{ $description "Allocates an unmanaged memory block, and stores a string in 8-bit ASCII encoding with a trailing null byte to the block." } -{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } -{ $errors "Throws an error if memory allocation fails." } ; - -HELP: malloc-u16-string -{ $values { "string" string } { "alien" c-ptr } } -{ $description "Allocates an unmanaged memory block, and stores a string in UCS2 encoding with a trailing null character to the block." } -{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } -{ $errors "Throws an error if memory allocation fails." } ; - HELP: define-nth { $values { "name" "a word name" } { "vocab" "a vocabulary name" } } { $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." } @@ -202,8 +168,6 @@ $nl { $subsection *float } { $subsection *double } { $subsection *void* } -{ $subsection *char* } -{ $subsection *ushort* } "Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link } " and " { $link *void* } " may be used." ; ARTICLE: "c-types-specs" "C type specifiers" @@ -267,26 +231,6 @@ $nl "A wrapper for temporarily allocating a block of memory:" { $subsection with-malloc } ; -ARTICLE: "c-strings" "C strings" -"The C library interface defines two types of C strings:" -{ $table - { "C type" "Notes" } - { { $snippet "char*" } "8-bit per character null-terminated ASCII" } - { { $snippet "ushort*" } "16-bit per character null-terminated UCS-2" } -} -"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown." -"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:" -{ $subsection string>char-alien } -{ $subsection string>u16-alien } -{ $subsection malloc-char-string } -{ $subsection malloc-u16-string } -"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches." -$nl -"Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:" -{ $subsection alien>char-string } -{ $subsection alien>u16-string } -"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ; - ARTICLE: "c-data" "Passing data between Factor and C" "Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers." $nl diff --git a/core/alien/c-types/c-types-tests.factor b/core/alien/c-types/c-types-tests.factor index 843b0a826b..5f57068bab 100755 --- a/core/alien/c-types/c-types-tests.factor +++ b/core/alien/c-types/c-types-tests.factor @@ -1,30 +1,6 @@ IN: alien.c-types.tests USING: alien alien.syntax alien.c-types kernel tools.test -sequences system libc ; - -[ "\u0000ff" ] -[ "\u0000ff" string>char-alien alien>char-string ] -unit-test - -[ "hello world" ] -[ "hello world" string>char-alien alien>char-string ] -unit-test - -[ "hello\u00abcdworld" ] -[ "hello\u00abcdworld" string>u16-alien alien>u16-string ] -unit-test - -[ t ] [ f expired? ] unit-test - -[ "hello world" ] [ - "hello world" malloc-char-string - dup alien>char-string swap free -] unit-test - -[ "hello world" ] [ - "hello world" malloc-u16-string - dup alien>u16-string swap free -] unit-test +sequences system libc alien.strings io.encodings.utf8 ; : foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ; @@ -67,7 +43,7 @@ TYPEDEF: int* MyIntArray TYPEDEF: uchar* MyLPBYTE -[ t ] [ "char*" c-type "MyLPBYTE" c-type eq? ] unit-test +[ t ] [ { "char*" utf8 } c-type "MyLPBYTE" c-type = ] unit-test [ 0 B{ 1 2 3 4 } diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index c97c760695..f67fc78259 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bit-arrays byte-arrays float-arrays arrays -generator.registers assocs kernel kernel.private libc math +assocs kernel kernel.private libc math namespaces parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations layouts system compiler.units io.files io.encodings.binary @@ -14,7 +14,7 @@ DEFER: *char : little-endian? ( -- ? ) 1 *char 1 = ; foldable TUPLE: c-type -boxer prep unboxer +boxer boxer-quot unboxer unboxer-quot getter setter reg-class size align stack-align? ; @@ -149,23 +149,12 @@ M: float-array byte-length length "double" heap-size * ; : malloc-byte-array ( byte-array -- alien ) dup length dup malloc [ -rot memcpy ] keep ; -: malloc-char-string ( string -- alien ) - string>char-alien malloc-byte-array ; - -: malloc-u16-string ( string -- alien ) - string>u16-alien malloc-byte-array ; - : memory>byte-array ( alien len -- byte-array ) dup [ -rot memcpy ] keep ; : byte-array>memory ( byte-array base -- ) swap dup length memcpy ; -DEFER: >c-ushort-array - -: string>u16-memory ( string base -- ) - >r >c-ushort-array r> byte-array>memory ; - : (define-nth) ( word type quot -- ) >r heap-size [ rot * ] swap prefix r> append define-inline ; @@ -378,7 +367,7 @@ M: long-long-type box-return ( type -- ) "box_float" >>boxer "to_float" >>unboxer single-float-regs >>reg-class - [ >float ] >>prep + [ >float ] >>unboxer-quot "float" define-primitive-type @@ -389,30 +378,8 @@ M: long-long-type box-return ( type -- ) "box_double" >>boxer "to_double" >>unboxer double-float-regs >>reg-class - [ >float ] >>prep + [ >float ] >>unboxer-quot "double" define-primitive-type - - [ alien-cell alien>char-string ] >>getter - [ set-alien-cell ] >>setter - bootstrap-cell >>size - bootstrap-cell >>align - "box_char_string" >>boxer - "alien_offset" >>unboxer - [ string>char-alien ] >>prep - "char*" define-primitive-type - - "char*" "uchar*" typedef - - - [ alien-cell alien>u16-string ] >>getter - [ set-alien-cell ] >>setter - 4 >>size - 4 >>align - "box_u16_string" >>boxer - "alien_offset" >>unboxer - [ string>u16-alien ] >>prep - "ushort*" define-primitive-type - os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef ] with-compilation-unit diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index f0c0706a3c..5d847e364f 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -1,367 +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" [ 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" - [ 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 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" - 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" - 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" - 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" - 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" - [ 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 - -! 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 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: 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" [ 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" + [ 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 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" + 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" + 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" + 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" + 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" + [ 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 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 diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 9bd65aa0bc..08b52367b0 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -3,10 +3,11 @@ USING: arrays generator generator.registers generator.fixup hashtables kernel math namespaces sequences words inference.state inference.backend inference.dataflow system -math.parser classes alien.arrays alien.c-types alien.structs -alien.syntax cpu.architecture alien inspector quotations assocs -kernel.private threads continuations.private libc combinators -compiler.errors continuations layouts accessors ; +math.parser classes alien.arrays alien.c-types alien.strings +alien.structs alien.syntax cpu.architecture alien inspector +quotations assocs kernel.private threads continuations.private +libc combinators compiler.errors continuations layouts accessors +; IN: alien.compiler TUPLE: #alien-node < node return parameters abi ; @@ -20,9 +21,7 @@ TUPLE: #alien-invoke < #alien-node library function ; : large-struct? ( ctype -- ? ) dup c-struct? [ heap-size struct-small-enough? not - ] [ - drop f - ] if ; + ] [ drop f ] if ; : alien-node-parameters* ( node -- seq ) dup parameters>> @@ -162,17 +161,16 @@ M: long-long-type flatten-value-type ( type -- ) dup return>> "void" = 0 1 ? swap produce-values ; -: (make-prep-quot) ( parameters -- ) +: (param-prep-quot) ( parameters -- ) dup empty? [ drop ] [ - unclip c-type c-type-prep % - \ >r , (make-prep-quot) \ r> , + unclip c-type c-type-unboxer-quot % + \ >r , (param-prep-quot) \ r> , ] if ; -: make-prep-quot ( node -- quot ) - parameters>> - [ (make-prep-quot) ] [ ] make ; +: param-prep-quot ( node -- quot ) + parameters>> [ (param-prep-quot) ] [ ] make ; : unbox-parameters ( offset node -- ) parameters>> [ @@ -200,6 +198,20 @@ M: long-long-type flatten-value-type ( type -- ) : box-return* ( node -- ) return>> [ ] [ box-return ] if-void ; +: (return-prep-quot) ( parameters -- ) + dup empty? [ + drop + ] [ + unclip c-type c-type-boxer-quot % + \ >r , (return-prep-quot) \ r> , + ] if ; + +: callback-prep-quot ( node -- quot ) + parameters>> [ (return-prep-quot) ] [ ] make ; + +: return-prep-quot ( node -- quot ) + [ return>> [ ] [ 1array (return-prep-quot) ] if-void ] [ ] make ; + M: alien-invoke-error summary drop "Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ; @@ -258,15 +270,15 @@ M: no-such-symbol compiler-error-type pop-literal nip >>library pop-literal nip >>return ! Quotation which coerces parameters to required types - dup make-prep-quot recursive-state get infer-quot + dup param-prep-quot recursive-state get infer-quot ! Set ABI - dup library>> - library [ abi>> ] [ "cdecl" ] if* - >>abi + dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi ! Add node to IR dup node, ! Magic #: consume exactly the number of inputs - 0 alien-invoke-stack + dup 0 alien-invoke-stack + ! Quotation which coerces return value to required type + return-prep-quot recursive-state get infer-quot ] "infer" set-word-prop M: #alien-invoke generate-node @@ -294,11 +306,13 @@ M: alien-indirect-error summary pop-parameters >>parameters pop-literal nip >>return ! Quotation which coerces parameters to required types - dup make-prep-quot [ dip ] curry recursive-state get infer-quot + dup param-prep-quot [ dip ] curry recursive-state get infer-quot ! Add node to IR dup node, ! Magic #: consume the function pointer, too - 1 alien-invoke-stack + dup 1 alien-invoke-stack + ! Quotation which coerces return value to required type + return-prep-quot recursive-state get infer-quot ] "infer" set-word-prop M: #alien-indirect generate-node @@ -371,16 +385,18 @@ TUPLE: callback-context ; slip wait-to-return ; inline -: prepare-callback-return ( ctype -- quot ) +: callback-return-quot ( ctype -- quot ) return>> { { [ dup "void" = ] [ drop [ ] ] } { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] } - [ c-type c-type-prep ] + [ c-type c-type-unboxer-quot ] } cond ; : wrap-callback-quot ( node -- quot ) [ - [ quot>> ] [ prepare-callback-return ] bi append , + [ callback-prep-quot ] + [ quot>> ] + [ callback-return-quot ] tri 3append , [ callback-context new do-callback ] % ] [ ] make ; @@ -405,9 +421,10 @@ TUPLE: callback-context ; init-templates %prologue-later dup alien-stack-frame [ - dup registers>objects - dup wrap-callback-quot %alien-callback - %callback-return + [ registers>objects ] + [ wrap-callback-quot %alien-callback ] + [ %callback-return ] + tri ] with-stack-frame ] with-generator ; diff --git a/core/alien/remote-control/remote-control.factor b/core/alien/remote-control/remote-control.factor index b7700c0ff1..1d713f6edd 100755 --- a/core/alien/remote-control/remote-control.factor +++ b/core/alien/remote-control/remote-control.factor @@ -1,12 +1,12 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types parser threads words kernel.private -kernel ; +USING: alien alien.c-types alien.strings parser threads words +kernel.private kernel io.encodings.utf8 ; IN: alien.remote-control : eval-callback "void*" { "char*" } "cdecl" - [ eval>string malloc-char-string ] alien-callback ; + [ eval>string utf8 malloc-string ] alien-callback ; : yield-callback "void" { } "cdecl" [ yield ] alien-callback ; diff --git a/core/alien/strings/strings-docs.factor b/core/alien/strings/strings-docs.factor new file mode 100644 index 0000000000..27b0122ebe --- /dev/null +++ b/core/alien/strings/strings-docs.factor @@ -0,0 +1,52 @@ +USING: help.markup help.syntax strings byte-arrays alien libc +debugger ; +IN: alien.strings + +HELP: string>alien +{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } } +{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." } +{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ; + +{ string>alien alien>string malloc-string } related-words + +HELP: alien>string +{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } } +{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ; + +HELP: malloc-string +{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } } +{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." } +{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } +{ $errors "Throws an error if one of the following conditions occurs:" + { $list + "the string contains null code points" + "the string contains characters not representable using the encoding specified" + "memory allocation fails" + } +} ; + +HELP: string>symbol +{ $values { "str" string } { "alien" alien } } +{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory." +$nl +"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ; + +HELP: utf16n +{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "c-strings" "C strings" +"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors." +$nl +"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown." +$nl +"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:" +{ $subsection string>alien } +{ $subsection malloc-string } +"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches." +$nl +"A word to read strings from arbitrary addresses:" +{ $subsection alien>string } +"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ; + +ABOUT: "c-strings" diff --git a/core/alien/strings/strings-tests.factor b/core/alien/strings/strings-tests.factor new file mode 100644 index 0000000000..484809469f --- /dev/null +++ b/core/alien/strings/strings-tests.factor @@ -0,0 +1,30 @@ +USING: alien.strings tools.test kernel libc +io.encodings.8-bit io.encodings.utf8 io.encodings.utf16 +io.encodings.ascii alien ; +IN: alien.strings.tests + +[ "\u0000ff" ] +[ "\u0000ff" latin1 string>alien latin1 alien>string ] +unit-test + +[ "hello world" ] +[ "hello world" latin1 string>alien latin1 alien>string ] +unit-test + +[ "hello\u00abcdworld" ] +[ "hello\u00abcdworld" utf16le string>alien utf16le alien>string ] +unit-test + +[ t ] [ f expired? ] unit-test + +[ "hello world" ] [ + "hello world" ascii malloc-string + dup ascii alien>string swap free +] unit-test + +[ "hello world" ] [ + "hello world" utf16n malloc-string + dup utf16n alien>string swap free +] unit-test + +[ f ] [ f utf8 alien>string ] unit-test diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor new file mode 100644 index 0000000000..d69d8e9e8e --- /dev/null +++ b/core/alien/strings/strings.factor @@ -0,0 +1,111 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays sequences kernel accessors math alien.accessors +alien.c-types byte-arrays words io io.encodings +io.streams.byte-array io.streams.memory io.encodings.utf8 +io.encodings.utf16 system alien strings cpu.architecture ; +IN: alien.strings + +GENERIC# alien>string 1 ( c-ptr encoding -- string/f ) + +M: c-ptr alien>string + >r r> + "\0" swap stream-read-until drop ; + +M: f alien>string + drop ; + +ERROR: invalid-c-string string ; + +: check-string ( string -- ) + 0 over memq? [ invalid-c-string ] [ drop ] if ; + +GENERIC# string>alien 1 ( string encoding -- byte-array ) + +M: c-ptr string>alien drop ; + +M: string string>alien + over check-string + + [ stream-write ] + [ 0 swap stream-write1 ] + [ stream>> >byte-array ] + tri ; + +: malloc-string ( string encoding -- alien ) + string>alien malloc-byte-array ; + +PREDICATE: string-type < pair + first2 [ "char*" = ] [ word? ] bi* and ; + +M: string-type c-type ; + +M: string-type heap-size + drop "void*" heap-size ; + +M: string-type c-type-align + drop "void*" c-type-align ; + +M: string-type c-type-stack-align? + drop "void*" c-type-stack-align? ; + +M: string-type unbox-parameter + drop "void*" unbox-parameter ; + +M: string-type unbox-return + drop "void*" unbox-return ; + +M: string-type box-parameter + drop "void*" box-parameter ; + +M: string-type box-return + drop "void*" box-return ; + +M: string-type stack-size + drop "void*" stack-size ; + +M: string-type c-type-reg-class + drop int-regs ; + +M: string-type c-type-boxer + drop "void*" c-type-boxer ; + +M: string-type c-type-unboxer + drop "void*" c-type-unboxer ; + +M: string-type c-type-boxer-quot + second [ alien>string ] curry [ ] like ; + +M: string-type c-type-unboxer-quot + second [ string>alien ] curry [ ] like ; + +M: string-type c-type-getter + drop [ alien-cell ] ; + +M: string-type c-type-setter + drop [ set-alien-cell ] ; + +TUPLE: utf16n ; + +! Native-order UTF-16 + +: utf16n ( -- descriptor ) + little-endian? utf16le utf16be ? ; foldable + +M: utf16n drop utf16n ; + +M: utf16n drop utf16n ; + +: alien>native-string ( alien -- string ) + os windows? [ utf16n ] [ utf8 ] if alien>string ; + +: dll-path ( dll -- string ) + (dll-path) alien>native-string ; + +: string>symbol ( str -- alien ) + [ os wince? [ utf16n ] [ utf8 ] if string>alien ] + over string? [ call ] [ map ] if ; + +{ "char*" utf8 } "char*" typedef +{ "char*" utf16n } "wchar_t*" typedef +"char*" "uchar*" typedef diff --git a/core/alien/structs/structs-tests.factor b/core/alien/structs/structs-tests.factor index a33a86d4b5..bfdcd31b99 100644 --- a/core/alien/structs/structs-tests.factor +++ b/core/alien/structs/structs-tests.factor @@ -1,6 +1,6 @@ IN: alien.structs.tests USING: alien alien.syntax alien.c-types kernel tools.test -sequences system libc words vocabs namespaces ; +sequences system libc words vocabs namespaces layouts ; C-STRUCT: bar { "int" "x" } @@ -9,20 +9,20 @@ C-STRUCT: bar [ 36 ] [ "bar" heap-size ] unit-test [ t ] [ \ "bar" c-type c-type-getter memq? ] unit-test -! This was actually only correct on Windows/x86: +C-STRUCT: align-test + { "int" "x" } + { "double" "y" } ; -! C-STRUCT: align-test -! { "int" "x" } -! { "double" "y" } ; -! -! [ 16 ] [ "align-test" heap-size ] unit-test -! -! cell 4 = [ -! C-STRUCT: one -! { "long" "a" } { "double" "b" } { "int" "c" } ; -! -! [ 24 ] [ "one" heap-size ] unit-test -! ] when +os winnt? cpu x86? and [ + [ 16 ] [ "align-test" heap-size ] unit-test + + cell 4 = [ + C-STRUCT: one + { "long" "a" } { "double" "b" } { "int" "c" } ; + + [ 24 ] [ "one" heap-size ] unit-test + ] when +] when : MAX_FOOS 30 ; diff --git a/core/alien/structs/structs.factor b/core/alien/structs/structs.factor index 6d98d31790..bc5fa5a3f1 100755 --- a/core/alien/structs/structs.factor +++ b/core/alien/structs/structs.factor @@ -20,14 +20,19 @@ IN: alien.structs : define-getter ( type spec -- ) [ set-reader-props ] keep - dup slot-spec-reader - over slot-spec-type c-getter + [ ] + [ slot-spec-reader ] + [ + slot-spec-type + [ c-getter ] [ c-type c-type-boxer-quot ] bi append + ] tri define-struct-slot-word ; : define-setter ( type spec -- ) [ set-writer-props ] keep - dup slot-spec-writer - over slot-spec-type c-setter + [ ] + [ slot-spec-writer ] + [ slot-spec-type c-setter ] tri define-struct-slot-word ; : define-field ( type spec -- ) diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index 67ea30f379..b2e819f8fb 100755 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays alien alien.c-types alien.structs alien.arrays -kernel math namespaces parser sequences words quotations -math.parser splitting effects prettyprint prettyprint.sections -prettyprint.backend assocs combinators ; +alien.strings kernel math namespaces parser sequences words +quotations math.parser splitting effects prettyprint +prettyprint.sections prettyprint.backend assocs combinators ; IN: alien.syntax : FUNCTION: scan "c-library" get scan ";" parse-tokens - [ "()" subseq? not ] subset + [ "()" subseq? not ] filter define-function ; parsing : TYPEDEF: diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 863fdaecb3..de62ccd878 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -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" } } diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 76f484006d..19e323bdae 100755 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -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 ] [ diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 4a6ecae4fe..e68c311836 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -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 diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index da3c634ebd..7ad1c6978b 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -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 @@ -18,6 +18,8 @@ IN: bootstrap.compiler enable-compiler +: compile-uncompiled [ compiled? not ] filter compile ; + nl "Compiling..." write flush @@ -42,38 +44,38 @@ nl find-pair-next namestack* bitand bitor bitxor bitnot -} compile +} compile-uncompiled "." write flush { - + 1+ 1- 2/ < <= > >= shift min -} compile + + 1+ 1- 2/ < <= > >= shift +} compile-uncompiled "." write flush { new-sequence nth push pop peek -} compile +} compile-uncompiled "." write flush { hashcode* = get set -} compile +} compile-uncompiled "." write flush { . lines -} compile +} compile-uncompiled "." write flush { malloc calloc free memcpy -} compile +} compile-uncompiled -vocabs [ words [ compiled? not ] subset compile "." write flush ] each +vocabs [ words compile-uncompiled "." write flush ] each " done" print flush diff --git a/core/bootstrap/image/image-tests.factor b/core/bootstrap/image/image-tests.factor index ae5c66a45c..c432a47ea4 100755 --- a/core/bootstrap/image/image-tests.factor +++ b/core/bootstrap/image/image-tests.factor @@ -1,5 +1,22 @@ IN: bootstrap.image.tests -USING: bootstrap.image bootstrap.image.private tools.test ; +USING: bootstrap.image bootstrap.image.private tools.test +kernel math ; \ ' must-infer \ write-image must-infer + +[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test + +[ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test + +[ f ] [ [ 2drop 0 ] [ 2drop 0.0 ] eql? ] unit-test + +[ t ] [ [ 2drop 0 ] [ 2drop 0 ] eql? ] unit-test + +[ f ] [ \ + [ 2drop 0 ] eql? ] unit-test + +[ f ] [ 3 [ 0 1 2 ] eql? ] unit-test + +[ f ] [ 3 3.0 eql? ] unit-test + +[ t ] [ 4.0 4.0 eql? ] unit-test diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 05d48af2e8..b3be0c41e7 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -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 accessors ; IN: bootstrap.image : my-arch ( -- arch ) @@ -31,6 +31,43 @@ IN: bootstrap.image id + +M: id hashcode* obj>> hashcode* ; + +GENERIC: (eql?) ( obj1 obj2 -- ? ) + +: eql? ( obj1 obj2 -- ? ) + [ (eql?) ] [ [ class ] bi@ = ] 2bi and ; + +M: integer (eql?) = ; + +M: sequence (eql?) + over sequence? [ + 2dup [ length ] bi@ = + [ [ eql? ] 2all? ] [ 2drop f ] if + ] [ 2drop f ] if ; + +M: object (eql?) = ; + +M: id equal? + over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ; + +SYMBOL: objects + +: (objects) objects get ; inline + +: lookup-object ( obj -- n/f ) (objects) at ; + +: put-object ( n obj -- ) (objects) set-at ; + +: cache-object ( obj quot -- value ) + >r (objects) r> [ obj>> ] prepose cache ; inline + ! Constants : image-magic HEX: 0f0e0d0c ; inline @@ -61,9 +98,6 @@ IN: bootstrap.image ! The image being constructed; a vector of word-size integers SYMBOL: image -! Object cache -SYMBOL: objects - ! Image output format SYMBOL: big-endian @@ -187,7 +221,9 @@ GENERIC: ' ( obj -- ptr ) 2tri ; M: bignum ' - bignum tag-number dup [ emit-bignum ] emit-object ; + [ + bignum tag-number dup [ emit-bignum ] emit-object + ] cache-object ; ! Fixnums @@ -202,9 +238,11 @@ M: fixnum ' ! Floats M: float ' - float tag-number dup [ - align-here double>bits emit-64 - ] emit-object ; + [ + float tag-number dup [ + align-here double>bits emit-64 + ] emit-object + ] cache-object ; ! Special objects @@ -243,7 +281,7 @@ M: f ' ] bi \ word type-number object tag-number [ emit-seq ] emit-object - ] keep objects get set-at ; + ] keep put-object ; : word-error ( word msg -- * ) [ % dup word-vocabulary % " " % word-name % ] "" make throw ; @@ -252,7 +290,7 @@ M: f ' [ target-word ] keep or ; : fixup-word ( word -- offset ) - transfer-word dup objects get at + transfer-word dup lookup-object [ ] [ "Not in image: " word-error ] ?if ; : fixup-words ( -- ) @@ -286,7 +324,7 @@ M: wrapper ' M: string ' #! We pool strings so that each string is only written once #! to the image - objects get [ emit-string ] cache ; + [ emit-string ] cache-object ; : assert-empty ( seq -- ) length 0 assert= ; @@ -305,18 +343,18 @@ 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 ; : emit-tuple ( tuple -- pointer ) dup class word-name "tombstone" = - [ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ; + [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ; M: tuple ' emit-tuple ; M: tuple-layout ' - objects get [ + [ [ { [ layout-hashcode , ] @@ -328,12 +366,12 @@ M: tuple-layout ' ] { } make [ ' ] map \ tuple-layout type-number object tag-number [ emit-seq ] emit-object - ] cache ; + ] cache-object ; M: tombstone ' delegate "((tombstone))" "((empty))" ? "hashtables.private" lookup - word-def first objects get [ emit-tuple ] cache ; + word-def first [ emit-tuple ] cache-object ; ! Arrays M: array ' @@ -343,7 +381,7 @@ M: array ' ! Quotations M: quotation ' - objects get [ + [ quotation-array ' quotation type-number object tag-number [ emit ! array @@ -351,7 +389,7 @@ M: quotation ' 0 emit ! xt 0 emit ! code ] emit-object - ] cache ; + ] cache-object ; ! End of the image diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index f1e41ac2b6..bcd75e9854 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -58,16 +58,13 @@ num-types get f builtins set "alien.accessors" "arrays" "bit-arrays" - "bit-vectors" "byte-arrays" - "byte-vectors" "classes.private" "classes.tuple" "classes.tuple.private" "compiler.units" "continuations.private" "float-arrays" - "float-vectors" "generator" "growable" "hashtables" @@ -160,7 +157,7 @@ num-types get f 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 @@ -455,54 +452,6 @@ tuple } } define-tuple-class -"byte-vector" "byte-vectors" create -tuple -{ - { - { "byte-array" "byte-arrays" } - "underlying" - { "underlying" "growable" } - { "set-underlying" "growable" } - } { - { "array-capacity" "sequences.private" } - "fill" - { "length" "sequences" } - { "set-fill" "growable" } - } -} define-tuple-class - -"bit-vector" "bit-vectors" create -tuple -{ - { - { "bit-array" "bit-arrays" } - "underlying" - { "underlying" "growable" } - { "set-underlying" "growable" } - } { - { "array-capacity" "sequences.private" } - "fill" - { "length" "sequences" } - { "set-fill" "growable" } - } -} define-tuple-class - -"float-vector" "float-vectors" create -tuple -{ - { - { "float-array" "float-arrays" } - "underlying" - { "underlying" "growable" } - { "set-underlying" "growable" } - } { - { "array-capacity" "sequences.private" } - "fill" - { "length" "sequences" } - { "set-fill" "growable" } - } -} define-tuple-class - "curry" "kernel" create tuple { @@ -689,10 +638,6 @@ tuple { "set-alien-double" "alien.accessors" } { "alien-cell" "alien.accessors" } { "set-alien-cell" "alien.accessors" } - { "alien>char-string" "alien" } - { "string>char-alien" "alien" } - { "alien>u16-string" "alien" } - { "string>u16-alien" "alien" } { "(throw)" "kernel.private" } { "alien-address" "alien" } { "slot" "slots.private" } diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index dfd2e4be6f..8e4108866f 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -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 diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 4d5f31dc82..4b74804749 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -14,16 +14,13 @@ IN: bootstrap.syntax ";" " anonymous-complement { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] } { [ over anonymous-union? ] [ left-anonymous-union< ] } { [ over anonymous-intersection? ] [ left-anonymous-intersection< ] } - { [ over anonymous-complement? ] [ 2drop f ] } { [ over members ] [ left-union-class< ] } { [ dup anonymous-union? ] [ right-anonymous-union< ] } { [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] } + { [ over anonymous-complement? ] [ 2drop f ] } { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } { [ dup members ] [ right-union-class< ] } { [ over superclass ] [ superclass< ] } @@ -183,7 +183,7 @@ C: 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,9 +193,8 @@ C: anonymous-complement [ ] unfold nip ; : min-class ( class seq -- class/f ) - [ dupd classes-intersect? ] subset dup empty? [ - 2drop f - ] [ + over [ classes-intersect? ] curry filter + dup empty? [ 2drop f ] [ tuck [ class< ] with all? [ peek ] [ drop f ] if ] if ; diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index dd3782e877..5971ffd9fa 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -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." } ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 4f43b86f64..c998a1b155 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -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 ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 33b0fc32fa..ca2547bacf 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -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 -- ) diff --git a/core/classes/singleton/singleton-docs.factor b/core/classes/singleton/singleton-docs.factor index a8dae809ec..f647b006d9 100644 --- a/core/classes/singleton/singleton-docs.factor +++ b/core/classes/singleton/singleton-docs.factor @@ -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 diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index cdfdee9717..9f8ce83240 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -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 }" diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index ce6fd9367c..41776c4eec 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -3,7 +3,8 @@ math.constants parser sequences tools.test words assocs 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 ; +calendar prettyprint io.streams.string splitting inspector +columns math.order ; IN: classes.tuple.tests TUPLE: rect x y w h ; @@ -87,7 +88,7 @@ C: empty [ t length ] [ object>> t eq? ] must-fail-with [ "" ] -[ "TUPLE: constructor-test ; C: constructor-test" eval word word-name ] unit-test +[ "IN: classes.tuple.test TUPLE: constructor-test ; C: constructor-test" eval word word-name ] unit-test TUPLE: size-test a b c d ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index c14205e1d9..8bcf023131 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -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 diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 54c62c44fa..61752ac7d6 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -95,7 +95,7 @@ HELP: case "If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied." $nl "The following two phrases are equivalent:" - { $code "{ { X [ Y ] } { Y [ T ] } } case" } + { $code "{ { X [ Y ] } { Z [ T ] } } case" } { $code "dup X = [ drop Y ] [ dup Z = [ drop T ] [ no-case ] if ] if" } } { $examples diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index e3d0f88680..d33edfab30 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -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 ; @@ -150,7 +150,7 @@ M: hashtable hashcode* drop ] [ dup length 4 <= - over keys [ word? ] contains? or + over keys [ [ word? ] [ wrapper? ] bi or ] contains? or [ linear-case-quot ] [ diff --git a/core/command-line/command-line.factor b/core/command-line/command-line.factor index 246bf2dabe..84020abca0 100644 --- a/core/command-line/command-line.factor +++ b/core/command-line/command-line.factor @@ -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* ; diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor index b7b599e5a9..e7dc5156e4 100755 --- a/core/compiler/errors/errors.factor +++ b/core/compiler/errors/errors.factor @@ -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 diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index fadc57dc8d..6fb6afe0c6 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -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 -alien.accessors alien.c-types alien.syntax namespaces libc -sequences.private ; +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 @@ -361,11 +361,11 @@ cell 8 = [ [ ] [ "b" get free ] unit-test ] when -[ ] [ "hello world" malloc-char-string "s" set ] unit-test +[ ] [ "hello world" ascii malloc-string "s" set ] unit-test "s" get [ - [ "hello world" ] [ "s" get [ { byte-array } declare *void* ] compile-call alien>char-string ] unit-test - [ "hello world" ] [ "s" get [ { c-ptr } declare *void* ] compile-call alien>char-string ] unit-test + [ "hello world" ] [ "s" get [ { byte-array } declare *void* ] compile-call ascii alien>string ] unit-test + [ "hello world" ] [ "s" get [ { c-ptr } declare *void* ] compile-call ascii alien>string ] unit-test [ ] [ "s" get free ] unit-test ] when diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index dce2ec562a..bc9c56864c 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -1,6 +1,6 @@ USING: compiler.units tools.test kernel kernel.private sequences.private math.private math combinators strings -alien arrays memory ; +alien arrays memory vocabs parser ; IN: compiler.tests ! Test empty word @@ -230,3 +230,11 @@ M: f single-combination-test-2 single-combination-test-4 ; ! Regression [ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test + +! Regression +10 [ + [ "compiler.tests.foo" forget-vocab ] with-compilation-unit + [ t ] [ + "USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval + ] unit-test +] times diff --git a/core/compiler/tests/stack-trace.factor b/core/compiler/tests/stack-trace.factor index f54ac62204..9ee774d81d 100755 --- a/core/compiler/tests/stack-trace.factor +++ b/core/compiler/tests/stack-trace.factor @@ -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? ; diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor index 004d088343..5a08ed0b5b 100755 --- a/core/compiler/tests/templates-early.factor +++ b/core/compiler/tests/templates-early.factor @@ -2,7 +2,8 @@ IN: compiler.tests USING: compiler generator generator.registers generator.registers.private tools.test namespaces sequences -words kernel math effects definitions compiler.units accessors ; +words kernel math effects definitions compiler.units accessors +cpu.architecture ; : ( n -- vreg ) int-regs ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 65e57a8912..a31cd8de16 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -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 ( -- ) diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 8c9db6c7e8..338c5341bc 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -1,10 +1,17 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic kernel kernel.private math memory namespaces sequences layouts system hashtables classes alien byte-arrays bit-arrays float-arrays combinators words sets ; IN: cpu.architecture +! Register classes +SINGLETON: int-regs +SINGLETON: single-float-regs +SINGLETON: double-float-regs +UNION: float-regs single-float-regs double-float-regs ; +UNION: reg-class int-regs float-regs ; + ! A pseudo-register class for parameters spilled on the stack SINGLETON: stack-params @@ -187,6 +194,9 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- ) HOOK: %box-alien cpu ( dst src -- ) +! GC check +HOOK: %gc cpu + : operand ( var -- op ) get v>operand ; inline : unique-operands ( operands quot -- ) diff --git a/core/cpu/ppc/allot/allot.factor b/core/cpu/ppc/allot/allot.factor index 34ea82dc4e..49c77c65ed 100755 --- a/core/cpu/ppc/allot/allot.factor +++ b/core/cpu/ppc/allot/allot.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel cpu.ppc.architecture cpu.ppc.assembler kernel.private namespaces math sequences generic arrays @@ -7,7 +7,7 @@ cpu.architecture alien ; IN: cpu.ppc.allot : load-zone-ptr ( reg -- ) - "nursery" f pick %load-dlsym dup 0 LWZ ; + >r "nursery" f r> %load-dlsym ; : %allot ( header size -- ) #! Store a pointer to 'size' bytes allocated from the @@ -25,6 +25,19 @@ IN: cpu.ppc.allot : %store-tagged ( reg tag -- ) >r dup fresh-object v>operand 11 r> tag-number ORI ; +M: ppc %gc + "end" define-label + 12 load-zone-ptr + 11 12 cell LWZ ! nursery.here -> r11 + 12 12 3 cells LWZ ! nursery.end -> r12 + 11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here + 11 0 12 CMP ! is here >= end? + "end" get BLE + 0 frame-required + %prepare-alien-invoke + "minor_gc" f %alien-invoke + "end" resolve-label ; + : %allot-float ( reg -- ) #! exits with tagged ptr to object in r12, untagged in r11 float 16 %allot diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 1799411021..70345b1e96 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -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 diff --git a/core/cpu/ppc/assembler/assembler.factor b/core/cpu/ppc/assembler/assembler.factor index 628022698f..b1d7016eff 100755 --- a/core/cpu/ppc/assembler/assembler.factor +++ b/core/cpu/ppc/assembler/assembler.factor @@ -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 diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 985f717035..50e38f2082 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -17,6 +17,8 @@ M: x86.32 ds-reg ESI ; M: x86.32 rs-reg EDI ; M: x86.32 stack-reg ESP ; M: x86.32 stack-save-reg EDX ; +M: x86.32 temp-reg-1 EAX ; +M: x86.32 temp-reg-2 ECX ; M: temp-reg v>operand drop EBX ; diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 99f567f448..5f396e7751 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -12,6 +12,8 @@ M: x86.64 ds-reg R14 ; M: x86.64 rs-reg R15 ; M: x86.64 stack-reg RSP ; M: x86.64 stack-save-reg RSI ; +M: x86.64 temp-reg-1 RAX ; +M: x86.64 temp-reg-2 RCX ; M: temp-reg v>operand drop RBX ; @@ -179,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 diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor index f236cdcfa6..63870f94cd 100755 --- a/core/cpu/x86/allot/allot.factor +++ b/core/cpu/x86/allot/allot.factor @@ -16,12 +16,12 @@ IN: cpu.x86.allot : object@ ( n -- operand ) cells (object@) ; -: load-zone-ptr ( -- ) +: load-zone-ptr ( reg -- ) #! Load pointer to start of zone array - "nursery" f allot-reg %alien-global ; + 0 MOV "nursery" f rc-absolute-cell rel-dlsym ; : load-allot-ptr ( -- ) - load-zone-ptr + allot-reg load-zone-ptr allot-reg PUSH allot-reg dup cell [+] MOV ; @@ -29,6 +29,19 @@ IN: cpu.x86.allot allot-reg POP allot-reg cell [+] swap 8 align ADD ; +M: x86 %gc ( -- ) + "end" define-label + temp-reg-1 load-zone-ptr + temp-reg-2 temp-reg-1 cell [+] MOV + temp-reg-2 1024 ADD + temp-reg-1 temp-reg-1 3 cells [+] MOV + temp-reg-2 temp-reg-1 CMP + "end" get JLE + 0 frame-required + %prepare-alien-invoke + "minor_gc" f %alien-invoke + "end" resolve-label ; + : store-header ( header -- ) 0 object@ swap type-number tag-fixnum MOV ; diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index fa1c9c8768..f0ca47a1ba 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -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 @@ -34,6 +35,10 @@ GENERIC: push-return-reg ( reg-class -- ) GENERIC: load-return-reg ( stack@ reg-class -- ) GENERIC: store-return-reg ( stack@ reg-class -- ) +! Only used by inline allocation +HOOK: temp-reg-1 cpu +HOOK: temp-reg-2 cpu + HOOK: address-operand cpu ( address -- operand ) HOOK: fixnum>slot@ cpu diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index 3ad7d4f7b5..cabd81dad6 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -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. diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 827a5c4e8d..34fcf8e6bc 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -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 -- ) @@ -96,10 +97,10 @@ M: relative-overflow summary : assert-depth ( quot -- ) >r datastack r> swap slip >r datastack r> - 2dup [ length ] compare sgn { - { -1 [ trim-datastacks nip relative-underflow ] } - { 0 [ 2drop ] } - { 1 [ trim-datastacks drop relative-overflow ] } + 2dup [ length ] compare { + { +lt+ [ trim-datastacks nip relative-underflow ] } + { +eq+ [ 2drop ] } + { +gt+ [ trim-datastacks drop relative-overflow ] } } case ; inline : expired-error. ( obj -- ) @@ -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" ; + array - ] 2keep diff assert-same-elements + ] 2keep swap diff assert-same-elements ] unit-test [ ] [ diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index e79907f11f..d9aa6b1c19 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -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? diff --git a/core/generator/fixup/fixup-docs.factor b/core/generator/fixup/fixup-docs.factor index 7f4b5026da..f5d530dccb 100644 --- a/core/generator/fixup/fixup-docs.factor +++ b/core/generator/fixup/fixup-docs.factor @@ -13,12 +13,6 @@ HELP: add-literal { $values { "obj" object } { "n" integer } } { $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ; -HELP: string>symbol -{ $values { "str" string } { "alien" alien } } -{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory." -$nl -"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ; - HELP: rel-dlsym { $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } } { $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats." diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 920690e9d8..06895cd8ac 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic assocs hashtables kernel kernel.private math namespaces sequences words -quotations strings alien layouts system combinators -math.bitfields words.private cpu.architecture ; +quotations strings alien.strings layouts system combinators +math.bitfields words.private cpu.architecture math.order ; IN: generator.fixup : no-stack-frame -1 ; inline @@ -110,10 +110,6 @@ SYMBOL: literal-table : add-literal ( obj -- n ) literal-table get push-new* ; -: string>symbol ( str -- alien ) - [ os wince? [ string>u16-alien ] [ string>char-alien ] if ] - over string? [ call ] [ map ] if ; - : add-dlsym-literals ( symbol dll -- ) >r string>symbol r> 2array literal-table get push-all ; diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 4eb2c0fe4e..b8de9c3517 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -40,16 +40,16 @@ SYMBOL: current-label-start compiled-stack-traces? compiling-word get f ? 1vector literal-table set - f compiling-word get compiled get set-at ; + f compiling-label get compiled get set-at ; -: finish-compiling ( literals relocation labels code -- ) +: save-machine-code ( literals relocation labels code -- ) 4array compiling-label get compiled get set-at ; : with-generator ( node word label quot -- ) [ >r begin-compiling r> { } make fixup - finish-compiling + save-machine-code ] with-scope ; inline GENERIC: generate-node ( node -- next ) @@ -73,6 +73,7 @@ GENERIC: generate-node ( node -- next ) : word-dataflow ( word -- effect dataflow ) [ dup "no-effect" word-prop [ no-effect ] when + dup "no-compile" word-prop [ no-effect ] when dup specialized-def over dup 2array 1array infer-quot finish-word ] with-infer ; diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index 3b5b6ad096..e0fd7bd457 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -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+ @@ -13,13 +13,6 @@ SYMBOL: +scratch+ SYMBOL: +clobber+ SYMBOL: known-tag -! Register classes -SINGLETON: int-regs -SINGLETON: single-float-regs -SINGLETON: double-float-regs -UNION: float-regs single-float-regs double-float-regs ; -UNION: reg-class int-regs float-regs ; - > ] bi zip - [ live-loc? ] assoc-subset + [ live-loc? ] assoc-filter values ; : live-locs ( -- seq ) @@ -379,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 - [ ] curry map diff + [ ] curry map swap diff >vector ; : compute-free-vregs ( -- ) @@ -468,11 +461,6 @@ M: loc lazy-store : finalize-contents ( -- ) finalize-locs finalize-vregs reset-phantoms ; -: %gc ( -- ) - 0 frame-required - %prepare-alien-invoke - "simple_gc" f %alien-invoke ; - ! Loading stacks to vregs : free-vregs? ( int# float# -- ? ) double-float-regs free-vregs length <= @@ -496,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 -- ) diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index bbd7186a11..600f422274 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -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 diff --git a/core/generic/generic.factor b/core/generic/generic.factor index caae16e8ed..82bab475b3 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -29,10 +29,13 @@ PREDICATE: method-spec < pair : order ( generic -- seq ) "methods" word-prop keys sort-classes ; +: specific-method ( class word -- class ) + order min-class ; + 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 ) @@ -134,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* ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 884ab8027e..90590fe565 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -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 @@ -23,7 +23,7 @@ PREDICATE: math-class < class } cond ; : math-class-max ( class class -- class ) - [ [ math-precedence ] compare 0 > ] most ; + [ [ math-precedence ] compare +gt+ eq? ] most ; : (math-upgrade) ( max class -- quot ) dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ; diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor index 1f0b80e016..c09f1abfd4 100644 --- a/core/generic/standard/engines/engines.factor +++ b/core/generic/standard/engines/engines.factor @@ -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? [ diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor index 5335074dea..e4643b2f3d 100644 --- a/core/generic/standard/engines/predicate/predicate.factor +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -17,8 +17,8 @@ C: 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' ) diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index c31c46f3f7..1bff9ae15d 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -3,7 +3,7 @@ USING: tools.test math math.functions math.constants generic.standard strings sequences arrays kernel accessors words float-arrays byte-arrays bit-arrays parser namespaces quotations inference vectors growable hashtables sbufs -prettyprint ; +prettyprint byte-vectors bit-vectors float-vectors ; GENERIC: lo-tag-test diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index f4e76aa68e..4e80ed1f6e 100755 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -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 ] diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor index f9224eafeb..d1003ac2f8 100755 --- a/core/heaps/heaps-docs.factor +++ b/core/heaps/heaps-docs.factor @@ -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" diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index b22d8818c1..d55b547b8f 100755 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -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 [ heap-pop ] must-fail diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index 02a8b8d88b..57f0e0ac72 100755 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -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 @@ -92,11 +92,11 @@ M: priority-queue heap-size ( heap -- n ) GENERIC: heap-compare ( pair1 pair2 heap -- ? ) -: (heap-compare) drop [ entry-key ] compare 0 ; inline +: (heap-compare) drop [ entry-key ] compare ; inline -M: min-heap heap-compare (heap-compare) > ; +M: min-heap heap-compare (heap-compare) +gt+ eq? ; -M: max-heap heap-compare (heap-compare) < ; +M: max-heap heap-compare (heap-compare) +lt+ eq? ; : heap-bounds-check? ( m heap -- ? ) heap-size >= ; inline diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor index 0125f04efa..91314d1312 100755 --- a/core/inference/backend/backend-docs.factor +++ b/core/inference/backend/backend-docs.factor @@ -48,10 +48,6 @@ HELP: no-effect { $description "Throws a " { $link no-effect } " error." } { $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ; -HELP: collect-recursion -{ $values { "#label" "a " { $link #label } " node" } { "seq" "a new sequence" } } -{ $description "Collect the input stacks of all child " { $link #call-label } " nodes that call the given label." } ; - HELP: inline-word { $values { "word" word } } { $description "Called during inference to infer stack effects of inline words." diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index e0cc1a5839..5896429ccf 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -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 ) @@ -60,7 +60,7 @@ M: object value-literal \ literal-expected inference-warning ; : value-vector ( n -- vector ) [ drop ] V{ } map-as ; : add-inputs ( seq stack -- n stack ) - tuck [ length ] compare dup 0 > + tuck [ length ] bi@ - dup 0 > [ dup value-vector [ swapd push-all ] keep ] [ drop 0 swap ] if ; @@ -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 @@ -409,6 +409,25 @@ TUPLE: recursive-declare-error word ; \ recursive-declare-error inference-error ] if* ; +GENERIC: collect-label-info* ( label node -- ) + +M: node collect-label-info* 2drop ; + +: (collect-label-info) ( label node vector -- ) + >r tuck [ param>> ] bi@ eq? r> [ push ] curry [ drop ] if ; + inline + +M: #call-label collect-label-info* + over calls>> (collect-label-info) ; + +M: #return collect-label-info* + over returns>> (collect-label-info) ; + +: collect-label-info ( #label -- ) + V{ } clone >>calls + V{ } clone >>returns + dup [ collect-label-info* ] with each-node ; + : nest-node ( -- ) #entry node, ; : unnest-node ( new-node -- new-node ) @@ -419,27 +438,17 @@ TUPLE: recursive-declare-error word ; : gensym dup t "inlined-block" set-word-prop ; -: inline-block ( word -- node-block data ) +: inline-block ( word -- #label data ) [ copy-inference nest-node dup word-def swap [ infer-quot-recursive ] 2keep #label unnest-node + dup collect-label-info ] H{ } make-assoc ; -GENERIC: collect-recursion* ( label node -- ) - -M: node collect-recursion* 2drop ; - -M: #call-label collect-recursion* - tuck node-param eq? [ , ] [ drop ] if ; - -: collect-recursion ( #label -- seq ) - dup node-param - [ [ swap collect-recursion* ] curry each-node ] { } make ; - -: join-values ( node -- ) - collect-recursion [ node-in-d ] map meta-d get suffix +: join-values ( #label -- ) + calls>> [ node-in-d ] map meta-d get suffix unify-lengths unify-stacks meta-d [ length tail* ] change ; @@ -460,7 +469,7 @@ M: #call-label collect-recursion* drop join-values inline-block apply-infer r> over set-node-in-d dup node, - collect-recursion [ + calls>> [ [ flatten-curries ] modify-values ] each ] [ diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 038ab1d230..e6ce2cfa0b 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -4,7 +4,12 @@ inference.dataflow optimizer tools.test kernel.private generic sequences words inference.class quotations alien alien.c-types strings sbufs sequences.private slots.private combinators definitions compiler.units -system layouts vectors ; +system layouts vectors optimizer.math.partial accessors +optimizer.inlining math.order ; + +[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test + +[ f ] [ T{ literal-constraint f 1 3 } T{ literal-constraint f 1 2 } equal? ] unit-test ! Make sure these compile even though this is invalid code [ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test @@ -13,9 +18,15 @@ system layouts vectors ; ! Ensure type inference works as it is supposed to by checking ! if various methods get inlined -: inlined? ( quot word -- ? ) +: inlined? ( quot seq/word -- ? ) + dup word? [ 1array ] when swap dataflow optimize - [ node-param eq? ] with node-exists? not ; + [ node-param swap member? ] with node-exists? not ; + +[ f ] [ + [ { integer } declare >fixnum ] + \ >fixnum inlined? +] unit-test GENERIC: mynot ( x -- y ) @@ -109,12 +120,17 @@ M: object xyz ; [ { fixnum } declare [ ] times ] \ fixnum+ inlined? ] unit-test -[ f ] [ +[ t ] [ [ { integer fixnum } declare dupd < [ 1 + ] when ] \ + inlined? ] unit-test -[ f ] [ [ dup 0 < [ neg ] when ] \ neg inlined? ] unit-test +[ f ] [ + [ { integer fixnum } declare dupd < [ 1 + ] when ] + \ +-integer-fixnum inlined? +] unit-test + +[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test [ f ] [ [ @@ -137,13 +153,13 @@ M: object xyz ; DEFER: blah -[ t ] [ +[ ] [ [ \ blah [ dup V{ } eq? [ foo ] when ] dup second dup push define ] with-compilation-unit - \ blah compiled? + \ blah word-def dataflow optimize drop ] unit-test GENERIC: detect-fx ( n -- n ) @@ -158,14 +174,20 @@ M: fixnum detect-fx ; ] \ detect-fx inlined? ] unit-test +[ t ] [ + [ + 1000000000000000000000000000000000 [ ] times + ] \ + inlined? +] unit-test [ f ] [ [ 1000000000000000000000000000000000 [ ] times - ] \ 1+ inlined? + ] \ +-integer-fixnum inlined? ] unit-test [ f ] [ - [ { bignum } declare [ ] times ] \ 1+ inlined? + [ { bignum } declare [ ] times ] + \ +-integer-fixnum inlined? ] unit-test @@ -251,19 +273,24 @@ M: float detect-float ; [ 3 + = ] \ equal? inlined? ] unit-test -[ t ] [ +[ f ] [ [ { fixnum fixnum } declare 7 bitand neg shift ] - \ shift inlined? + \ fixnum-shift-fast inlined? ] unit-test [ t ] [ [ { fixnum fixnum } declare 7 bitand neg shift ] - \ fixnum-shift inlined? + { shift fixnum-shift } inlined? ] unit-test [ t ] [ [ { fixnum fixnum } declare 1 swap 7 bitand shift ] - \ fixnum-shift inlined? + { shift fixnum-shift } inlined? +] unit-test + +[ f ] [ + [ { fixnum fixnum } declare 1 swap 7 bitand shift ] + { fixnum-shift-fast } inlined? ] unit-test cell-bits 32 = [ @@ -278,6 +305,11 @@ cell-bits 32 = [ ] unit-test ] when +[ f ] [ + [ { integer } declare -63 shift 4095 bitand ] + \ shift inlined? +] unit-test + [ t ] [ [ B{ 1 0 } *short 0 number= ] \ number= inlined? @@ -323,3 +355,228 @@ cell-bits 32 = [ ] when ] \ + inlined? ] unit-test + +[ f ] [ + [ + 256 mod + ] { mod fixnum-mod } inlined? +] unit-test + +[ f ] [ + [ + dup 0 >= [ 256 mod ] when + ] { mod fixnum-mod } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare dup 0 >= [ 256 mod ] when + ] { mod fixnum-mod } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare 256 rem + ] { mod fixnum-mod } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare [ 256 rem ] map + ] { mod fixnum-mod rem } inlined? +] unit-test + +[ t ] [ + [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined? +] unit-test + +: rec ( a -- b ) + dup 0 > [ 1 - rec ] when ; inline + +[ t ] [ + [ { fixnum } declare rec 1 + ] + { > - + } inlined? +] unit-test + +: fib ( m -- n ) + dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline + +[ t ] [ + [ 27.0 fib ] { < - + } inlined? +] unit-test + +[ f ] [ + [ 27.0 fib ] { +-integer-integer } inlined? +] unit-test + +[ t ] [ + [ 27 fib ] { < - + } inlined? +] unit-test + +[ t ] [ + [ 27 >bignum fib ] { < - + } inlined? +] unit-test + +[ f ] [ + [ 27/2 fib ] { < - } inlined? +] unit-test + +: hang-regression ( m n -- x ) + over 0 number= [ + nip + ] [ + dup [ + drop 1 hang-regression + ] [ + dupd hang-regression hang-regression + ] if + ] if ; inline + +[ t ] [ + [ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if +] { } inlined? ] unit-test + +: detect-null ( a -- b ) dup drop ; + +\ detect-null { + { [ dup dup in-d>> first node-class null eq? ] [ [ ] f splice-quot ] } +} define-optimizers + +[ t ] [ + [ { null } declare detect-null ] \ detect-null inlined? +] unit-test + +[ t ] [ + [ { null null } declare + detect-null ] \ detect-null inlined? +] unit-test + +[ f ] [ + [ { null fixnum } declare + detect-null ] \ detect-null inlined? +] unit-test + +GENERIC: detect-integer ( a -- b ) + +M: integer detect-integer ; + +[ t ] [ + [ { null fixnum } declare + detect-integer ] \ detect-integer inlined? +] unit-test + +[ t ] [ + [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined? +] unit-test + +[ f ] [ + [ { integer } declare 10 [ -1 shift ] times ] \ shift inlined? +] unit-test + +[ f ] [ + [ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ] + \ fixnum-bitand inlined? +] unit-test + +[ t ] [ + [ { integer } declare 127 bitand 3 + ] + { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined? +] unit-test + +[ f ] [ + [ { integer } declare 127 bitand 3 + ] + { >fixnum } inlined? +] unit-test + +[ t ] [ + [ { fixnum } declare [ drop ] each-integer ] + { < <-integer-fixnum +-integer-fixnum + } inlined? +] unit-test + +[ t ] [ + [ { fixnum } declare length [ drop ] each-integer ] + { < <-integer-fixnum +-integer-fixnum + } inlined? +] unit-test + +[ t ] [ + [ { fixnum } declare [ drop ] each ] + { < <-integer-fixnum +-integer-fixnum + } inlined? +] unit-test + +[ t ] [ + [ { fixnum } declare 0 [ + ] reduce ] + { < <-integer-fixnum } inlined? +] unit-test + +[ f ] [ + [ { fixnum } declare 0 [ + ] reduce ] + \ +-integer-fixnum inlined? +] unit-test + +[ t ] [ + [ + { integer } declare + dup 0 >= [ + 615949 * 797807 + 20 2^ mod dup 19 2^ - + ] [ dup ] if + ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? +] unit-test + +[ t ] [ + [ + { fixnum } declare + 615949 * 797807 + 20 2^ mod dup 19 2^ - + ] { >fixnum } inlined? +] unit-test + +[ f ] [ + [ + { integer } declare [ ] map + ] \ >fixnum inlined? +] unit-test + +[ f ] [ + [ + { integer } declare { } set-nth-unsafe + ] \ >fixnum inlined? +] unit-test + +[ f ] [ + [ + { integer } declare 1 + { } set-nth-unsafe + ] \ >fixnum inlined? +] unit-test + +[ t ] [ + [ + { integer } declare 0 swap + [ + drop 615949 * 797807 + 20 2^ rem dup 19 2^ - + ] map + ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? +] unit-test + +[ t ] [ + [ + { fixnum } declare 0 swap + [ + drop 615949 * 797807 + 20 2^ rem dup 19 2^ - + ] map + ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined? +] unit-test + +[ t ] [ + [ { integer } declare bitnot detect-integer ] + \ detect-integer inlined? +] unit-test + +! Later + +! [ t ] [ +! [ +! { integer } declare [ 256 mod ] map +! ] { mod fixnum-mod } inlined? +! ] unit-test +! +! [ t ] [ +! [ +! { integer } declare [ 0 >= ] map +! ] { >= fixnum>= } inlined? +! ] unit-test diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 033d2cce7a..9d0c55afeb 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic assocs hashtables inference kernel math namespaces sequences words parser math.intervals effects classes classes.algebra inference.dataflow -inference.backend combinators ; +inference.backend combinators accessors ; IN: inference.class ! Class inference @@ -25,12 +25,10 @@ C: literal-constraint M: literal-constraint equal? over literal-constraint? [ - 2dup - [ literal-constraint-literal ] bi@ eql? >r - [ literal-constraint-value ] bi@ = r> and - ] [ - 2drop f - ] if ; + [ [ literal>> ] bi@ eql? ] + [ [ value>> ] bi@ = ] + 2bi and + ] [ 2drop f ] if ; TUPLE: class-constraint class value ; @@ -43,8 +41,8 @@ C: interval-constraint GENERIC: apply-constraint ( constraint -- ) GENERIC: constraint-satisfied? ( constraint -- ? ) -: `input node get node-in-d nth ; -: `output node get node-out-d nth ; +: `input node get in-d>> nth ; +: `output node get out-d>> nth ; : class, , ; : literal, , ; : interval, , ; @@ -84,14 +82,12 @@ SYMBOL: value-classes set-value-interval* ; M: interval-constraint apply-constraint - dup interval-constraint-interval - swap interval-constraint-value intersect-value-interval ; + [ interval>> ] [ value>> ] bi intersect-value-interval ; : set-class-interval ( class value -- ) over class? [ - over "interval" word-prop [ - >r "interval" word-prop r> set-value-interval* - ] [ 2drop ] if + >r "interval" word-prop r> over + [ set-value-interval* ] [ 2drop ] if ] [ 2drop ] if ; : value-class* ( value -- class ) @@ -110,18 +106,21 @@ M: interval-constraint apply-constraint [ value-class* class-and ] keep set-value-class* ; M: class-constraint apply-constraint - dup class-constraint-class - swap class-constraint-value intersect-value-class ; + [ class>> ] [ value>> ] bi intersect-value-class ; + +: literal-interval ( value -- interval/f ) + dup real? [ [a,a] ] [ drop f ] if ; : set-value-literal* ( literal value -- ) - over class over set-value-class* - over real? [ over [a,a] over set-value-interval* ] when - 2dup assume - value-literals get set-at ; + { + [ >r class r> set-value-class* ] + [ >r literal-interval r> set-value-interval* ] + [ assume ] + [ value-literals get set-at ] + } 2cleave ; M: literal-constraint apply-constraint - dup literal-constraint-literal - swap literal-constraint-value set-value-literal* ; + [ literal>> ] [ value>> ] bi set-value-literal* ; ! For conditionals, an assoc of child node # --> constraint GENERIC: child-constraints ( node -- seq ) @@ -133,19 +132,18 @@ GENERIC: infer-classes-around ( node -- ) M: node infer-classes-before drop ; M: node child-constraints - node-children length + children>> length dup zero? [ drop f ] [ f ] if ; : value-literal* ( value -- obj ? ) value-literals get at* ; M: literal-constraint constraint-satisfied? - dup literal-constraint-value value-literal* - [ swap literal-constraint-literal eql? ] [ 2drop f ] if ; + dup value>> value-literal* + [ swap literal>> eql? ] [ 2drop f ] if ; M: class-constraint constraint-satisfied? - dup class-constraint-value value-class* - swap class-constraint-class class< ; + [ value>> value-class* ] [ class>> ] bi class< ; M: pair apply-constraint first2 2dup constraints get set-at @@ -154,19 +152,18 @@ M: pair apply-constraint M: pair constraint-satisfied? first constraint-satisfied? ; -: extract-keys ( assoc seq -- newassoc ) - dup length swap [ - dup >r pick at* [ r> pick set-at ] [ r> 2drop ] if - ] each nip f assoc-like ; +: extract-keys ( seq assoc -- newassoc ) + [ dupd at ] curry H{ } map>assoc [ nip ] assoc-filter f assoc-like ; : annotate-node ( node -- ) #! Annotate the node with the currently-inferred set of #! value classes. - dup node-values - value-intervals get over extract-keys pick set-node-intervals - value-classes get over extract-keys pick set-node-classes - value-literals get over extract-keys pick set-node-literals - 2drop ; + dup node-values { + [ value-intervals get extract-keys >>intervals ] + [ value-classes get extract-keys >>classes ] + [ value-literals get extract-keys >>literals ] + [ 2drop ] + } cleave ; : intersect-classes ( classes values -- ) [ intersect-value-class ] 2each ; @@ -190,31 +187,29 @@ M: pair constraint-satisfied? ] 2bi ; : compute-constraints ( #call -- ) - dup node-param "constraints" word-prop [ + dup param>> "constraints" word-prop [ call ] [ - dup node-param "predicating" word-prop dup + dup param>> "predicating" word-prop dup [ swap predicate-constraints ] [ 2drop ] if ] if* ; : compute-output-classes ( node word -- classes intervals ) - dup node-param "output-classes" word-prop + dup param>> "output-classes" word-prop dup [ call ] [ 2drop f f ] if ; : output-classes ( node -- classes intervals ) dup compute-output-classes >r - [ ] [ node-param "default-output-classes" word-prop ] ?if + [ ] [ param>> "default-output-classes" word-prop ] ?if r> ; M: #call infer-classes-before - dup compute-constraints - dup node-out-d swap output-classes - >r over intersect-classes - r> swap intersect-intervals ; + [ compute-constraints ] keep + [ output-classes ] [ out-d>> ] bi + tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ; M: #push infer-classes-before - node-out-d - [ [ value-literal ] keep set-value-literal* ] each ; + out-d>> [ [ value-literal ] keep set-value-literal* ] each ; M: #if child-constraints [ @@ -224,19 +219,17 @@ M: #if child-constraints M: #dispatch child-constraints dup [ - node-children length [ - 0 `input literal, - ] each + children>> length [ 0 `input literal, ] each ] make-constraints ; M: #declare infer-classes-before - dup node-param swap node-in-d + [ param>> ] [ in-d>> ] bi [ intersect-value-class ] 2each ; DEFER: (infer-classes) : infer-children ( node -- ) - dup node-children swap child-constraints [ + [ children>> ] [ child-constraints ] bi [ [ value-classes [ clone ] change value-literals [ clone ] change @@ -251,27 +244,27 @@ DEFER: (infer-classes) >r dup [ length ] map supremum r> [ pad-left ] 2curry map ; : (merge-classes) ( nodes -- seq ) - [ node-input-classes ] map - null pad-all flip [ null [ class-or ] reduce ] map ; + dup length 1 = [ + first node-input-classes + ] [ + [ node-input-classes ] map null pad-all flip + [ null [ class-or ] reduce ] map + ] if ; : set-classes ( seq node -- ) - node-out-d [ set-value-class* ] 2reverse-each ; + out-d>> [ set-value-class* ] 2reverse-each ; : merge-classes ( nodes node -- ) >r (merge-classes) r> set-classes ; -: (merge-intervals) ( nodes quot -- seq ) - >r - [ node-input-intervals ] map - f pad-all flip - r> map ; inline - : set-intervals ( seq node -- ) - node-out-d [ set-value-interval* ] 2reverse-each ; + out-d>> [ set-value-interval* ] 2reverse-each ; : merge-intervals ( nodes node -- ) - >r [ dup first [ interval-union ] reduce ] - (merge-intervals) r> set-intervals ; + >r + [ node-input-intervals ] map f pad-all flip + [ dup first [ interval-union ] reduce ] map + r> set-intervals ; : annotate-merge ( nodes #merge/#entry -- ) [ merge-classes ] [ merge-intervals ] 2bi ; @@ -280,28 +273,68 @@ DEFER: (infer-classes) dup node-successor dup #merge? [ swap active-children dup empty? [ 2drop ] [ swap annotate-merge ] if - ] [ - 2drop - ] if ; + ] [ 2drop ] if ; + +: classes= ( inferred current -- ? ) + 2dup min-length [ tail* ] curry bi@ sequence= ; + +SYMBOL: fixed-point? + +SYMBOL: nested-labels : annotate-entry ( nodes #label -- ) - node-child merge-classes ; + >r (merge-classes) r> node-child + 2dup node-output-classes classes= + [ 2drop ] [ set-classes fixed-point? off ] if ; + +: init-recursive-calls ( #label -- ) + #! We set recursive calls to output the empty type, then + #! repeat inference until a fixed point is reached. + #! Hopefully, our type functions are monotonic so this + #! will always converge. + returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ; M: #label infer-classes-before ( #label -- ) - #! First, infer types under the hypothesis which hold on - #! entry to the recursive label. - [ 1array ] keep annotate-entry ; + [ init-recursive-calls ] + [ [ 1array ] keep annotate-entry ] bi ; + +: infer-label-loop ( #label -- ) + fixed-point? on + dup node-child (infer-classes) + dup [ calls>> ] [ suffix ] [ annotate-entry ] tri + fixed-point? get [ drop ] [ infer-label-loop ] if ; M: #label infer-classes-around ( #label -- ) #! Now merge the types at every recursion point with the #! entry types. - { - [ annotate-node ] - [ infer-classes-before ] - [ infer-children ] - [ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ] - [ node-child (infer-classes) ] - } cleave ; + [ + { + [ nested-labels get push ] + [ annotate-node ] + [ infer-classes-before ] + [ infer-label-loop ] + [ drop nested-labels get pop* ] + } cleave + ] with-scope ; + +: find-label ( param -- #label ) + param>> nested-labels get [ param>> eq? ] with find nip ; + +M: #call-label infer-classes-before ( #call-label -- ) + [ find-label returns>> (merge-classes) ] [ out-d>> ] bi + [ set-value-class* ] 2each ; + +M: #return infer-classes-around + nested-labels get length 0 > [ + dup param>> nested-labels get peek param>> eq? [ + [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri + classes= not [ + fixed-point? off + [ in-d>> value-classes get extract-keys ] keep + set-node-classes + ] [ drop ] if + ] [ call-next-method ] if + ] [ call-next-method ] if ; M: object infer-classes-around { @@ -314,11 +347,13 @@ M: object infer-classes-around : (infer-classes) ( node -- ) [ [ infer-classes-around ] - [ node-successor (infer-classes) ] bi + [ node-successor ] bi + (infer-classes) ] when* ; : infer-classes-with ( node classes literals intervals -- ) [ + V{ } clone nested-labels set H{ } assoc-like value-intervals set H{ } assoc-like value-literals set H{ } assoc-like value-classes set @@ -326,13 +361,11 @@ M: object infer-classes-around (infer-classes) ] with-scope ; -: infer-classes ( node -- ) - f f f infer-classes-with ; +: infer-classes ( node -- node ) + dup f f f infer-classes-with ; : infer-classes/node ( node existing -- ) #! Infer classes, using the existing node's class info as a #! starting point. - dup node-classes - over node-literals - rot node-intervals + [ classes>> ] [ literals>> ] [ intervals>> ] tri infer-classes-with ; diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 3fb047b781..d7e3e78308 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -90,7 +90,7 @@ M: object flatten-curry , ; : node-child node-children first ; -TUPLE: #label < node word loop? ; +TUPLE: #label < node word loop? returns calls ; : #label ( word label -- node ) \ #label param-node swap >>word ; @@ -290,6 +290,9 @@ SYMBOL: node-stack : node-input-classes ( node -- seq ) dup in-d>> [ node-class ] with map ; +: node-output-classes ( node -- seq ) + dup out-d>> [ node-class ] with map ; + : node-input-intervals ( node -- seq ) dup in-d>> [ node-interval ] with map ; @@ -297,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? diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 2e471420da..b68c98d25d 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -92,6 +92,8 @@ M: object infer-call peek-d infer-call ] "infer" set-word-prop +\ call t "no-compile" set-word-prop + \ execute [ 1 ensure-values pop-literal nip @@ -471,18 +473,6 @@ set-primitive-effect \ set-alien-cell { c-ptr c-ptr integer } { } set-primitive-effect -\ alien>char-string { c-ptr } { string } set-primitive-effect -\ alien>char-string make-flushable - -\ string>char-alien { string } { byte-array } set-primitive-effect -\ string>char-alien make-flushable - -\ alien>u16-string { c-ptr } { string } set-primitive-effect -\ alien>u16-string make-flushable - -\ string>u16-alien { string } { byte-array } set-primitive-effect -\ string>u16-alien make-flushable - \ alien-address { alien } { integer } set-primitive-effect \ alien-address make-flushable diff --git a/core/inspector/inspector.factor b/core/inspector/inspector.factor index c9bfbfad54..0ab016b0fa 100755 --- a/core/inspector/inspector.factor +++ b/core/inspector/inspector.factor @@ -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 ; diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index bdd9e56d87..8a176ce4ec 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -41,12 +41,13 @@ $low-level-note ; ARTICLE: "encodings-descriptors" "Encoding descriptors" "An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:" -{ $vocab-subsection "ASCII" "io.encodings.ascii" } -{ $vocab-subsection "Binary" "io.encodings.binary" } +{ $subsection "io.encodings.binary" } +{ $subsection "io.encodings.utf8" } +{ $subsection "io.encodings.utf16" } { $vocab-subsection "Strict encodings" "io.encodings.strict" } +"Legacy encodings:" { $vocab-subsection "8-bit encodings" "io.encodings.8-bit" } -{ $vocab-subsection "UTF-8" "io.encodings.utf8" } -{ $vocab-subsection "UTF-16" "io.encodings.utf16" } +{ $vocab-subsection "ASCII" "io.encodings.ascii" } { $see-also "encodings-introduction" } ; ARTICLE: "encodings-protocol" "Encoding protocol" diff --git a/extra/io/encodings/utf16/.utf16.factor.swo b/core/io/encodings/utf16/.utf16.factor.swo similarity index 100% rename from extra/io/encodings/utf16/.utf16.factor.swo rename to core/io/encodings/utf16/.utf16.factor.swo diff --git a/extra/io/encodings/utf16/authors.txt b/core/io/encodings/utf16/authors.txt similarity index 100% rename from extra/io/encodings/utf16/authors.txt rename to core/io/encodings/utf16/authors.txt diff --git a/extra/io/encodings/utf16/summary.txt b/core/io/encodings/utf16/summary.txt similarity index 100% rename from extra/io/encodings/utf16/summary.txt rename to core/io/encodings/utf16/summary.txt diff --git a/extra/io/encodings/utf16/tags.txt b/core/io/encodings/utf16/tags.txt similarity index 100% rename from extra/io/encodings/utf16/tags.txt rename to core/io/encodings/utf16/tags.txt diff --git a/extra/io/encodings/utf16/utf16-docs.factor b/core/io/encodings/utf16/utf16-docs.factor similarity index 77% rename from extra/io/encodings/utf16/utf16-docs.factor rename to core/io/encodings/utf16/utf16-docs.factor index 1666219db5..f37a9d1d58 100644 --- a/extra/io/encodings/utf16/utf16-docs.factor +++ b/core/io/encodings/utf16/utf16-docs.factor @@ -5,8 +5,7 @@ ARTICLE: "io.encodings.utf16" "UTF-16" "The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:" { $subsection utf16 } { $subsection utf16le } -{ $subsection utf16be } -{ $subsection utf16n } ; +{ $subsection utf16be } ; ABOUT: "io.encodings.utf16" @@ -22,8 +21,4 @@ HELP: utf16 { $class-description "The encoding descriptor for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." } { $see-also "encodings-introduction" } ; -HELP: utf16n -{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" } -{ $see-also "encodings-introduction" } ; - -{ utf16 utf16le utf16be utf16n } related-words +{ utf16 utf16le utf16be } related-words diff --git a/extra/io/encodings/utf16/utf16-tests.factor b/core/io/encodings/utf16/utf16-tests.factor similarity index 95% rename from extra/io/encodings/utf16/utf16-tests.factor rename to core/io/encodings/utf16/utf16-tests.factor index 6985983917..0d171ee9aa 100755 --- a/extra/io/encodings/utf16/utf16-tests.factor +++ b/core/io/encodings/utf16/utf16-tests.factor @@ -1,6 +1,6 @@ USING: kernel tools.test io.encodings.utf16 arrays sbufs io.streams.byte-array sequences io.encodings io unicode -io.encodings.string alien.c-types accessors classes ; +io.encodings.string alien.c-types alien.strings accessors classes ; IN: io.encodings.utf16.tests [ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test diff --git a/extra/io/encodings/utf16/utf16.factor b/core/io/encodings/utf16/utf16.factor similarity index 92% rename from extra/io/encodings/utf16/utf16.factor rename to core/io/encodings/utf16/utf16.factor index fbc296e57c..9093132e5f 100755 --- a/extra/io/encodings/utf16/utf16.factor +++ b/core/io/encodings/utf16/utf16.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2006, 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors namespaces io.binary -io.encodings combinators splitting io byte-arrays inspector -alien.c-types ; +io.encodings combinators splitting io byte-arrays inspector ; IN: io.encodings.utf16 TUPLE: utf16be ; @@ -11,8 +10,6 @@ TUPLE: utf16le ; TUPLE: utf16 ; -TUPLE: utf16n ; - ( stream utf16 -- decoder ) M: utf16 ( stream utf16 -- encoder ) drop bom-le over stream-write utf16le ; -! Native-order UTF-16 - -: native-utf16 ( -- descriptor ) - little-endian? utf16le utf16be ? ; - -M: utf16n drop native-utf16 ; - -M: utf16n drop native-utf16 ; - PRIVATE> diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 5efbb9496d..a463fd2e40 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -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 diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 061e6386da..576307b589 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -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 ; diff --git a/core/io/streams/memory/memory.factor b/core/io/streams/memory/memory.factor new file mode 100644 index 0000000000..daadbb0e81 --- /dev/null +++ b/core/io/streams/memory/memory.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors alien.accessors math io ; +IN: io.streams.memory + +TUPLE: memory-stream alien index ; + +: ( alien -- stream ) + 0 memory-stream boa ; + +M: memory-stream stream-read1 + [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ] + [ [ 1+ ] change-index drop ] bi ; diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index b7ff37a971..531d0401b2 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -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 ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 4578e2a93f..0ef8919713 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -1,7 +1,7 @@ USING: generic help.markup help.syntax math memory -namespaces sequences kernel.private layouts sorting classes +namespaces sequences kernel.private layouts classes kernel.private vectors combinators quotations strings words -assocs arrays ; +assocs arrays math.order ; IN: kernel ARTICLE: "shuffle-words" "Shuffle words" @@ -241,7 +241,7 @@ ARTICLE: "conditionals" "Conditionals and logic" "See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches." { $see-also "booleans" "bitwise-arithmetic" both? either? } ; -ARTICLE: "equality" "Equality and comparison testing" +ARTICLE: "equality" "Equality" "There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object (" { $emphasis "identity comparison" } "), or you can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "). Both notions of equality are equality relations in the mathematical sense." $nl "Identity comparison:" @@ -250,15 +250,8 @@ $nl { $subsection = } "Custom value comparison methods:" { $subsection equal? } +"Utility class:" { $subsection identity-tuple } -"Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":" -{ $subsection <=> } -{ $subsection compare } -"Utilities for comparing objects:" -{ $subsection after? } -{ $subsection before? } -{ $subsection after=? } -{ $subsection before=? } "An object can be cloned; the clone has distinct identity but equal value:" { $subsection clone } ; @@ -393,29 +386,6 @@ 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." } ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 95f0d60720..a72e25b9e0 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -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 diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index 879862c926..19fe03202c 100755 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -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 diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index 30abd9cad6..5cd6f067a9 100755 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -6,8 +6,6 @@ IN: math.floats.private M: fixnum >float fixnum>float ; M: bignum >float bignum>float ; -M: float zero? dup 0.0 float= swap -0.0 float= or ; - M: float >fixnum float>fixnum ; M: float >bignum float>bignum ; M: float >float ; @@ -22,4 +20,7 @@ M: float + float+ ; M: float - float- ; M: float * float* ; M: float / float/f ; +M: float /f float/f ; M: float mod float-mod ; + +M: real abs dup 0 < [ neg ] when ; diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index eebc45511a..db50d262ad 100755 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -1,5 +1,5 @@ -USING: kernel math namespaces prettyprint -math.private continuations tools.test sequences ; +USING: kernel math math.functions namespaces prettyprint +math.private continuations tools.test sequences random ; IN: math.integers.tests [ "-8" ] [ -8 unparse ] unit-test @@ -184,3 +184,38 @@ unit-test [ HEX: 988a259c3433f237 ] [ B{ HEX: 37 HEX: f2 HEX: 33 HEX: 34 HEX: 9c HEX: 25 HEX: 8a HEX: 98 } byte-array>bignum ] unit-test + +[ t ] [ 256 power-of-2? ] unit-test +[ f ] [ 123 power-of-2? ] unit-test + +[ f ] [ -128 power-of-2? ] unit-test +[ f ] [ 0 power-of-2? ] unit-test +[ t ] [ 1 power-of-2? ] unit-test + +: ratio>float [ >bignum ] bi@ /f ; + +[ 5. ] [ 5 1 ratio>float ] unit-test +[ 4. ] [ 4 1 ratio>float ] unit-test +[ 2. ] [ 2 1 ratio>float ] unit-test +[ .5 ] [ 1 2 ratio>float ] unit-test +[ .75 ] [ 3 4 ratio>float ] unit-test +[ 1. ] [ 2000 2^ 2000 2^ 1+ ratio>float ] unit-test +[ -1. ] [ 2000 2^ neg 2000 2^ 1+ ratio>float ] unit-test +[ 0.4 ] [ 6 15 ratio>float ] unit-test + +[ HEX: 3fe553522d230931 ] +[ 61967020039 92984792073 ratio>float double>bits ] unit-test + +: random-integer + 32 random-bits + 1 random zero? [ neg ] when + 1 random zero? [ >bignum ] when ; + +[ t ] [ + 1000 [ + drop + random-integer + random-integer + [ >float / ] [ /f ] 2bi 0.1 ~ + ] all? +] unit-test diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 70a6d2e087..6563a1cd11 100755 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -1,4 +1,5 @@ ! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2008, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel kernel.private sequences sequences.private math math.private combinators ; @@ -22,6 +23,8 @@ M: fixnum + fixnum+ ; M: fixnum - fixnum- ; M: fixnum * fixnum* ; M: fixnum /i fixnum/i ; +M: fixnum /f >r >float r> >float float/f ; + M: fixnum mod fixnum-mod ; M: fixnum /mod fixnum/mod ; @@ -67,4 +70,57 @@ M: bignum bitnot bignum-bitnot ; M: bignum bit? bignum-bit? ; M: bignum (log2) bignum-log2 ; -M: integer zero? 0 number= ; +! Converting ratios to floats. Based on FLOAT-RATIO from +! sbcl/src/code/float.lisp, which has the following license: + +! "The software is in the public domain and is +! provided with absolutely no warranty." + +! First step: pre-scaling +: twos ( x -- y ) dup 1- bitxor log2 ; inline + +: scale-denonimator ( den -- scaled-den scale' ) + dup twos neg [ shift ] keep ; inline + +: pre-scale ( num den -- scale shifted-num scaled-den ) + 2dup [ log2 ] bi@ - + tuck [ neg 54 + shift ] [ >r scale-denonimator r> + ] 2bi* + -rot ; inline + +! Second step: loop +: shift-mantissa ( scale mantissa -- scale' mantissa' ) + [ 1+ ] [ 2/ ] bi* ; inline + +: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem ) + [ 2dup /i log2 53 > ] + [ >r shift-mantissa r> ] + [ ] while /mod ; inline + +! Third step: post-scaling +: unscaled-float ( mantissa -- n ) + 52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline + +: scale-float ( scale mantissa -- float' ) + >r dup 0 < [ neg 2^ recip ] [ 2^ ] if r> * ; inline + +: post-scale ( scale mantissa -- n ) + 2/ dup log2 52 > [ shift-mantissa ] when + unscaled-float scale-float ; inline + +! Main word +: /f-abs ( m n -- f ) + over zero? [ + 2drop 0.0 + ] [ + dup zero? [ + 2drop 1.0/0.0 + ] [ + pre-scale + /f-loop over odd? + [ zero? [ 1+ ] unless ] [ drop ] if + post-scale + ] if + ] if ; inline + +M: bignum /f ( m n -- f ) + [ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ; diff --git a/core/math/intervals/intervals-docs.factor b/core/math/intervals/intervals-docs.factor index 7eb20090ab..59fb0df18e 100644 --- a/core/math/intervals/intervals-docs.factor +++ b/core/math/intervals/intervals-docs.factor @@ -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" diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index 5204d7d45a..ba728e67c0 100755 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -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 diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index 4ca1a8637c..324d628fd1 100755 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -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 ; @@ -96,6 +96,8 @@ C: interval : interval-bitnot ( i1 -- i2 ) interval-neg interval-1- ; +: interval-sq ( i1 -- i2 ) dup interval* ; + : make-interval ( from to -- int ) over first over first { { [ 2dup > ] [ 2drop 2drop f ] } diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 5533c00090..b15f09e49d 100755 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax kernel sequences quotations -math.private math.functions ; +math.private ; IN: math ARTICLE: "division-by-zero" "Division by zero" @@ -26,17 +26,13 @@ $nl { $subsection < } { $subsection <= } { $subsection > } -{ $subsection >= } -"Inexact comparison:" -{ $subsection ~ } ; +{ $subsection >= } ; ARTICLE: "modular-arithmetic" "Modular arithmetic" { $subsection mod } { $subsection rem } { $subsection /mod } { $subsection /i } -{ $subsection mod-inv } -{ $subsection ^mod } { $see-also "integer-functions" } ; ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic" @@ -83,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 } } @@ -279,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 @@ -337,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 } "." } ; @@ -363,6 +320,10 @@ HELP: next-power-of-2 { $values { "m" "a non-negative integer" } { "n" "an integer" } } { $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ; +HELP: power-of-2? +{ $values { "n" integer } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "n" } " is a power of 2." } ; + HELP: each-integer { $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- )" } } } { $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } "." } diff --git a/core/math/math.factor b/core/math/math.factor index 064b488ac3..d5040757d4 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -17,15 +17,11 @@ 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 MATH: / ( x y -- z ) foldable +MATH: /f ( x y -- z ) foldable MATH: /i ( x y -- z ) foldable MATH: mod ( x y -- z ) foldable @@ -38,6 +34,8 @@ GENERIC# shift 1 ( x n -- y ) foldable GENERIC: bitnot ( x -- y ) foldable GENERIC# bit? 1 ( x n -- ? ) foldable +GENERIC: abs ( x -- y ) foldable + (log2) ] if ; foldable -GENERIC: zero? ( x -- ? ) foldable - -M: object zero? drop f ; - -: 1+ ( x -- y ) 1 + ; foldable -: 1- ( x -- y ) 1 - ; foldable -: 2/ ( x -- y ) -1 shift ; foldable -: sq ( x -- y ) dup * ; foldable -: neg ( x -- -x ) 0 swap - ; foldable -: recip ( x -- y ) 1 swap / ; foldable +: zero? ( x -- ? ) 0 number= ; inline +: 1+ ( x -- y ) 1 + ; inline +: 1- ( x -- y ) 1 - ; inline +: 2/ ( x -- y ) -1 shift ; inline +: 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 ; foldable -: min ( x y -- z ) [ < ] most ; foldable - -: between? ( x y z -- ? ) - pick >= [ >= ] [ 2drop f ] if ; inline - : rem ( x y -- z ) tuck mod over + swap mod ; foldable -: sgn ( x -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable - -: [-] ( x y -- z ) - 0 max ; inline - : 2^ ( n -- 2^n ) 1 swap shift ; inline : even? ( n -- ? ) 1 bitand zero? ; @@ -96,13 +80,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? @@ -121,7 +101,11 @@ M: float fp-nan? : next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable -: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline +: power-of-2? ( n -- ? ) + dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable + +: align ( m w -- n ) + 1- [ + ] keep bitnot bitand ; inline 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 diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor new file mode 100644 index 0000000000..98ff1920fa --- /dev/null +++ b/core/math/order/order-docs.factor @@ -0,0 +1,94 @@ +USING: help.markup help.syntax kernel math quotations +math.private words ; +IN: math.order + +HELP: <=> +{ $values { "obj1" object } { "obj2" object } { "symbol" symbol } } +{ $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 + { { $link +lt+ } " - indicating that " { $snippet "obj1" } " precedes " { $snippet "obj2" } } + { { $link +eq+ } " - indicating that " { $snippet "obj1" } " is equal to " { $snippet "obj2" } } + { { $link +gt+ } " - indicating that " { $snippet "obj1" } " follows " { $snippet "obj2" } } + } +} ; + +HELP: +lt+ +{ $description "Returned by " { $link <=> } " when the first object is strictly less than the second object." } ; + +HELP: +eq+ +{ $description "Returned by " { $link <=> } " when the first object is equal to the second object." } ; + +HELP: +gt+ +{ $description "Returned by " { $link <=> } " when the first object is strictly greater than the second object." } ; + +HELP: invert-comparison +{ $values { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } + { "new-symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } } +{ $description "Invert the comparison symbol returned by " { $link <=> } ". The output for the symbol " { $snippet "+eq+" } " is itself." } +{ $examples + { $example "USING: math.order prettyprint ;" "+lt+ invert-comparison ." "+gt+" } } ; + +HELP: compare +{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } } +{ $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." } +{ $examples { $example "USING: kernel math.order prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "+gt+" } +} ; + +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: 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" real } { "y" real } { "z" real } } +{ $description "Subtracts " { $snippet "y" } " from " { $snippet "x" } ". If the result is less than zero, outputs zero." } ; + +ARTICLE: "math.order" "Ordered objects" +"Some classes have an intrinsic order amongst instances:" +{ $subsection <=> } +{ $subsection compare } +{ $subsection invert-comparison } +"The above words return one of the following symbols:" +{ $subsection +lt+ } +{ $subsection +eq+ } +{ $subsection +gt+ } +"Utilities for comparing objects:" +{ $subsection after? } +{ $subsection before? } +{ $subsection after=? } +{ $subsection before=? } ; + +ABOUT: "math.order" diff --git a/core/math/order/order-tests.factor b/core/math/order/order-tests.factor new file mode 100644 index 0000000000..665537be5d --- /dev/null +++ b/core/math/order/order-tests.factor @@ -0,0 +1,9 @@ +USING: kernel math.order tools.test ; +IN: math.order.tests + +[ +lt+ ] [ "ab" "abc" <=> ] unit-test +[ +gt+ ] [ "abc" "ab" <=> ] unit-test +[ +lt+ ] [ 3 4 <=> ] unit-test +[ +eq+ ] [ 4 4 <=> ] unit-test +[ +gt+ ] [ 4 3 <=> ] unit-test + diff --git a/core/math/order/order.factor b/core/math/order/order.factor new file mode 100644 index 0000000000..7cbef68dcc --- /dev/null +++ b/core/math/order/order.factor @@ -0,0 +1,45 @@ +! Copyright (C) 2008 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math ; +IN: math.order + +SYMBOL: +lt+ +SYMBOL: +eq+ +SYMBOL: +gt+ + +GENERIC: <=> ( obj1 obj2 -- symbol ) + +: (<=>) ( a b -- symbol ) + 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; inline + +: invert-comparison ( symbol -- new-symbol ) + #! Can't use case, index or nth here + dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ; + +M: real <=> (<=>) ; +M: integer <=> (<=>) ; + +GENERIC: before? ( obj1 obj2 -- ? ) +GENERIC: after? ( obj1 obj2 -- ? ) +GENERIC: before=? ( obj1 obj2 -- ? ) +GENERIC: after=? ( obj1 obj2 -- ? ) + +M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ; +M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ; +M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ; +M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ; + +M: real before? ( obj1 obj2 -- ? ) < ; +M: real after? ( obj1 obj2 -- ? ) > ; +M: real before=? ( obj1 obj2 -- ? ) <= ; +M: real after=? ( obj1 obj2 -- ? ) >= ; + +: min ( x y -- z ) [ before? ] most ; inline +: max ( x y -- z ) [ after? ] most ; inline + +: between? ( x y z -- ? ) + pick after=? [ after=? ] [ 2drop f ] if ; inline + +: [-] ( x y -- z ) - 0 max ; inline + +: compare ( obj1 obj2 quot -- symbol ) bi@ <=> ; inline diff --git a/core/mirrors/mirrors-docs.factor b/core/mirrors/mirrors-docs.factor index dc4315fb39..60de841568 100755 --- a/core/mirrors/mirrors-docs.factor +++ b/core/mirrors/mirrors-docs.factor @@ -30,6 +30,7 @@ HELP: { $examples { $example "USING: assocs mirrors prettyprint ;" + "IN: scratchpad" "TUPLE: circle center radius ;" "C: circle" "{ 100 50 } 15 >alist ." @@ -37,10 +38,6 @@ HELP: } } ; -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." } ; diff --git a/core/mirrors/mirrors-tests.factor b/core/mirrors/mirrors-tests.factor index 11e5772000..45970c8bae 100755 --- a/core/mirrors/mirrors-tests.factor +++ b/core/mirrors/mirrors-tests.factor @@ -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 [ 3 ] [ 3 "baz" 1 2 [ set-at ] keep foo-baz ] unit-test + +[ 3 "hi" 1 2 set-at ] [ + [ no-such-slot? ] + [ name>> "hi" = ] + [ object>> foo? ] tri and and +] must-fail-with + +[ 3 "numerator" 1/2 set-at ] [ + [ immutable-slot? ] + [ name>> "numerator" = ] + [ object>> 1/2 = ] tri and and +] must-fail-with diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index 02afaf07fc..0a49163075 100755 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -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 ; : ( 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 ) diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor index 971477cd4d..1da3bc45db 100755 --- a/core/namespaces/namespaces-docs.factor +++ b/core/namespaces/namespaces-docs.factor @@ -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 diff --git a/core/namespaces/namespaces-tests.factor b/core/namespaces/namespaces-tests.factor index 8dc065c04a..4c11e2389f 100644 --- a/core/namespaces/namespaces-tests.factor +++ b/core/namespaces/namespaces-tests.factor @@ -1,5 +1,5 @@ -IN: namespaces.tests USING: kernel namespaces tools.test words ; +IN: namespaces.tests H{ } clone "test-namespace" set diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 3237f095bf..9b70ccdd9d 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -3,7 +3,7 @@ USING: arrays generic assocs inference inference.class inference.dataflow inference.backend inference.state io kernel math namespaces sequences vectors words quotations hashtables -combinators classes optimizer.def-use ; +combinators classes optimizer.def-use accessors ; IN: optimizer.backend SYMBOL: class-substitutions @@ -16,37 +16,32 @@ SYMBOL: optimizer-changed GENERIC: optimize-node* ( node -- node/t changed? ) -: ?union ( assoc/f assoc -- hash ) - over [ assoc-union ] [ nip ] if ; +: ?union ( assoc assoc/f -- assoc' ) + dup assoc-empty? [ drop ] [ swap assoc-union ] if ; -: add-node-literals ( assoc node -- ) - over assoc-empty? [ +: add-node-literals ( node assoc -- ) + [ ?union ] curry change-literals drop ; + +: add-node-classes ( node assoc -- ) + [ ?union ] curry change-classes drop ; + +: substitute-values ( node assoc -- ) + dup assoc-empty? [ 2drop ] [ - [ node-literals ?union ] keep set-node-literals - ] if ; - -: add-node-classes ( assoc node -- ) - over assoc-empty? [ - 2drop - ] [ - [ node-classes ?union ] keep set-node-classes - ] if ; - -: substitute-values ( assoc node -- ) - over assoc-empty? [ - 2drop - ] [ - 2dup node-in-d swap substitute-here - 2dup node-in-r swap substitute-here - 2dup node-out-d swap substitute-here - node-out-r swap substitute-here + { + [ >r in-d>> r> substitute-here ] + [ >r in-r>> r> substitute-here ] + [ >r out-d>> r> substitute-here ] + [ >r out-r>> r> substitute-here ] + } 2cleave ] if ; : perform-substitutions ( node -- ) - class-substitutions get over add-node-classes - literal-substitutions get over add-node-literals - value-substitutions get swap substitute-values ; + [ class-substitutions get add-node-classes ] + [ literal-substitutions get add-node-literals ] + [ value-substitutions get substitute-values ] + tri ; DEFER: optimize-nodes @@ -90,18 +85,21 @@ M: node optimize-node* drop t f ; #! Not very efficient. dupd union* update ; -: compute-value-substitutions ( #return/#values #call/#merge -- assoc ) - node-out-d swap node-in-d 2array unify-lengths flip - [ = not ] assoc-subset >hashtable ; +: compute-value-substitutions ( #call/#merge #return/#values -- assoc ) + [ out-d>> ] [ in-d>> ] bi* 2array unify-lengths flip + [ = not ] assoc-filter >hashtable ; : cleanup-inlining ( #return/#values -- newnode changed? ) - dup node-successor dup [ - class-substitutions get pick node-classes update - literal-substitutions get pick node-literals update - tuck compute-value-substitutions value-substitutions get swap update* - node-successor t + dup node-successor [ + [ node-successor ] keep + { + [ nip classes>> class-substitutions get swap update ] + [ nip literals>> literal-substitutions get swap update ] + [ compute-value-substitutions value-substitutions get swap update* ] + [ drop node-successor ] + } 2cleave t ] [ - 2drop t f + drop t f ] if ; ! #return diff --git a/core/optimizer/collect/collect.factor b/core/optimizer/collect/collect.factor new file mode 100644 index 0000000000..6b9aee4e1a --- /dev/null +++ b/core/optimizer/collect/collect.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2006, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: inference.dataflow inference.backend kernel ; +IN: optimizer + +: collect-label-infos ( node -- node ) + dup [ + dup #label? [ collect-label-info ] [ drop ] if + ] each-node ; + diff --git a/core/optimizer/control/control-tests.factor b/core/optimizer/control/control-tests.factor index ce77cdd43a..9c6d041bca 100755 --- a/core/optimizer/control/control-tests.factor +++ b/core/optimizer/control/control-tests.factor @@ -27,22 +27,22 @@ optimizer ; dup [ 1+ loop-test-1 ] [ drop ] if ; inline [ t ] [ - [ loop-test-1 ] dataflow dup detect-loops + [ loop-test-1 ] dataflow detect-loops \ loop-test-1 label-is-loop? ] unit-test [ t ] [ - [ loop-test-1 1 2 3 ] dataflow dup detect-loops + [ loop-test-1 1 2 3 ] dataflow detect-loops \ loop-test-1 label-is-loop? ] unit-test [ t ] [ - [ [ loop-test-1 ] each ] dataflow dup detect-loops + [ [ loop-test-1 ] each ] dataflow detect-loops \ loop-test-1 label-is-loop? ] unit-test [ t ] [ - [ [ loop-test-1 ] each ] dataflow dup detect-loops + [ [ loop-test-1 ] each ] dataflow detect-loops \ (each-integer) label-is-loop? ] unit-test @@ -50,7 +50,7 @@ optimizer ; dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline [ t ] [ - [ loop-test-2 ] dataflow dup detect-loops + [ loop-test-2 ] dataflow detect-loops \ loop-test-2 label-is-not-loop? ] unit-test @@ -58,7 +58,7 @@ optimizer ; dup [ [ loop-test-3 ] each ] [ drop ] if ; inline [ t ] [ - [ loop-test-3 ] dataflow dup detect-loops + [ loop-test-3 ] dataflow detect-loops \ loop-test-3 label-is-not-loop? ] unit-test @@ -73,7 +73,7 @@ optimizer ; dup #label? [ node-successor find-label ] unless ; : test-loop-exits - dataflow dup detect-loops find-label + dataflow detect-loops find-label dup node-param swap [ node-child find-tail find-loop-exits [ class ] map ] keep #label-loop? ; @@ -113,7 +113,7 @@ optimizer ; ] unit-test [ f ] [ - [ [ [ ] map ] map ] dataflow dup detect-loops + [ [ [ ] map ] map ] dataflow detect-loops [ dup #label? swap #loop? not and ] node-exists? ] unit-test @@ -128,22 +128,22 @@ DEFER: a blah [ b ] [ a ] if ; inline [ t ] [ - [ a ] dataflow dup detect-loops + [ a ] dataflow detect-loops \ a label-is-loop? ] unit-test [ t ] [ - [ a ] dataflow dup detect-loops + [ a ] dataflow detect-loops \ b label-is-loop? ] unit-test [ t ] [ - [ b ] dataflow dup detect-loops + [ b ] dataflow detect-loops \ a label-is-loop? ] unit-test [ t ] [ - [ a ] dataflow dup detect-loops + [ a ] dataflow detect-loops \ b label-is-loop? ] unit-test @@ -156,12 +156,12 @@ DEFER: a' blah [ b' ] [ a' ] if ; inline [ f ] [ - [ a' ] dataflow dup detect-loops + [ a' ] dataflow detect-loops \ a' label-is-loop? ] unit-test [ f ] [ - [ b' ] dataflow dup detect-loops + [ b' ] dataflow detect-loops \ b' label-is-loop? ] unit-test @@ -171,11 +171,11 @@ DEFER: a' ! a standard iterative dataflow problem after all -- so I'm ! tempted to believe the computer here [ t ] [ - [ b' ] dataflow dup detect-loops + [ b' ] dataflow detect-loops \ a' label-is-loop? ] unit-test [ f ] [ - [ a' ] dataflow dup detect-loops + [ a' ] dataflow detect-loops \ b' label-is-loop? ] unit-test diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index f9f8901c41..de7aec2bb1 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -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 ; @@ -109,8 +109,9 @@ SYMBOL: potential-loops ] [ 2drop ] if ] assoc-each [ remove-non-loop-calls ] when ; -: detect-loops ( nodes -- ) +: detect-loops ( node -- node ) [ + dup collect-label-info remove-non-tail-calls remove-non-loop-calls diff --git a/core/optimizer/def-use/def-use-tests.factor b/core/optimizer/def-use/def-use-tests.factor index f22cce9fa8..914018437a 100755 --- a/core/optimizer/def-use/def-use-tests.factor +++ b/core/optimizer/def-use/def-use-tests.factor @@ -3,12 +3,12 @@ USING: inference inference.dataflow optimizer optimizer.def-use namespaces assocs kernel sequences math tools.test words ; [ 3 { 1 1 1 } ] [ - [ 1 2 3 ] dataflow compute-def-use + [ 1 2 3 ] dataflow compute-def-use drop def-use get values dup length swap [ length ] map ] unit-test : kill-set ( quot -- seq ) - dataflow compute-def-use compute-dead-literals keys + dataflow compute-def-use drop compute-dead-literals keys [ value-literal ] map ; : subset? [ member? ] curry all? ; diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor index 54fca38ee2..a2e9f88135 100755 --- a/core/optimizer/def-use/def-use.factor +++ b/core/optimizer/def-use/def-use.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: optimizer.def-use USING: namespaces assocs sequences inference.dataflow -inference.backend kernel generic assocs classes vectors ; +inference.backend kernel generic assocs classes vectors +accessors combinators ; +IN: optimizer.def-use SYMBOL: def-use @@ -21,17 +22,20 @@ SYMBOL: def-use GENERIC: node-def-use ( node -- ) -: compute-def-use ( node -- ) - H{ } clone def-use set [ node-def-use ] each-node ; +: compute-def-use ( node -- node ) + H{ } clone def-use set + dup [ node-def-use ] each-node ; : nest-def-use ( node -- def-use ) - [ compute-def-use def-use get ] with-scope ; + [ compute-def-use drop def-use get ] with-scope ; : (node-def-use) ( node -- ) - dup dup node-in-d uses-values - dup dup node-in-r uses-values - dup node-out-d defs-values - node-out-r defs-values ; + { + [ dup in-d>> uses-values ] + [ dup in-r>> uses-values ] + [ out-d>> defs-values ] + [ out-r>> defs-values ] + } cleave ; M: object node-def-use (node-def-use) ; @@ -43,7 +47,7 @@ M: #passthru node-def-use drop ; M: #return node-def-use #! Values returned by local labels can be killed. - dup node-param [ drop ] [ (node-def-use) ] if ; + dup param>> [ drop ] [ (node-def-use) ] if ; ! nodes that don't use their values directly UNION: #killable @@ -52,17 +56,17 @@ 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 [ - dup node-in-d , - dup node-child node-out-d , - dup collect-recursion [ node-in-d , ] each + dup in-d>> , + dup node-child out-d>> , + dup calls>> [ in-d>> , ] each ] { } make purge-invariants uses-values ; : branch-def-use ( #branch -- ) - active-children [ node-in-d ] map + active-children [ in-d>> ] map purge-invariants t swap uses-values ; M: #branch node-def-use @@ -71,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 @@ -85,16 +89,16 @@ M: node kill-node* drop t ; inline M: #shuffle kill-node* - [ - dup node-in-d empty? swap node-out-d empty? and - ] prune-if ; + [ [ in-d>> empty? ] [ out-d>> empty? ] bi and ] prune-if ; M: #push kill-node* - [ node-out-d empty? ] prune-if ; + [ out-d>> empty? ] prune-if ; -M: #>r kill-node* [ node-in-d empty? ] prune-if ; +M: #>r kill-node* + [ in-d>> empty? ] prune-if ; -M: #r> kill-node* [ node-in-r empty? ] prune-if ; +M: #r> kill-node* + [ in-r>> empty? ] prune-if ; : kill-node ( node -- node ) dup [ @@ -116,7 +120,7 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ; ] if ; : sole-consumer ( #call -- node/f ) - node-out-d first used-by + out-d>> first used-by dup length 1 = [ first ] [ drop f ] if ; : splice-def-use ( node -- ) @@ -128,5 +132,5 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ; #! degree of accuracy; the new values should be marked as #! having _some_ usage, so that flushing doesn't erronously #! flush them away. - [ compute-def-use def-use get keys ] with-scope + nest-def-use keys def-use get [ [ t swap ?push ] change-at ] curry each ; diff --git a/core/optimizer/inlining/inlining-tests.factor b/core/optimizer/inlining/inlining-tests.factor new file mode 100644 index 0000000000..608054becb --- /dev/null +++ b/core/optimizer/inlining/inlining-tests.factor @@ -0,0 +1,10 @@ +IN: optimizer.inlining.tests +USING: tools.test optimizer.inlining ; + +\ word-flat-length must-infer + +\ inlining-math-method must-infer + +\ optimistic-inline? must-infer + +\ find-identity must-infer diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 8447d1be5f..33c8244b4c 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -3,10 +3,11 @@ USING: arrays generic assocs inference inference.class inference.dataflow inference.backend inference.state io kernel math namespaces sequences vectors words quotations hashtables -combinators classes classes.algebra generic.math continuations -optimizer.def-use optimizer.backend generic.standard -optimizer.specializers optimizer.def-use optimizer.pattern-match -generic.standard optimizer.control kernel.private ; +combinators classes classes.algebra generic.math +optimizer.math.partial continuations optimizer.def-use +optimizer.backend generic.standard optimizer.specializers +optimizer.def-use optimizer.pattern-match generic.standard +optimizer.control kernel.private ; IN: optimizer.inlining : remember-inlining ( node history -- ) @@ -53,8 +54,6 @@ DEFER: (flat-length) [ word-def (flat-length) ] with-scope ; ! Single dispatch method inlining optimization -: specific-method ( class word -- class ) order min-class ; - : node-class# ( node n -- class ) over node-in-d ?nth node-class ; @@ -72,6 +71,7 @@ DEFER: (flat-length) ! Partial dispatch of math-generic words : normalize-math-class ( class -- class' ) { + null fixnum bignum integer ratio rational float real @@ -79,21 +79,31 @@ DEFER: (flat-length) object } [ class< ] with find nip ; -: math-both-known? ( word left right -- ? ) - math-class-max swap specific-method ; - -: inline-math-method ( #call word -- node ) - over node-input-classes +: inlining-math-method ( #call word -- quot/f ) + swap node-input-classes [ first normalize-math-class ] [ second normalize-math-class ] bi - 3dup math-both-known? - [ math-method f splice-quot ] - [ 2drop 2drop t ] if ; + 3dup math-both-known? [ math-method* ] [ 3drop f ] if ; + +: inline-math-method ( #call word -- node/t ) + [ drop ] [ inlining-math-method ] 2bi + dup [ f splice-quot ] [ 2drop t ] if ; + +: inline-math-partial ( #call word -- node/t ) + [ drop ] + [ + "derived-from" word-prop first + inlining-math-method dup + ] + [ nip 1quotation ] 2tri + [ = not ] [ drop ] 2bi and + [ f splice-quot ] [ 2drop t ] if ; : inline-method ( #call -- node ) dup node-param { { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } + { [ dup math-partial? ] [ inline-math-partial ] } [ 2drop t ] } cond ; @@ -183,7 +193,7 @@ DEFER: (flat-length) nip dup [ second ] when ; : apply-identities ( node -- node/f ) - dup find-identity dup [ f splice-quot ] [ 2drop f ] if ; + dup find-identity f splice-quot ; : optimistic-inline? ( #call -- ? ) dup node-param "specializer" word-prop dup [ diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index cf71af216e..6e1aacff44 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -60,7 +60,8 @@ sequences.private combinators ; [ value-literal sequence? ] [ drop f ] if ; : member-quot ( seq -- newquot ) - [ [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ; + [ literalize [ t ] ] { } map>assoc + [ drop f ] suffix [ nip case ] curry ; : expand-member ( #call -- ) dup node-in-d peek value-literal member-quot f splice-quot ; @@ -83,21 +84,11 @@ sequences.private combinators ; ] "constraints" set-word-prop ! eq? on the same object is always t -{ eq? bignum= float= number= = } { +{ eq? = } { { { @ @ } [ 2drop t ] } } define-identities ! Specializers -{ 1+ 1- sq neg recip sgn } [ - { number } "specializer" set-word-prop -] each - -\ 2/ { fixnum } "specializer" set-word-prop - -{ min max } [ - { number number } "specializer" set-word-prop -] each - { first first2 first3 first4 } [ { array } "specializer" set-word-prop ] each diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 4ec4bfeb36..ab8a1f3eda 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -8,103 +8,104 @@ namespaces assocs quotations math.intervals sequences.private combinators splitting layouts math.parser classes classes.algebra generic.math optimizer.pattern-match optimizer.backend optimizer.def-use optimizer.inlining -generic.standard system ; +optimizer.math.partial generic.standard system accessors ; -{ + bignum+ float+ fixnum+fast } { +: define-math-identities ( word identities -- ) + >r all-derived-ops r> define-identities ; + +\ number= { + { { @ @ } [ 2drop t ] } +} define-math-identities + +\ + { { { number 0 } [ drop ] } { { 0 number } [ nip ] } -} define-identities +} define-math-identities -{ fixnum+ } { - { { number 0 } [ drop ] } - { { 0 number } [ nip ] } -} define-identities - -{ - fixnum- bignum- float- fixnum-fast } { +\ - { { { number 0 } [ drop ] } { { @ @ } [ 2drop 0 ] } -} define-identities +} define-math-identities -{ < fixnum< bignum< float< } { +\ < { { { @ @ } [ 2drop f ] } -} define-identities +} define-math-identities -{ <= fixnum<= bignum<= float<= } { +\ <= { { { @ @ } [ 2drop t ] } -} define-identities +} define-math-identities -{ > fixnum> bignum> float>= } { +\ > { { { @ @ } [ 2drop f ] } -} define-identities +} define-math-identities -{ >= fixnum>= bignum>= float>= } { +\ >= { { { @ @ } [ 2drop t ] } -} define-identities +} define-math-identities -{ * fixnum* bignum* float* } { +\ * { { { number 1 } [ drop ] } { { 1 number } [ nip ] } { { number 0 } [ nip ] } { { 0 number } [ drop ] } { { number -1 } [ drop 0 swap - ] } { { -1 number } [ nip 0 swap - ] } -} define-identities +} define-math-identities -{ / fixnum/i bignum/i float/f } { +\ / { { { number 1 } [ drop ] } { { number -1 } [ drop 0 swap - ] } -} define-identities +} define-math-identities -{ fixnum-mod bignum-mod } { - { { number 1 } [ 2drop 0 ] } -} define-identities +\ mod { + { { integer 1 } [ 2drop 0 ] } +} define-math-identities -{ bitand fixnum-bitand bignum-bitand } { +\ rem { + { { integer 1 } [ 2drop 0 ] } +} define-math-identities + +\ bitand { { { number -1 } [ drop ] } { { -1 number } [ nip ] } { { @ @ } [ drop ] } { { number 0 } [ nip ] } { { 0 number } [ drop ] } -} define-identities +} define-math-identities -{ bitor fixnum-bitor bignum-bitor } { +\ bitor { { { number 0 } [ drop ] } { { 0 number } [ nip ] } { { @ @ } [ drop ] } { { number -1 } [ nip ] } { { -1 number } [ drop ] } -} define-identities +} define-math-identities -{ bitxor fixnum-bitxor bignum-bitxor } { +\ bitxor { { { number 0 } [ drop ] } { { 0 number } [ nip ] } { { number -1 } [ drop bitnot ] } { { -1 number } [ nip bitnot ] } { { @ @ } [ 2drop 0 ] } -} define-identities +} define-math-identities -{ shift fixnum-shift fixnum-shift-fast bignum-shift } { +\ shift { { { 0 number } [ drop ] } { { number 0 } [ drop ] } -} define-identities +} define-math-identities : math-closure ( class -- newclass ) - { fixnum integer rational real } + { null fixnum bignum integer rational float real number } [ class< ] with find nip number or ; : fits? ( interval class -- ? ) "interval" word-prop dup [ interval-subset? ] [ 2drop t ] if ; -: math-output-class ( node min -- newclass ) - #! if min is f, it means we just want to use the declared - #! output class from the "infer-effect". - dup [ - swap node-in-d - [ value-class* math-closure math-class-max ] each - ] [ - 2drop f - ] if ; +: math-output-class ( node upgrades -- newclass ) + >r + in-d>> null [ value-class* math-closure math-class-max ] reduce + dup r> at swap or ; : won't-overflow? ( interval node -- ? ) node-in-d [ value-class* fixnum class< ] all? @@ -123,28 +124,18 @@ generic.standard system ; 2drop f ] if ; inline -: math-output-class/interval-1 ( node min word -- classes intervals ) - pick >r - >r over r> - math-output-interval-1 - >r math-output-class r> - r> post-process ; inline +: math-output-class/interval-1 ( node word -- classes intervals ) + [ drop { } math-output-class 1array ] + [ math-output-interval-1 1array ] 2bi ; { - { 1+ integer interval-1+ } - { 1- integer interval-1- } - { neg integer interval-neg } - { shift integer interval-recip } - { bitnot fixnum interval-bitnot } - { fixnum-bitnot f interval-bitnot } - { bignum-bitnot f interval-bitnot } - { 2/ fixnum interval-2/ } - { sq integer f } + { bitnot interval-bitnot } + { fixnum-bitnot interval-bitnot } + { bignum-bitnot interval-bitnot } } [ - first3 [ - math-output-class/interval-1 - ] 2curry "output-classes" set-word-prop -] each + [ math-output-class/interval-1 ] curry + "output-classes" set-word-prop +] assoc-each : intervals ( node -- i1 i2 ) node-in-d first2 [ value-interval* ] bi@ ; @@ -156,7 +147,7 @@ generic.standard system ; 2drop f ] if ; inline -: math-output-class/interval-2 ( node min word -- classes intervals ) +: math-output-class/interval-2 ( node upgrades word -- classes intervals ) pick >r >r over r> math-output-interval-2 @@ -164,47 +155,18 @@ generic.standard system ; r> post-process ; inline { - { + integer interval+ } - { - integer interval- } - { * integer interval* } - { / rational interval/ } - { /i integer interval/i } - - { fixnum+ f interval+ } - { fixnum+fast f interval+ } - { fixnum- f interval- } - { fixnum-fast f interval- } - { fixnum* f interval* } - { fixnum*fast f interval* } - { fixnum/i f interval/i } - - { bignum+ f interval+ } - { bignum- f interval- } - { bignum* f interval* } - { bignum/i f interval/i } - { bignum-shift f interval-shift-safe } - - { float+ f interval+ } - { float- f interval- } - { float* f interval* } - { float/f f interval/ } - - { min fixnum interval-min } - { max fixnum interval-max } + { + { { fixnum integer } } interval+ } + { - { { fixnum integer } } interval- } + { * { { fixnum integer } } interval* } + { / { { fixnum rational } { integer rational } } interval/ } + { /i { { fixnum integer } } interval/i } + { shift { { fixnum integer } } interval-shift-safe } } [ first3 [ - math-output-class/interval-2 - ] 2curry "output-classes" set-word-prop -] each - -{ fixnum-shift fixnum-shift-fast shift } [ - [ - dup - node-in-d second value-interval* - -1./0. 0 [a,b] interval-subset? fixnum integer ? - \ interval-shift-safe - math-output-class/interval-2 - ] "output-classes" set-word-prop + [ + math-output-class/interval-2 + ] 2curry "output-classes" set-word-prop + ] 2curry each-derived-op ] each : real-value? ( value -- n ? ) @@ -235,22 +197,18 @@ generic.standard system ; r> post-process ; inline { - { mod fixnum mod-range } - { fixnum-mod f mod-range } - { bignum-mod f mod-range } - { float-mod f mod-range } + { mod { } mod-range } + { rem { { fixnum integer } } rem-range } - { rem integer rem-range } - - { bitand fixnum bitand-range } - { fixnum-bitand f bitand-range } - - { bitor fixnum f } - { bitxor fixnum f } + { bitand { } bitand-range } + { bitor { } f } + { bitxor { } f } } [ first3 [ - math-output-class/interval-special - ] 2curry "output-classes" set-word-prop + [ + math-output-class/interval-special + ] 2curry "output-classes" set-word-prop + ] 2curry each-derived-op ] each : twiddle-interval ( i1 -- i2 ) @@ -280,26 +238,12 @@ generic.standard system ; { <= assume<= assume> } { > assume> assume<= } { >= assume>= assume< } - - { fixnum< assume< assume>= } - { fixnum<= assume<= assume> } - { fixnum> assume> assume<= } - { fixnum>= assume>= assume< } - - { bignum< assume< assume>= } - { bignum<= assume<= assume> } - { bignum> assume> assume<= } - { bignum>= assume>= assume< } - - { float< assume< assume>= } - { float<= assume<= assume> } - { float> assume> assume<= } - { float>= assume>= assume< } } [ - first3 - [ - [ comparison-constraints ] with-scope - ] 2curry "constraints" set-word-prop + first3 [ + [ + [ comparison-constraints ] with-scope + ] 2curry "constraints" set-word-prop + ] 2curry each-derived-op ] each { @@ -348,22 +292,20 @@ most-negative-fixnum most-positive-fixnum [a,b] ! Removing overflow checks : remove-overflow-check? ( #call -- ? ) - dup node-out-d first node-class fixnum class< ; + dup out-d>> first node-class + [ fixnum class< ] [ null eq? not ] bi and ; { { + [ fixnum+fast ] } + { +-integer-fixnum [ fixnum+fast ] } { - [ fixnum-fast ] } { * [ fixnum*fast ] } + { *-integer-fixnum [ fixnum*fast ] } + { shift [ fixnum-shift-fast ] } { fixnum+ [ fixnum+fast ] } { fixnum- [ fixnum-fast ] } { fixnum* [ fixnum*fast ] } - ! these are here as an optimization. if they weren't given - ! explicitly, the same would be inferred after an extra - ! optimization step (see optimistic-inline?) - { 1+ [ 1 fixnum+fast ] } - { 1- [ 1 fixnum-fast ] } - { 2/ [ -1 fixnum-shift ] } - { neg [ 0 swap fixnum-fast ] } + { fixnum-shift [ fixnum-shift-fast ] } } [ [ [ dup remove-overflow-check? ] , @@ -397,26 +339,13 @@ most-negative-fixnum most-positive-fixnum [a,b] { <= interval<= } { > interval> } { >= interval>= } - - { fixnum< interval< } - { fixnum<= interval<= } - { fixnum> interval> } - { fixnum>= interval>= } - - { bignum< interval< } - { bignum<= interval<= } - { bignum> interval> } - { bignum>= interval>= } - - { float< interval< } - { float<= interval<= } - { float> interval> } - { float>= interval>= } } [ [ - dup [ dupd foldable-comparison? ] curry , - [ fold-comparison ] curry , - ] { } make 1array define-optimizers + [ + dup [ dupd foldable-comparison? ] curry , + [ fold-comparison ] curry , + ] { } make 1array define-optimizers + ] curry each-derived-op ] assoc-each ! The following words are handled in a similar way except if @@ -426,44 +355,68 @@ most-negative-fixnum most-positive-fixnum [a,b] swap sole-consumer dup #call? [ node-param eq? ] [ 2drop f ] if ; -: coereced-to-fixnum? ( #call -- ? ) - \ >fixnum consumed-by? ; +: coerced-to-fixnum? ( #call -- ? ) + dup dup node-in-d [ node-class integer class< ] with all? + [ \ >fixnum consumed-by? ] [ drop f ] if ; { - { fixnum+ [ fixnum+fast ] } - { fixnum- [ fixnum-fast ] } - { fixnum* [ fixnum*fast ] } + { + [ [ >fixnum ] bi@ fixnum+fast ] } + { - [ [ >fixnum ] bi@ fixnum-fast ] } + { * [ [ >fixnum ] bi@ fixnum*fast ] } } [ - [ + >r derived-ops r> [ [ - dup remove-overflow-check? - over coereced-to-fixnum? or - ] , - [ f splice-quot ] curry , - ] { } make 1array define-optimizers + [ + dup remove-overflow-check? + over coerced-to-fixnum? or + ] , + [ f splice-quot ] curry , + ] { } make 1array define-optimizers + ] curry each ] assoc-each -: fixnum-shift-fast-pos? ( node -- ? ) - #! Shifting 1 to the left won't overflow if the shift - #! count is small enough - dup dup node-in-d first node-literal 1 = [ - dup node-in-d second node-interval - 0 cell-bits tag-bits get - 2 - [a,b] interval-subset? - ] [ drop f ] if ; +: convert-rem-to-and? ( #call -- ? ) + dup node-in-d { + { [ 2dup first node-class integer class< not ] [ f ] } + { [ 2dup second node-literal integer? not ] [ f ] } + { [ 2dup second node-literal power-of-2? not ] [ f ] } + [ t ] + } cond 2nip ; -: fixnum-shift-fast-neg? ( node -- ? ) - #! Shifting any number to the right won't overflow if the - #! shift count is small enough - dup node-in-d second node-interval - cell-bits 1- neg 0 [a,b] interval-subset? ; +: convert-mod-to-and? ( #call -- ? ) + dup dup node-in-d first node-interval 0 [a,inf] interval-subset? + [ convert-rem-to-and? ] [ drop f ] if ; -: fixnum-shift-fast? ( node -- ? ) - dup fixnum-shift-fast-pos? - [ drop t ] [ fixnum-shift-fast-neg? ] if ; +: convert-mod-to-and ( #call -- node ) + dup + dup node-in-d second node-literal 1- + [ nip bitand ] curry f splice-quot ; -\ fixnum-shift { +\ mod [ { - [ dup fixnum-shift-fast? ] - [ [ fixnum-shift-fast ] f splice-quot ] + { + [ dup convert-mod-to-and? ] + [ convert-mod-to-and ] + } + } define-optimizers +] each-derived-op + +\ rem { + { + [ dup convert-rem-to-and? ] + [ convert-mod-to-and ] + } +} define-optimizers + +: fixnumify-bitand? ( #call -- ? ) + dup node-in-d second node-interval fixnum fits? ; + +: fixnumify-bitand ( #call -- node ) + [ [ >fixnum ] bi@ fixnum-bitand ] f splice-quot ; + +\ bitand { + { + [ dup fixnumify-bitand? ] + [ fixnumify-bitand ] } } define-optimizers diff --git a/core/optimizer/math/partial/partial-tests.factor b/core/optimizer/math/partial/partial-tests.factor new file mode 100644 index 0000000000..671933b682 --- /dev/null +++ b/core/optimizer/math/partial/partial-tests.factor @@ -0,0 +1,13 @@ +IN: optimizer.math.partial.tests +USING: optimizer.math.partial tools.test math kernel +sequences ; + +[ t ] [ \ + integer fixnum math-both-known? ] unit-test +[ t ] [ \ + bignum fixnum math-both-known? ] unit-test +[ t ] [ \ + integer bignum math-both-known? ] unit-test +[ t ] [ \ + float fixnum math-both-known? ] unit-test +[ f ] [ \ + real fixnum math-both-known? ] unit-test +[ f ] [ \ + object number math-both-known? ] unit-test +[ f ] [ \ number= fixnum object math-both-known? ] unit-test +[ t ] [ \ number= integer fixnum math-both-known? ] unit-test +[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test diff --git a/core/optimizer/math/partial/partial.factor b/core/optimizer/math/partial/partial.factor new file mode 100644 index 0000000000..8b5e25deb1 --- /dev/null +++ b/core/optimizer/math/partial/partial.factor @@ -0,0 +1,172 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel kernel.private math math.private words +sequences parser namespaces assocs quotations arrays +generic generic.math hashtables effects ; +IN: optimizer.math.partial + +! Partial dispatch. + +! This code will be overhauled and generalized when +! multi-methods go into the core. +PREDICATE: math-partial < word + "derived-from" word-prop >boolean ; + +: fixnum-integer-op ( a b fix-word big-word -- c ) + pick tag 0 eq? [ + drop execute + ] [ + >r drop >r fixnum>bignum r> r> execute + ] if ; inline + +: integer-fixnum-op ( a b fix-word big-word -- c ) + >r pick tag 0 eq? [ + r> drop execute + ] [ + drop fixnum>bignum r> execute + ] if ; inline + +: integer-integer-op ( a b fix-word big-word -- c ) + pick tag 0 eq? [ + integer-fixnum-op + ] [ + >r drop over tag 0 eq? [ + >r fixnum>bignum r> r> execute + ] [ + r> execute + ] if + ] if ; inline + +<< +: integer-op-combinator ( triple -- word ) + [ + [ second word-name % "-" % ] + [ third word-name % "-op" % ] + bi + ] "" make in get lookup ; + +: integer-op-word ( triple fix-word big-word -- word ) + [ + drop + word-name "fast" tail? >r + [ "-" % ] [ word-name % ] interleave + r> [ "-fast" % ] when + ] "" make in get create ; + +: integer-op-quot ( word fix-word big-word -- quot ) + rot integer-op-combinator 1quotation 2curry ; + +: define-integer-op-word ( word fix-word big-word -- ) + [ + [ integer-op-word ] [ integer-op-quot ] 3bi + 2 1 define-declared + ] + [ + [ integer-op-word ] [ 2drop ] 3bi + "derived-from" set-word-prop + ] 3bi ; + +: define-integer-op-words ( words fix-word big-word -- ) + [ define-integer-op-word ] 2curry each ; + +: integer-op-triples ( word -- triples ) + { + { fixnum integer } + { integer fixnum } + { integer integer } + } swap [ prefix ] curry map ; + +: define-integer-ops ( word fix-word big-word -- ) + >r >r integer-op-triples r> r> + [ define-integer-op-words ] + [ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ] + 3bi ; + +: define-math-ops ( op -- ) + { fixnum bignum float } + [ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc + [ nip ] assoc-filter + [ word-def peek ] assoc-map % ; + +SYMBOL: math-ops + +[ + \ + define-math-ops + \ - define-math-ops + \ * define-math-ops + \ shift define-math-ops + \ mod define-math-ops + \ /i define-math-ops + + \ bitand define-math-ops + \ bitor define-math-ops + \ bitxor define-math-ops + + \ < define-math-ops + \ <= define-math-ops + \ > define-math-ops + \ >= define-math-ops + \ number= define-math-ops + + \ + \ fixnum+ \ bignum+ define-integer-ops + \ - \ fixnum- \ bignum- define-integer-ops + \ * \ fixnum* \ bignum* define-integer-ops + \ shift \ fixnum-shift \ bignum-shift define-integer-ops + \ mod \ fixnum-mod \ bignum-mod define-integer-ops + \ /i \ fixnum/i \ bignum/i define-integer-ops + + \ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops + \ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops + \ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops + + \ < \ fixnum< \ bignum< define-integer-ops + \ <= \ fixnum<= \ bignum<= define-integer-ops + \ > \ fixnum> \ bignum> define-integer-ops + \ >= \ fixnum>= \ bignum>= define-integer-ops + \ number= \ eq? \ bignum= define-integer-ops +] { } make >hashtable math-ops set-global + +SYMBOL: fast-math-ops + +[ + { { + fixnum fixnum } fixnum+fast } , + { { - fixnum fixnum } fixnum-fast } , + { { * fixnum fixnum } fixnum*fast } , + { { shift fixnum fixnum } fixnum-shift-fast } , + + \ + \ fixnum+fast \ bignum+ define-integer-ops + \ - \ fixnum-fast \ bignum- define-integer-ops + \ * \ fixnum*fast \ bignum* define-integer-ops + \ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops +] { } make >hashtable fast-math-ops set-global + +>> + +: math-op ( word left right -- word' ? ) + 3array math-ops get at* ; + +: math-method* ( word left right -- quot ) + 3dup math-op + [ >r 3drop r> 1quotation ] [ drop math-method ] if ; + +: math-both-known? ( word left right -- ? ) + 3dup math-op + [ 2drop 2drop t ] + [ drop math-class-max swap specific-method >boolean ] if ; + +: (derived-ops) ( word assoc -- words ) + swap [ rot first eq? nip ] curry assoc-filter values ; + +: derived-ops ( word -- words ) + [ 1array ] + [ math-ops get (derived-ops) ] + bi append ; + +: fast-derived-ops ( word -- words ) + fast-math-ops get (derived-ops) ; + +: all-derived-ops ( word -- words ) + [ derived-ops ] [ fast-derived-ops ] bi append ; + +: each-derived-op ( word quot -- ) + >r derived-ops r> each ; inline diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 1a48e353a2..6f4ae2c1d5 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -1,9 +1,9 @@ USING: arrays compiler.units generic hashtables inference kernel -kernel.private math optimizer prettyprint sequences sbufs -strings tools.test vectors words sequences.private quotations -optimizer.backend classes classes.algebra inference.dataflow -classes.tuple.private continuations growable optimizer.inlining -namespaces hints ; +kernel.private math optimizer generator prettyprint sequences +sbufs strings tools.test vectors words sequences.private +quotations optimizer.backend classes classes.algebra +inference.dataflow classes.tuple.private continuations growable +optimizer.inlining namespaces hints ; IN: optimizer.tests [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ @@ -14,40 +14,6 @@ IN: optimizer.tests H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* ] unit-test -! Test method inlining -[ f ] [ fixnum { } min-class ] unit-test - -[ string ] [ - \ string - [ integer string array reversed sbuf - slice vector quotation ] - sort-classes min-class -] unit-test - -[ fixnum ] [ - \ fixnum - [ fixnum integer object ] - sort-classes min-class -] unit-test - -[ integer ] [ - \ fixnum - [ integer float object ] - sort-classes min-class -] unit-test - -[ object ] [ - \ word - [ integer float object ] - sort-classes min-class -] unit-test - -[ reversed ] [ - \ reversed - [ integer reversed slice ] - sort-classes min-class -] unit-test - GENERIC: xyz ( obj -- obj ) M: array xyz xyz ; @@ -325,7 +291,6 @@ TUPLE: silly-tuple a b ; [ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test -! Make sure we don't lose GENERIC: generic-inline-test ( x -- y ) M: integer generic-inline-test ; @@ -342,6 +307,7 @@ M: integer generic-inline-test ; generic-inline-test generic-inline-test ; +! Inlining all of the above should only take two passes [ { t f } ] [ \ generic-inline-test-1 word-def dataflow [ optimize-1 , optimize-1 , drop ] { } make @@ -374,3 +340,19 @@ HINTS: recursive-inline-hang-3 array ; USE: sequences.private [ ] [ { (3append) } compile ] unit-test + +! Wow +: counter-example ( a b c d -- a' b' c' d' ) + dup 0 > [ 1 - >r rot 2 * r> counter-example ] when ; inline + +: counter-example' ( -- a' b' c' d' ) + 1 2 3.0 3 counter-example ; + +[ 2 4 6.0 0 ] [ counter-example' ] unit-test + +: member-test { + - * / /i } member? ; + +\ member-test must-infer +[ ] [ \ member-test word-dataflow optimize 2drop ] unit-test +[ t ] [ \ + member-test ] unit-test +[ f ] [ \ append member-test ] unit-test diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor index 9e898450cc..23cba3ea4c 100755 --- a/core/optimizer/optimizer.factor +++ b/core/optimizer/optimizer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces optimizer.backend optimizer.def-use optimizer.known-words optimizer.math optimizer.control -optimizer.inlining inference.class ; +optimizer.collect optimizer.inlining inference.class ; IN: optimizer : optimize-1 ( node -- newnode ? ) @@ -10,10 +10,13 @@ IN: optimizer H{ } clone class-substitutions set H{ } clone literal-substitutions set H{ } clone value-substitutions set - dup compute-def-use + + collect-label-infos + compute-def-use kill-values - dup detect-loops - dup infer-classes + detect-loops + infer-classes + optimizer-changed off optimize-nodes optimizer-changed get diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index b33a9e8fc2..c3702e9805 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -12,7 +12,7 @@ IN: optimizer.specializers : make-specializer ( classes -- quot ) dup length [ (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 diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 23363c30ad..b69985fb1d 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -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 } } diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index ab193e1c02..20d51f3461 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -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 diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 7639ebaa69..23c0c0a1a5 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -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 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 diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index c9019b029d..e13a991e2b 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -1,11 +1,10 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors -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 classes.tuple.private classes float-arrays -float-vectors ; +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 math.order +classes.tuple.private classes float-arrays ; IN: prettyprint.backend GENERIC: pprint* ( obj -- ) @@ -140,11 +139,8 @@ M: curry pprint-delims drop \ [ \ ] ; M: compose pprint-delims drop \ [ \ ] ; M: array pprint-delims drop \ { \ } ; M: byte-array pprint-delims drop \ B{ \ } ; -M: byte-vector pprint-delims drop \ BV{ \ } ; M: bit-array pprint-delims drop \ ?{ \ } ; -M: bit-vector pprint-delims drop \ ?V{ \ } ; M: float-array pprint-delims drop \ F{ \ } ; -M: float-vector pprint-delims drop \ FV{ \ } ; M: vector pprint-delims drop \ V{ \ } ; M: hashtable pprint-delims drop \ H{ \ } ; M: tuple pprint-delims drop \ T{ \ } ; @@ -156,9 +152,6 @@ GENERIC: >pprint-sequence ( obj -- seq ) M: object >pprint-sequence ; M: vector >pprint-sequence ; -M: bit-vector >pprint-sequence ; -M: byte-vector >pprint-sequence ; -M: float-vector >pprint-sequence ; M: curry >pprint-sequence ; M: compose >pprint-sequence ; M: hashtable >pprint-sequence >alist ; diff --git a/core/prettyprint/config/config.factor b/core/prettyprint/config/config.factor index 1474f51c53..6a649bc5a6 100644 --- a/core/prettyprint/config/config.factor +++ b/core/prettyprint/config/config.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: prettyprint.config -USING: alien arrays generic assocs io kernel math +USING: arrays generic assocs io kernel math namespaces sequences strings io.styles vectors words continuations ; diff --git a/core/prettyprint/prettyprint-docs.factor b/core/prettyprint/prettyprint-docs.factor index 7cc141be22..2933c8ee6f 100755 --- a/core/prettyprint/prettyprint-docs.factor +++ b/core/prettyprint/prettyprint-docs.factor @@ -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 } "." } ; diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 525749cfae..4974e1df3c 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: prettyprint -USING: alien arrays generic generic.standard assocs io kernel +USING: arrays generic generic.standard assocs io kernel math namespaces sequences strings io.styles io.streams.string vectors words prettyprint.backend prettyprint.sections prettyprint.config sorting splitting math.parser vocabs @@ -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 -- ) diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor index 319e5eab65..5f32539115 100644 --- a/core/prettyprint/sections/sections.factor +++ b/core/prettyprint/sections/sections.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays generic hashtables io kernel math assocs +USING: arrays generic hashtables io kernel math assocs namespaces sequences strings io.styles vectors words prettyprint.config splitting classes continuations io.streams.nested accessors ; @@ -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 ; diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index c0f15a9388..2a0f5d289f 100755 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -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 diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index bb3dc9337e..2a2fcf29cd 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -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" @@ -76,10 +76,7 @@ ARTICLE: "sequences-reshape" "Reshaping sequences" { $subsection reversed } { $subsection } "Transposing a matrix:" -{ $subsection flip } -"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:" -{ $subsection column } -{ $subsection } ; +{ $subsection flip } ; ARTICLE: "sequences-appending" "Appending sequences" { $subsection append } @@ -95,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:" @@ -108,6 +106,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices" { $subsection } { $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:" @@ -130,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:" @@ -156,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." @@ -503,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 " @@ -516,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." } ; @@ -533,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." } ; @@ -565,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 } "." } ; @@ -575,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 } "." } ; @@ -785,23 +784,6 @@ HELP: { subseq } related-words -HELP: column -{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link } "." } ; - -HELP: ( seq n -- column ) -{ $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } } -{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." } -{ $examples - { $example - "USING: arrays prettyprint sequences ;" - "{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 >array ." - "{ 1 4 7 }" - } -} -{ $notes - "In the same sense that " { $link } " is a virtual variant of " { $link reverse } ", " { $link } " is a virtual variant of " { $snippet "swap [ nth ] curry map" } "." -} ; - HELP: repetition { $class-description "A virtual sequence consisting of " { $link repetition-elt } " repeated " { $link repetition-len } " times. Repetitions are created by calling " { $link } "." } ; @@ -854,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." } @@ -874,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." } diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index e8db18b3d0..2479c125a2 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -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 @@ -224,13 +221,6 @@ unit-test [ V{ 1 2 3 } ] [ 3 V{ 1 3 2 } clone [ push-new ] keep ] unit-test -! Columns -{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set - -[ { 1 4 7 } ] [ "seq" get 0 >array ] unit-test -[ ] [ "seq" get 1 [ sq ] change-each ] unit-test -[ { 4 25 64 } ] [ "seq" get 1 >array ] unit-test - ! erg's random tester found this one [ SBUF" 12341234" ] [ 9 dup "1234" swap push-all dup dup swap push-all diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 252df54391..a63e6d2835 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -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 ) [ ] keep like ; +: reverse ( seq -- newseq ) [ ] [ 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,24 +210,14 @@ M: slice length dup slice-to swap slice-from - ; : tail-slice ( seq n -- slice ) (tail) ; +: 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 ; INSTANCE: slice virtual-sequence -! A column of a matrix -TUPLE: column seq col ; - -C: column - -M: column virtual-seq column-seq ; -M: column virtual@ - dup column-col -rot column-seq nth bounds-check ; -M: column length column-seq length ; - -INSTANCE: column virtual-sequence - ! One element repeated many times TUPLE: repetition len elt ; @@ -260,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 ; @@ -279,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> @@ -291,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) ; @@ -335,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) ] [ @@ -344,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 @@ -385,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 @@ -406,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 -- ? ) @@ -426,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 @@ -445,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 [ @@ -484,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 < [ @@ -509,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= [ @@ -531,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 ; @@ -556,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? ; @@ -621,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 @@ -646,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 ; : 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 @@ -674,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 ; : ( seq -- slice ) dup slice? [ { } like ] when 0 over length rot ; @@ -692,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 ; @@ -703,5 +697,5 @@ PRIVATE> : flip ( matrix -- newmatrix ) dup empty? [ dup [ length ] map infimum - [ dup like ] with map + swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as ] unless ; diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index 8b6859260d..55ef3ccddd 100644 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -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 diff --git a/core/sets/sets-tests.factor b/core/sets/sets-tests.factor index 4f8c8cd103..86ee100da5 100644 --- a/core/sets/sets-tests.factor +++ b/core/sets/sets-tests.factor @@ -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 diff --git a/core/sets/sets.factor b/core/sets/sets.factor index 31c39c6105..78a92155fc 100644 --- a/core/sets/sets.factor +++ b/core/sets/sets.factor @@ -22,10 +22,10 @@ IN: sets dup length [ (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 ; diff --git a/core/slots/deprecated/deprecated.factor b/core/slots/deprecated/deprecated.factor index 2ec8f3d0d1..90f468a185 100755 --- a/core/slots/deprecated/deprecated.factor +++ b/core/slots/deprecated/deprecated.factor @@ -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 ; diff --git a/core/sorting/sorting-docs.factor b/core/sorting/sorting-docs.factor index 4fa5c7974d..5827a711c8 100644 --- a/core/sorting/sorting-docs.factor +++ b/core/sorting/sorting-docs.factor @@ -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:" @@ -61,3 +62,5 @@ HELP: binsearch* { $description "Variant of " { $link binsearch } " which outputs the found element rather than its index in the sequence." $nl "Outputs " { $link f } " if the sequence is empty. If the sequence has at least one element, this word always outputs a sequence element." } ; + +{ <=> compare natural-sort sort-keys sort-values } related-words diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor index 732aeb045d..a56c41b620 100755 --- a/core/sorting/sorting-tests.factor +++ b/core/sorting/sorting-tests.factor @@ -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 @@ -19,10 +19,10 @@ unit-test [ 3 ] [ { 1 2 3 4 } midpoint ] unit-test -[ f ] [ 3 { } [ - ] binsearch ] unit-test -[ 0 ] [ 3 { 3 } [ - ] binsearch ] unit-test -[ 1 ] [ 2 { 1 2 3 } [ - ] binsearch ] unit-test -[ 3 ] [ 4 { 1 2 3 4 5 6 } [ - ] binsearch ] unit-test -[ 1 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ - ] binsearch ] unit-test -[ 3 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ - ] binsearch ] unit-test -[ 10 ] [ 10 20 >vector [ - ] binsearch ] unit-test +[ f ] [ 3 { } [ <=> ] binsearch ] unit-test +[ 0 ] [ 3 { 3 } [ <=> ] binsearch ] unit-test +[ 1 ] [ 2 { 1 2 3 } [ <=> ] binsearch ] unit-test +[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] binsearch ] unit-test +[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test +[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test +[ 10 ] [ 10 20 >vector [ <=> ] binsearch ] unit-test diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index 5f81b17187..dac1c08e46 100755 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math sequences vectors -sequences sequences.private growable ; +USING: arrays kernel math sequences vectors math.order +sequences sequences.private growable math.order ; IN: sorting DEFER: sort @@ -17,7 +17,7 @@ DEFER: sort dup slice-from 1+ swap set-slice-from ; inline : smallest ( iter1 iter2 quot -- elt ) - >r over this over this r> call 0 < + >r over this over this r> call +lt+ eq? -rot ? [ this ] keep next ; inline : (merge) ( iter1 iter2 quot accum -- ) @@ -58,13 +58,13 @@ PRIVATE> [ midpoint@ ] keep nth-unsafe ; inline : partition ( seq n -- slice ) - 1 < swap halves ? ; inline + +gt+ eq? not swap halves ? ; inline : (binsearch) ( elt quot seq -- i ) dup length 1 <= [ slice-from 2nip ] [ - [ midpoint swap call ] 3keep roll dup zero? + [ midpoint swap call ] 3keep roll dup +eq+ eq? [ drop dup slice-from swap midpoint@ + 2nip ] [ partition (binsearch) ] if ] if ; inline diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 5703b631f4..5ef2d46790 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -19,7 +19,7 @@ uses definitions ; : (xref-source) ( source-file -- pathname uses ) dup source-file-path - swap source-file-uses [ crossref? ] subset ; + swap source-file-uses [ crossref? ] filter ; : xref-source ( source-file -- ) (xref-source) crossref get add-vertex ; diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index f840ca15ad..eb10b9fe4a 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -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 diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 961c8cdf6e..44e1d8859f 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -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 diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index c2eb411f0a..b72ed9a2cb 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -150,18 +150,6 @@ ARTICLE: "syntax-byte-arrays" "Byte array syntax" { $subsection POSTPONE: B{ } "Byte arrays are documented in " { $link "byte-arrays" } "." ; -ARTICLE: "syntax-bit-vectors" "Bit vector syntax" -{ $subsection POSTPONE: ?V{ } -"Bit vectors are documented in " { $link "bit-vectors" } "." ; - -ARTICLE: "syntax-float-vectors" "Float vector syntax" -{ $subsection POSTPONE: FV{ } -"Float vectors are documented in " { $link "float-vectors" } "." ; - -ARTICLE: "syntax-byte-vectors" "Byte vector syntax" -{ $subsection POSTPONE: BV{ } -"Byte vectors are documented in " { $link "byte-vectors" } "." ; - ARTICLE: "syntax-pathnames" "Pathname syntax" { $subsection POSTPONE: P" } "Pathnames are documented in " { $link "pathnames" } "." ; @@ -182,9 +170,6 @@ $nl { $subsection "syntax-float-arrays" } { $subsection "syntax-vectors" } { $subsection "syntax-sbufs" } -{ $subsection "syntax-bit-vectors" } -{ $subsection "syntax-byte-vectors" } -{ $subsection "syntax-float-vectors" } { $subsection "syntax-hashtables" } { $subsection "syntax-tuples" } { $subsection "syntax-pathnames" } ; @@ -205,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" } @@ -291,30 +276,12 @@ HELP: B{ { $description "Marks the beginning of a literal byte array. Literal byte arrays are terminated by " { $link POSTPONE: } } "." } { $examples { $code "B{ 1 2 3 }" } } ; -HELP: BV{ -{ $syntax "BV{ elements... }" } -{ $values { "elements" "a list of bytes" } } -{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } -{ $examples { $code "BV{ 1 2 3 12 }" } } ; - HELP: ?{ { $syntax "?{ elements... }" } { $values { "elements" "a list of booleans" } } { $description "Marks the beginning of a literal bit array. Literal bit arrays are terminated by " { $link POSTPONE: } } "." } { $examples { $code "?{ t f t }" } } ; -HELP: ?V{ -{ $syntax "?V{ elements... }" } -{ $values { "elements" "a list of booleans" } } -{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." } -{ $examples { $code "?V{ t f t }" } } ; - -HELP: FV{ -{ $syntax "FV{ elements... }" } -{ $values { "elements" "a list of real numbers" } } -{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." } -{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ; - HELP: F{ { $syntax "F{ elements... }" } { $values { "elements" "a list of real numbers" } } @@ -371,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 @@ -505,6 +472,7 @@ HELP: HOOK: { $examples { $example "USING: io namespaces ;" + "IN: scratchpad" "SYMBOL: transport" "TUPLE: land-transport ;" "TUPLE: air-transport ;" diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index eaf5ffea05..b2f063ddf1 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays bit-arrays bit-vectors byte-arrays -byte-vectors definitions generic hashtables kernel math +USING: alien arrays bit-arrays byte-arrays +definitions generic hashtables kernel math namespaces parser sequences strings sbufs vectors words quotations io assocs splitting classes.tuple generic.standard -generic.math classes io.files vocabs float-arrays float-vectors +generic.math classes io.files vocabs float-arrays classes.union classes.mixin classes.predicate classes.singleton compiler.units combinators debugger ; IN: bootstrap.syntax @@ -79,11 +79,8 @@ IN: bootstrap.syntax "{" [ \ } [ >array ] parse-literal ] define-syntax "V{" [ \ } [ >vector ] parse-literal ] define-syntax "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax - "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax "?{" [ \ } [ >bit-array ] parse-literal ] define-syntax - "?V{" [ \ } [ >bit-vector ] parse-literal ] define-syntax "F{" [ \ } [ >float-array ] parse-literal ] define-syntax - "FV{" [ \ } [ >float-vector ] parse-literal ] define-syntax "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax "T{" [ \ } [ >tuple ] parse-literal ] define-syntax "W{" [ \ } [ first ] parse-literal ] define-syntax @@ -192,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 diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 2f9c3a73de..8b89cd5732 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -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 diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 24a00189e4..edd82b2596 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -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 ; diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index f259378f7e..14e6197683 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -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: +HELP: ( 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 } } } diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 694e54cf96..2a164ab11d 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -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 diff --git a/core/words/words.factor b/core/words/words.factor index 3466544eef..138b1ef928 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -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 ; r 256 random-bits >hex r> + >r 32 random-bits >hex r> 2dup key? [ nip generate-key ] [ drop ] if ; : set-at-unique ( value assoc -- key ) diff --git a/extra/benchmark/binary-trees/binary-trees.factor b/extra/benchmark/binary-trees/binary-trees.factor new file mode 100644 index 0000000000..6e63877989 --- /dev/null +++ b/extra/benchmark/binary-trees/binary-trees.factor @@ -0,0 +1,55 @@ +USING: kernel math accessors prettyprint io locals sequences +math.ranges math.order ; +IN: benchmark.binary-trees + +TUPLE: tree-node item left right ; + +C: tree-node + +: bottom-up-tree ( item depth -- tree ) + dup 0 > [ + 1 - + [ drop ] + [ >r 2 * 1 - r> bottom-up-tree ] + [ >r 2 * r> bottom-up-tree ] 2tri + ] [ + drop f f + ] if ; + +GENERIC: item-check ( node -- n ) + +M: tree-node item-check + [ item>> ] [ left>> ] [ right>> ] tri [ item-check ] bi@ - + ; + +M: f item-check drop 0 ; + +: min-depth 4 ; inline + +: stretch-tree ( max-depth -- ) + 1 + 0 over bottom-up-tree item-check + [ "stretch tree of depth " write pprint ] + [ "\t check: " write . ] bi* ; + +:: long-lived-tree ( max-depth -- ) + 0 max-depth bottom-up-tree + + min-depth max-depth 2 [| depth | + max-depth depth - min-depth + 2^ [ + [1,b] 0 [ + dup neg + [ depth bottom-up-tree item-check + ] bi@ + ] reduce + ] + [ 2 * ] bi + pprint "\t trees of depth " write depth pprint + "\t check: " write . + ] each + + "long lived tree of depth " write max-depth pprint + "\t check: " write item-check . ; + +: binary-trees ( n -- ) + min-depth 2 + max [ stretch-tree ] [ long-lived-tree ] bi ; + +: binary-trees-main ( -- ) + 16 binary-trees ; diff --git a/extra/benchmark/dispatch1/dispatch1.factor b/extra/benchmark/dispatch1/dispatch1.factor index 3317348f45..1c8701f73f 100644 --- a/extra/benchmark/dispatch1/dispatch1.factor +++ b/extra/benchmark/dispatch1/dispatch1.factor @@ -65,7 +65,7 @@ TUPLE: x30 ; M: x30 g ; : my-classes ( -- seq ) - "benchmark.dispatch1" words [ tuple-class? ] subset ; + "benchmark.dispatch1" words [ tuple-class? ] filter ; : a-bunch-of-objects ( -- seq ) my-classes [ new ] map ; diff --git a/extra/benchmark/dispatch2/dispatch2.factor b/extra/benchmark/dispatch2/dispatch2.factor index d51a723cbd..53e9c9a14c 100644 --- a/extra/benchmark/dispatch2/dispatch2.factor +++ b/extra/benchmark/dispatch2/dispatch2.factor @@ -1,4 +1,4 @@ -USING: namespaces math sequences splitting kernel ; +USING: namespaces math sequences splitting kernel columns ; IN: benchmark.dispatch2 : sequences diff --git a/extra/benchmark/dispatch3/dispatch3.factor b/extra/benchmark/dispatch3/dispatch3.factor index bb4c5ba904..409d6d4a0f 100644 --- a/extra/benchmark/dispatch3/dispatch3.factor +++ b/extra/benchmark/dispatch3/dispatch3.factor @@ -1,5 +1,5 @@ USING: sequences math mirrors splitting kernel namespaces -assocs alien.syntax ; +assocs alien.syntax columns ; IN: benchmark.dispatch3 GENERIC: g ( obj -- str ) diff --git a/extra/benchmark/dispatch5/dispatch5.factor b/extra/benchmark/dispatch5/dispatch5.factor index a2f096695b..727d288765 100755 --- a/extra/benchmark/dispatch5/dispatch5.factor +++ b/extra/benchmark/dispatch5/dispatch5.factor @@ -65,7 +65,7 @@ TUPLE: x30 ; INSTANCE: x30 g : my-classes ( -- seq ) - "benchmark.dispatch5" words [ tuple-class? ] subset ; + "benchmark.dispatch5" words [ tuple-class? ] filter ; : a-bunch-of-objects ( -- seq ) my-classes [ new ] map ; diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index b890fdc8e8..b9b139d7e3 100755 --- a/extra/benchmark/mandel/mandel.factor +++ b/extra/benchmark/mandel/mandel.factor @@ -1,5 +1,5 @@ IN: benchmark.mandel -USING: arrays io kernel math namespaces sequences +USING: arrays io kernel math math.order namespaces sequences byte-arrays byte-vectors math.functions math.parser io.files colors.hsv io.encodings.binary ; diff --git a/extra/benchmark/recursive/recursive.factor b/extra/benchmark/recursive/recursive.factor index ee66e303ec..f69547df60 100755 --- a/extra/benchmark/recursive/recursive.factor +++ b/extra/benchmark/recursive/recursive.factor @@ -1,38 +1,37 @@ +USING: math kernel hints prettyprint io combinators ; IN: benchmark.recursive -USING: math kernel hints prettyprint io ; : fib ( m -- n ) - dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; + dup 2 < [ drop 1 ] [ [ 1 - fib ] [ 2 - fib ] bi + ] if ; + inline : ack ( m n -- x ) - over zero? [ - nip 1+ - ] [ - dup zero? [ - drop 1- 1 ack - ] [ - dupd 1- ack >r 1- r> ack - ] if - ] if ; + { + { [ over zero? ] [ nip 1+ ] } + { [ dup zero? ] [ drop 1- 1 ack ] } + [ [ drop 1- ] [ 1- ack ] 2bi ack ] + } cond ; inline : tak ( x y z -- t ) - 2over swap < [ - [ rot 1- -rot tak ] 3keep - [ -rot 1- -rot tak ] 3keep - 1- -rot tak - tak - ] [ + 2over <= [ 2nip - ] if ; + ] [ + [ rot 1- -rot tak ] + [ -rot 1- -rot tak ] + [ 1- -rot tak ] + 3tri + tak + ] if ; inline : recursive ( n -- ) - 3 over ack . flush - dup 27.0 + fib . flush - 1- - dup 3 * over 2 * rot tak . flush + [ 3 swap ack . flush ] + [ 27.0 + fib . flush ] + [ 1- [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri 3 fib . flush 3.0 2.0 1.0 tak . flush ; +HINTS: recursive fixnum ; + : recursive-main 11 recursive ; MAIN: recursive-main diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor index 7eddeefc1b..5d36aa25bd 100644 --- a/extra/benchmark/spectral-norm/spectral-norm.factor +++ b/extra/benchmark/spectral-norm/spectral-norm.factor @@ -1,48 +1,44 @@ ! Factor port of ! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all USING: float-arrays kernel math math.functions math.vectors -sequences sequences.private prettyprint words tools.time hints ; +sequences sequences.private prettyprint words +hints locals ; IN: benchmark.spectral-norm -: fast-truncate >fixnum >float ; inline +:: inner-loop ( u n quot -- seq ) + n [| i | + n 0.0 [| j | + u i j quot call + + ] reduce + ] F{ } map-as ; inline : eval-A ( i j -- n ) [ >float ] bi@ - dupd + dup 1+ * 2 /f fast-truncate + 1+ - recip ; inline + [ drop ] [ + [ ] [ 1 + ] bi * 0.5 * ] 2bi + + 1 + recip ; inline : (eval-A-times-u) ( u i j -- x ) - tuck eval-A >r swap nth-unsafe r> * ; inline + tuck [ swap nth-unsafe ] [ eval-A ] 2bi* * ; inline : eval-A-times-u ( n u -- seq ) - over [ - pick 0.0 [ - swap >r >r 2dup r> (eval-A-times-u) r> + - ] reduce nip - ] F{ } map-as 2nip ; inline + [ (eval-A-times-u) ] inner-loop ; inline : (eval-At-times-u) ( u i j -- x ) - tuck swap eval-A >r swap nth-unsafe r> * ; inline + tuck [ swap nth-unsafe ] [ swap eval-A ] 2bi* * ; inline -: eval-At-times-u ( n u -- seq ) - over [ - pick 0.0 [ - swap >r >r 2dup r> (eval-At-times-u) r> + - ] reduce nip - ] F{ } map-as 2nip ; inline +: eval-At-times-u ( u n -- seq ) + [ (eval-At-times-u) ] inner-loop ; inline -: eval-AtA-times-u ( n u -- seq ) - dupd eval-A-times-u eval-At-times-u ; inline +: eval-AtA-times-u ( u n -- seq ) + [ eval-A-times-u ] [ eval-At-times-u ] bi ; inline -: u/v ( n -- u v ) - dup 1.0 dup +:: u/v ( n -- u v ) + n 1.0 dup 10 [ drop - dupd eval-AtA-times-u - 2dup eval-AtA-times-u - swap - ] times - rot drop ; inline + n eval-AtA-times-u + [ n eval-AtA-times-u ] keep + ] times ; inline : spectral-norm ( n -- norm ) u/v [ v. ] keep norm-sq /f sqrt ; @@ -50,6 +46,6 @@ IN: benchmark.spectral-norm HINTS: spectral-norm fixnum ; : spectral-norm-main ( -- ) - 2000 spectral-norm . ; + 5500 spectral-norm . ; MAIN: spectral-norm-main diff --git a/core/bit-vectors/bit-vectors-docs.factor b/extra/bit-vectors/bit-vectors-docs.factor similarity index 72% rename from core/bit-vectors/bit-vectors-docs.factor rename to extra/bit-vectors/bit-vectors-docs.factor index f2f5c4da2c..41f32b4cdb 100755 --- a/core/bit-vectors/bit-vectors-docs.factor +++ b/extra/bit-vectors/bit-vectors-docs.factor @@ -3,7 +3,7 @@ bit-vectors.private combinators ; IN: bit-vectors ARTICLE: "bit-vectors" "Bit vectors" -"A bit vector is a resizable mutable sequence of bits. The literal syntax is covered in " { $link "syntax-bit-vectors" } ". Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary." +"A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary." $nl "Bit vectors form a class:" { $subsection bit-vector } @@ -11,13 +11,15 @@ $nl "Creating bit vectors:" { $subsection >bit-vector } { $subsection } +"Literal syntax:" +{ $subsection POSTPONE: ?V{ } "If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:" { $code "?V{ } clone" } ; ABOUT: "bit-vectors" HELP: bit-vector -{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ; +{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ; HELP: { $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } } @@ -31,3 +33,10 @@ HELP: bit-array>vector { $values { "bit-array" "an array" } { "length" "a non-negative integer" } { "bit-vector" bit-vector } } { $description "Creates a new bit vector using the array for underlying storage with the specified initial length." } { $warning "This word is in the " { $vocab-link "bit-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >bit-vector } " instead." } ; + +HELP: ?V{ +{ $syntax "?V{ elements... }" } +{ $values { "elements" "a list of booleans" } } +{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." } +{ $examples { $code "?V{ t f t }" } } ; + diff --git a/core/bit-vectors/bit-vectors-tests.factor b/extra/bit-vectors/bit-vectors-tests.factor similarity index 100% rename from core/bit-vectors/bit-vectors-tests.factor rename to extra/bit-vectors/bit-vectors-tests.factor diff --git a/core/bit-vectors/bit-vectors.factor b/extra/bit-vectors/bit-vectors.factor similarity index 55% rename from core/bit-vectors/bit-vectors.factor rename to extra/bit-vectors/bit-vectors.factor index db941ac6f7..c14b0a5476 100755 --- a/core/bit-vectors/bit-vectors.factor +++ b/extra/bit-vectors/bit-vectors.factor @@ -1,9 +1,20 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences -sequences.private growable bit-arrays ; +sequences.private growable bit-arrays prettyprint.backend +parser accessors ; IN: bit-vectors +TUPLE: bit-vector underlying fill ; + +M: bit-vector underlying underlying>> { bit-array } declare ; + +M: bit-vector set-underlying (>>underlying) ; + +M: bit-vector length fill>> { array-capacity } declare ; + +M: bit-vector set-fill (>>fill) ; + vector ( bit-array length -- bit-vector ) @@ -14,7 +25,8 @@ PRIVATE> : ( n -- bit-vector ) 0 bit-array>vector ; inline -: >bit-vector ( seq -- bit-vector ) ?V{ } clone-like ; +: >bit-vector ( seq -- bit-vector ) + T{ bit-vector f ?{ } 0 } clone-like ; M: bit-vector like drop dup bit-vector? [ @@ -31,3 +43,9 @@ M: bit-vector equal? M: bit-array new-resizable drop ; INSTANCE: bit-vector growable + +: ?V{ \ } [ >bit-vector ] parse-literal ; parsing + +M: bit-vector >pprint-sequence ; + +M: bit-vector pprint-delims drop \ ?V{ \ } ; diff --git a/core/bit-vectors/summary.txt b/extra/bit-vectors/summary.txt similarity index 100% rename from core/bit-vectors/summary.txt rename to extra/bit-vectors/summary.txt diff --git a/core/bit-vectors/tags.txt b/extra/bit-vectors/tags.txt similarity index 100% rename from core/bit-vectors/tags.txt rename to extra/bit-vectors/tags.txt diff --git a/extra/bitfields/bitfields.factor b/extra/bitfields/bitfields.factor index fca0568adf..7fcec00e98 100644 --- a/extra/bitfields/bitfields.factor +++ b/extra/bitfields/bitfields.factor @@ -93,7 +93,7 @@ M: check< summary drop "Number exceeds upper bound" ; >r keys r> define-slots ; : filter-pad ( slots -- slots ) - [ drop padding-name? not ] assoc-subset ; + [ drop padding-name? not ] assoc-filter ; : define-bitfield ( classname slots -- ) [ diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index 4ea20629c1..40ce7adb35 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -3,6 +3,7 @@ USING: kernel namespaces math math.constants math.functions + math.order math.vectors math.trig combinators arrays sequences random vars @@ -116,7 +117,7 @@ over boid-vel -rot relative-position angle-between ; <--&& ; : cohesion-neighborhood ( self -- boids ) - boids> [ within-cohesion-neighborhood? ] with subset ; + boids> [ within-cohesion-neighborhood? ] with filter ; : cohesion-force ( self -- force ) dup cohesion-neighborhood @@ -136,7 +137,7 @@ over boid-vel -rot relative-position angle-between ; <--&& ; : separation-neighborhood ( self -- boids ) - boids> [ within-separation-neighborhood? ] with subset ; + boids> [ within-separation-neighborhood? ] with filter ; : separation-force ( self -- force ) dup separation-neighborhood @@ -156,7 +157,7 @@ over boid-vel -rot relative-position angle-between ; <--&& ; : alignment-neighborhood ( self -- boids ) -boids> [ within-alignment-neighborhood? ] with subset ; +boids> [ within-alignment-neighborhood? ] with filter ; : alignment-force ( self -- force ) alignment-neighborhood diff --git a/extra/bootstrap/help/help.factor b/extra/bootstrap/help/help.factor index 4326fcf61b..9dd4fd04b2 100755 --- a/extra/bootstrap/help/help.factor +++ b/extra/bootstrap/help/help.factor @@ -11,7 +11,7 @@ IN: bootstrap.help [ drop ] load-vocab-hook [ vocabs - [ vocab-docs-loaded? not ] subset + [ vocab-docs-loaded? not ] filter [ load-docs ] each ] with-variable ; diff --git a/extra/bubble-chamber/particle/muon/colors/colors.factor b/extra/bubble-chamber/particle/muon/colors/colors.factor index ab72f65b4b..e68fff5efd 100644 --- a/extra/bubble-chamber/particle/muon/colors/colors.factor +++ b/extra/bubble-chamber/particle/muon/colors/colors.factor @@ -1,5 +1,5 @@ -USING: kernel sequences math math.constants accessors +USING: kernel sequences math math.constants math.order accessors processing processing.color ; diff --git a/extra/builder/benchmark/benchmark.factor b/extra/builder/benchmark/benchmark.factor index 9e5e932831..afe277d30b 100644 --- a/extra/builder/benchmark/benchmark.factor +++ b/extra/builder/benchmark/benchmark.factor @@ -5,9 +5,9 @@ USING: kernel continuations arrays assocs sequences sorting math IN: builder.benchmark ! : passing-benchmarks ( table -- table ) -! [ second first2 number? swap number? and ] subset ; +! [ second first2 number? swap number? and ] filter ; -: passing-benchmarks ( table -- table ) [ second number? ] subset ; +: passing-benchmarks ( table -- table ) [ second number? ] filter ; ! : simplify-table ( table -- table ) [ first2 second 2array ] map ; diff --git a/extra/builder/release/branch/branch.factor b/extra/builder/release/branch/branch.factor index 6218a2ea90..6b1266bb45 100644 --- a/extra/builder/release/branch/branch.factor +++ b/extra/builder/release/branch/branch.factor @@ -21,7 +21,7 @@ IN: builder.release.branch { "scp" my-boot-image-name - "factorcode.org:/var/www/factorcode.org/newsite/images/clean" + { "factorcode.org:/var/www/factorcode.org/newsite/images/clean/" platform } } to-strings try-process ; diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index 43b9edcd00..d546f9ea41 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -4,7 +4,7 @@ opengl.glu shuffle http.client vectors namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting combinators tools.time system combinators.lib float-arrays continuations opengl.demo-support multiline ui.gestures bunny.fixed-pipeline -bunny.cel-shaded bunny.outlined bunny.model ; +bunny.cel-shaded bunny.outlined bunny.model accessors ; IN: bunny TUPLE: bunny-gadget model geom draw-seq draw-n ; @@ -13,38 +13,33 @@ TUPLE: bunny-gadget model geom draw-seq draw-n ; 0.0 0.0 0.375 maybe-download read-model { set-delegate - set-bunny-gadget-model + (>>model) } bunny-gadget construct ; : bunny-gadget-draw ( gadget -- draw ) - { bunny-gadget-draw-n bunny-gadget-draw-seq } + { draw-n>> draw-seq>> } get-slots nth ; : bunny-gadget-next-draw ( gadget -- ) - dup { bunny-gadget-draw-seq bunny-gadget-draw-n } + dup { draw-seq>> draw-n>> } get-slots 1+ swap length mod - swap [ set-bunny-gadget-draw-n ] keep relayout-1 ; + >>draw-n relayout-1 ; M: bunny-gadget graft* ( gadget -- ) GL_DEPTH_TEST glEnable - dup bunny-gadget-model - over { - [ ] - [ ] - [ ] - } map-call-with [ ] subset - 0 - roll { - set-bunny-gadget-geom - set-bunny-gadget-draw-seq - set-bunny-gadget-draw-n - } set-slots ; + dup model>> >>geom + dup + [ ] + [ ] + [ ] tri 3array + [ ] filter >>draw-seq + 0 >>draw-n + drop ; M: bunny-gadget ungraft* ( gadget -- ) - { bunny-gadget-geom bunny-gadget-draw-seq } get-slots - [ [ dispose ] when* ] each - [ dispose ] when* ; + [ geom>> [ dispose ] when* ] + [ draw-seq>> [ [ dispose ] when* ] each ] bi ; M: bunny-gadget draw-gadget* ( gadget -- ) 0.15 0.15 0.15 1.0 glClearColor @@ -52,7 +47,7 @@ M: bunny-gadget draw-gadget* ( gadget -- ) dup demo-gadget-set-matrices GL_MODELVIEW glMatrixMode 0.02 -0.105 0.0 glTranslatef - { bunny-gadget-geom bunny-gadget-draw } get-slots + { geom>> bunny-gadget-draw } get-slots draw-bunny ; M: bunny-gadget pref-dim* ( gadget -- dim ) diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor index d4f0b7612d..08bea0515b 100644 --- a/extra/bunny/cel-shaded/cel-shaded.factor +++ b/extra/bunny/cel-shaded/cel-shaded.factor @@ -1,5 +1,5 @@ USING: arrays bunny.model continuations kernel multiline opengl opengl.shaders - opengl.capabilities opengl.gl sequences sequences.lib ; + opengl.capabilities opengl.gl sequences sequences.lib accessors ; IN: bunny.cel-shaded STRING: vertex-shader-source @@ -68,11 +68,12 @@ TUPLE: bunny-cel-shaded program ; : ( gadget -- draw ) drop cel-shading-supported? [ + bunny-cel-shaded new vertex-shader-source check-gl-shader cel-shaded-fragment-shader-lib-source check-gl-shader cel-shaded-fragment-shader-main-source check-gl-shader 3array check-gl-program - { set-bunny-cel-shaded-program } bunny-cel-shaded construct + >>program ] [ f ] if ; : (draw-cel-shaded-bunny) ( geom program -- ) @@ -85,8 +86,8 @@ TUPLE: bunny-cel-shaded program ; } [ bunny-geom ] with-gl-program ; M: bunny-cel-shaded draw-bunny - bunny-cel-shaded-program (draw-cel-shaded-bunny) ; + program>> (draw-cel-shaded-bunny) ; M: bunny-cel-shaded dispose - bunny-cel-shaded-program delete-gl-program ; + program>> delete-gl-program ; diff --git a/extra/bunny/fixed-pipeline/fixed-pipeline.factor b/extra/bunny/fixed-pipeline/fixed-pipeline.factor index f3fb68e515..bf0fc45f0f 100644 --- a/extra/bunny/fixed-pipeline/fixed-pipeline.factor +++ b/extra/bunny/fixed-pipeline/fixed-pipeline.factor @@ -6,7 +6,7 @@ TUPLE: bunny-fixed-pipeline ; : ( gadget -- draw ) drop - { } bunny-fixed-pipeline construct ; + bunny-fixed-pipeline new ; M: bunny-fixed-pipeline draw-bunny drop diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 897a30c417..239603755d 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -2,17 +2,17 @@ USING: alien alien.c-types arrays sequences math math.vectors math.matrices math.parser io io.files kernel opengl opengl.gl opengl.glu io.encodings.ascii opengl.capabilities shuffle http.client vectors splitting tools.time system combinators -float-arrays continuations namespaces sequences.lib ; +float-arrays continuations namespaces sequences.lib accessors ; IN: bunny.model : numbers ( str -- seq ) - " " split [ string>number ] map [ ] subset ; + " " split [ string>number ] map [ ] filter ; : (parse-model) ( vs is -- vs is ) readln [ numbers { { [ dup length 5 = ] [ 3 head pick push ] } - { [ dup first 3 = ] [ 1 tail over push ] } + { [ dup first 3 = ] [ rest over push ] } [ drop ] } cond (parse-model) ] when* ; @@ -85,24 +85,24 @@ M: bunny-dlist bunny-geom bunny-dlist-list glCallList ; M: bunny-buffers bunny-geom - dup { - bunny-buffers-array - bunny-buffers-element-array - } get-slots [ + dup { array>> element-array>> } get-slots [ { GL_VERTEX_ARRAY GL_NORMAL_ARRAY } [ GL_DOUBLE 0 0 buffer-offset glNormalPointer - dup bunny-buffers-nv "double" heap-size * buffer-offset - 3 GL_DOUBLE 0 roll glVertexPointer - bunny-buffers-ni - GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements + [ + nv>> "double" heap-size * buffer-offset + 3 GL_DOUBLE 0 roll glVertexPointer + ] [ + ni>> + GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements + ] bi ] all-enabled-client-state ] with-array-element-buffers ; M: bunny-dlist dispose - bunny-dlist-list delete-dlist ; + list>> delete-dlist ; M: bunny-buffers dispose - { bunny-buffers-array bunny-buffers-element-array } get-slots + { array>> element-array>> } get-slots delete-gl-buffer delete-gl-buffer ; : ( model -- geom ) diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 6a2f54cceb..fef57d95d2 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -1,6 +1,7 @@ USING: arrays bunny.model bunny.cel-shaded continuations kernel math multiline opengl opengl.shaders opengl.framebuffers -opengl.gl opengl.capabilities sequences ui.gadgets combinators ; +opengl.gl opengl.capabilities sequences ui.gadgets combinators +accessors ; IN: bunny.outlined STRING: outlined-pass1-fragment-shader-main-source @@ -139,9 +140,9 @@ TUPLE: bunny-outlined : ( gadget -- draw ) outlining-supported? [ pass1-program pass2-program { - set-bunny-outlined-gadget - set-bunny-outlined-pass1-program - set-bunny-outlined-pass2-program + (>>gadget) + (>>pass1-program) + (>>pass2-program) } bunny-outlined construct ] [ drop f ] if ; @@ -169,35 +170,33 @@ TUPLE: bunny-outlined ] with-framebuffer ; : dispose-framebuffer ( draw -- ) - dup bunny-outlined-framebuffer-dim [ + dup framebuffer-dim>> [ { - [ bunny-outlined-framebuffer [ delete-framebuffer ] when* ] - [ bunny-outlined-color-texture [ delete-texture ] when* ] - [ bunny-outlined-normal-texture [ delete-texture ] when* ] - [ bunny-outlined-depth-texture [ delete-texture ] when* ] - [ f swap set-bunny-outlined-framebuffer-dim ] + [ framebuffer>> [ delete-framebuffer ] when* ] + [ color-texture>> [ delete-texture ] when* ] + [ normal-texture>> [ delete-texture ] when* ] + [ depth-texture>> [ delete-texture ] when* ] + [ f >>framebuffer-dim drop ] } cleave ] [ drop ] if ; : remake-framebuffer-if-needed ( draw -- ) - dup bunny-outlined-gadget rect-dim - over bunny-outlined-framebuffer-dim + dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi over = - [ 2drop ] - [ - swap dup dispose-framebuffer >r - dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) - swap dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) - swap dup GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture) - swap >r - [ (make-framebuffer) ] 3keep - r> r> { - set-bunny-outlined-framebuffer - set-bunny-outlined-color-texture - set-bunny-outlined-normal-texture - set-bunny-outlined-depth-texture - set-bunny-outlined-framebuffer-dim - } set-slots + [ 2drop ] [ + [ dup dispose-framebuffer dup ] dip { + [ + GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) + [ >>color-texture drop ] keep + ] [ + GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) + [ >>normal-texture drop ] keep + ] [ + GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture) + [ >>depth-texture drop ] keep + ] + } 2cleave + (make-framebuffer) >>framebuffer drop ] if ; : clear-framebuffer ( -- ) @@ -209,31 +208,34 @@ TUPLE: bunny-outlined GL_COLOR_BUFFER_BIT glClear ; : (pass1) ( geom draw -- ) - dup bunny-outlined-framebuffer [ + dup framebuffer>> [ clear-framebuffer { GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT1_EXT } set-draw-buffers - bunny-outlined-pass1-program (draw-cel-shaded-bunny) + pass1-program>> (draw-cel-shaded-bunny) ] with-framebuffer ; : (pass2) ( draw -- ) - init-matrices - dup bunny-outlined-color-texture GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit - dup bunny-outlined-normal-texture GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit - dup bunny-outlined-depth-texture GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit - bunny-outlined-pass2-program { - { "colormap" [ 0 glUniform1i ] } - { "normalmap" [ 1 glUniform1i ] } - { "depthmap" [ 2 glUniform1i ] } - { "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] } - } [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] with-gl-program ; + init-matrices { + [ color-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ] + [ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ] + [ depth-texture>> GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ] + [ + pass2-program>> { + { "colormap" [ 0 glUniform1i ] } + { "normalmap" [ 1 glUniform1i ] } + { "depthmap" [ 2 glUniform1i ] } + { "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] } + } [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] + with-gl-program + ] + } cleave ; M: bunny-outlined draw-bunny - dup remake-framebuffer-if-needed - [ (pass1) ] keep (pass2) ; + [ remake-framebuffer-if-needed ] + [ (pass1) ] + [ (pass2) ] tri ; M: bunny-outlined dispose - { - [ bunny-outlined-pass1-program [ delete-gl-program ] when* ] - [ bunny-outlined-pass2-program [ delete-gl-program ] when* ] - [ dispose-framebuffer ] - } cleave ; + [ pass1-program>> [ delete-gl-program ] when* ] + [ pass2-program>> [ delete-gl-program ] when* ] + [ dispose-framebuffer ] tri ; diff --git a/core/byte-vectors/byte-vectors-docs.factor b/extra/byte-vectors/byte-vectors-docs.factor similarity index 76% rename from core/byte-vectors/byte-vectors-docs.factor rename to extra/byte-vectors/byte-vectors-docs.factor index 0f1054ee5e..139cbab822 100755 --- a/core/byte-vectors/byte-vectors-docs.factor +++ b/extra/byte-vectors/byte-vectors-docs.factor @@ -3,7 +3,7 @@ byte-vectors.private combinators ; IN: byte-vectors ARTICLE: "byte-vectors" "Byte vectors" -"A byte vector is a resizable mutable sequence of unsigned bytes. The literal syntax is covered in " { $link "syntax-byte-vectors" } ". Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary." +"A byte vector is a resizable mutable sequence of unsigned bytes. Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary." $nl "Byte vectors form a class:" { $subsection byte-vector } @@ -11,13 +11,15 @@ $nl "Creating byte vectors:" { $subsection >byte-vector } { $subsection } +"Literal syntax:" +{ $subsection POSTPONE: BV{ } "If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:" { $code "BV{ } clone" } ; ABOUT: "byte-vectors" HELP: byte-vector -{ $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ; +{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ; HELP: { $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } } @@ -32,3 +34,9 @@ HELP: byte-array>vector { $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } } { $description "Creates a new byte vector using the array for underlying storage with the specified initial length." } { $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ; + +HELP: BV{ +{ $syntax "BV{ elements... }" } +{ $values { "elements" "a list of bytes" } } +{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } +{ $examples { $code "BV{ 1 2 3 12 }" } } ; diff --git a/core/byte-vectors/byte-vectors-tests.factor b/extra/byte-vectors/byte-vectors-tests.factor similarity index 100% rename from core/byte-vectors/byte-vectors-tests.factor rename to extra/byte-vectors/byte-vectors-tests.factor diff --git a/core/byte-vectors/byte-vectors.factor b/extra/byte-vectors/byte-vectors.factor similarity index 55% rename from core/byte-vectors/byte-vectors.factor rename to extra/byte-vectors/byte-vectors.factor index 206a23f43b..a8351dc781 100755 --- a/core/byte-vectors/byte-vectors.factor +++ b/extra/byte-vectors/byte-vectors.factor @@ -1,9 +1,20 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences -sequences.private growable byte-arrays ; +sequences.private growable byte-arrays prettyprint.backend +parser accessors ; IN: byte-vectors +TUPLE: byte-vector underlying fill ; + +M: byte-vector underlying underlying>> { byte-array } declare ; + +M: byte-vector set-underlying (>>underlying) ; + +M: byte-vector length fill>> { array-capacity } declare ; + +M: byte-vector set-fill (>>fill) ; + vector ( byte-array length -- byte-vector ) @@ -14,7 +25,8 @@ PRIVATE> : ( n -- byte-vector ) 0 byte-array>vector ; inline -: >byte-vector ( seq -- byte-vector ) BV{ } clone-like ; +: >byte-vector ( seq -- byte-vector ) + T{ byte-vector f B{ } 0 } clone-like ; M: byte-vector like drop dup byte-vector? [ @@ -31,3 +43,9 @@ M: byte-vector equal? M: byte-array new-resizable drop ; INSTANCE: byte-vector growable + +: BV{ \ } [ >byte-vector ] parse-literal ; parsing + +M: byte-vector >pprint-sequence ; + +M: byte-vector pprint-delims drop \ BV{ \ } ; diff --git a/core/byte-vectors/summary.txt b/extra/byte-vectors/summary.txt similarity index 100% rename from core/byte-vectors/summary.txt rename to extra/byte-vectors/summary.txt diff --git a/core/byte-vectors/tags.txt b/extra/byte-vectors/tags.txt similarity index 100% rename from core/byte-vectors/tags.txt rename to extra/byte-vectors/tags.txt diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index e49d3ad894..7d9716ae1a 100755 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -1,7 +1,11 @@ USING: arrays calendar kernel math sequences tools.test -continuations system ; +continuations system math.order threads ; IN: calendar.tests +\ time+ must-infer +\ time* must-infer +\ time- must-infer + [ f ] [ 2004 12 32 0 0 0 instant valid-timestamp? ] unit-test [ f ] [ 2004 2 30 0 0 0 instant valid-timestamp? ] unit-test [ f ] [ 2003 2 29 0 0 0 instant valid-timestamp? ] unit-test @@ -127,16 +131,16 @@ IN: calendar.tests [ t ] [ 2004 1 1 23 0 0 9+1/2 hours >gmt 2004 1 1 13 30 0 instant = ] unit-test -[ 0 ] [ 2004 1 1 13 30 0 instant +[ +eq+ ] [ 2004 1 1 13 30 0 instant 2004 1 1 12 30 0 -1 hours <=> ] unit-test -[ 1 ] [ 2004 1 1 13 30 0 instant +[ +gt+ ] [ 2004 1 1 13 30 0 instant 2004 1 1 12 30 0 instant <=> ] unit-test -[ -1 ] [ 2004 1 1 12 30 0 instant +[ +lt+ ] [ 2004 1 1 12 30 0 instant 2004 1 1 13 30 0 instant <=> ] unit-test -[ 1 ] [ 2005 1 1 12 30 0 instant +[ +gt+ ] [ 2005 1 1 12 30 0 instant 2004 1 1 13 30 0 instant <=> ] unit-test [ t ] [ now timestamp>millis millis - 1000 < ] unit-test @@ -159,3 +163,7 @@ IN: calendar.tests [ t ] [ 5 months checktime+ ] unit-test [ t ] [ 5 years checktime+ ] unit-test + +[ t ] [ now 50 milliseconds sleep now before? ] unit-test +[ t ] [ now 50 milliseconds sleep now swap after? ] unit-test +[ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 8dcb4af7f1..0e21876fe9 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -3,7 +3,7 @@ USING: arrays kernel math math.functions namespaces sequences strings system vocabs.loader calendar.backend threads -accessors combinators locals classes.tuple ; +accessors combinators locals classes.tuple math.order ; IN: calendar TUPLE: timestamp year month day hour minute second gmt-offset ; @@ -211,12 +211,14 @@ M: duration time+ #! Uses average month/year length since dt loses calendar #! data 0 swap - [ year>> + ] keep - [ month>> months-per-year / + ] keep - [ day>> days-per-year / + ] keep - [ hour>> hours-per-year / + ] keep - [ minute>> minutes-per-year / + ] keep - second>> seconds-per-year / + ; + { + [ year>> + ] + [ month>> months-per-year / + ] + [ day>> days-per-year / + ] + [ hour>> hours-per-year / + ] + [ minute>> minutes-per-year / + ] + [ second>> seconds-per-year / + ] + } cleave ; M: duration <=> [ dt>years ] compare ; @@ -252,14 +254,21 @@ M: timestamp time- #! Exact calendar-time difference (time-) seconds ; +: time* ( obj1 obj2 -- obj3 ) + dup real? [ swap ] when + dup real? [ * ] [ + { + [ year>> * ] + [ month>> * ] + [ day>> * ] + [ hour>> * ] + [ minute>> * ] + [ second>> * ] + } 2cleave + ] if ; + : before ( dt -- -dt ) - [ year>> neg ] keep - [ month>> neg ] keep - [ day>> neg ] keep - [ hour>> neg ] keep - [ minute>> neg ] keep - second>> neg - ; + -1 time* ; M: duration time- before time+ ; diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor index 88bd0733c0..f4e1669178 100755 --- a/extra/calendar/format/format-tests.factor +++ b/extra/calendar/format/format-tests.factor @@ -1,26 +1,52 @@ -USING: calendar.format calendar kernel tools.test -io.streams.string ; +USING: calendar.format calendar kernel math tools.test +io.streams.string accessors io math.order ; IN: calendar.format.tests [ 0 ] [ - "Z" [ read-rfc3339-gmt-offset ] with-string-reader + "Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours ] unit-test [ 1 ] [ - "+01" [ read-rfc3339-gmt-offset ] with-string-reader + "+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours ] unit-test [ -1 ] [ - "-01" [ read-rfc3339-gmt-offset ] with-string-reader + "-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours ] unit-test [ -1-1/2 ] [ - "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader + "-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours ] unit-test [ 1+1/2 ] [ - "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader + "+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours ] unit-test [ ] [ now timestamp>rfc3339 drop ] unit-test [ ] [ now timestamp>rfc822 drop ] unit-test + +[ 8/1000 -4 ] [ + "2008-04-19T04:56:00.008-04:00" rfc3339>timestamp + [ second>> ] [ gmt-offset>> hour>> ] bi +] unit-test + +[ T{ duration f 0 0 0 0 0 0 } ] [ + "GMT" parse-rfc822-gmt-offset +] unit-test + +[ T{ duration f 0 0 0 -5 0 0 } ] [ + "-0500" parse-rfc822-gmt-offset +] unit-test + +[ T{ timestamp f 2008 4 22 14 36 12 T{ duration f 0 0 0 0 0 0 } } ] [ + "Tue, 22 Apr 2008 14:36:12 GMT" rfc822>timestamp +] unit-test + +[ t ] [ now dup timestamp>rfc822 rfc822>timestamp time- 1 seconds before? ] unit-test + +[ t ] [ now dup timestamp>cookie-string cookie-string>timestamp time- 1 seconds before? ] unit-test + +[ "Sun, 4 May 2008 07:00:00" ] [ + "Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp + timestamp>string +] unit-test diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index 26ed873fd3..91a034f8bd 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -1,7 +1,50 @@ -USING: math math.parser kernel sequences io calendar -accessors arrays io.streams.string combinators accessors ; +USING: math math.order math.parser kernel sequences io +accessors arrays io.streams.string splitting +combinators accessors debugger +calendar calendar.format.macros ; IN: calendar.format +: pad-00 number>string 2 CHAR: 0 pad-left ; + +: pad-0000 number>string 4 CHAR: 0 pad-left ; + +: pad-00000 number>string 5 CHAR: 0 pad-left ; + +: write-00 pad-00 write ; + +: write-0000 pad-0000 write ; + +: write-00000 pad-00000 write ; + +: hh hour>> write-00 ; + +: mm minute>> write-00 ; + +: ss second>> >integer write-00 ; + +: D day>> number>string write ; + +: DD day>> write-00 ; + +: DAY day-of-week day-abbreviations3 nth write ; + +: MM month>> write-00 ; + +: MONTH month>> month-abbreviations nth write ; + +: YYYY year>> write-0000 ; + +: YYYYY year>> write-00000 ; + +: expect ( str -- ) + read1 swap member? [ "Parse error" throw ] unless ; + +: read-00 2 read string>number ; + +: read-000 3 read string>number ; + +: read-0000 4 read string>number ; + GENERIC: day. ( obj -- ) M: integer day. ( n -- ) @@ -24,7 +67,7 @@ M: array month. ( pair -- ) ] with each nl ; M: timestamp month. ( timestamp -- ) - { year>> month>> } get-slots 2array month. ; + [ year>> ] [ month>> ] bi 2array month. ; GENERIC: year. ( obj -- ) @@ -34,43 +77,29 @@ M: integer year. ( n -- ) M: timestamp year. ( timestamp -- ) year>> year. ; -: pad-00 number>string 2 CHAR: 0 pad-left ; - -: pad-0000 number>string 4 CHAR: 0 pad-left ; - -: write-00 pad-00 write ; - -: write-0000 pad-0000 write ; - : (timestamp>string) ( timestamp -- ) - dup day-of-week day-abbreviations3 nth write ", " write - dup day>> number>string write bl - dup month>> month-abbreviations nth write bl - dup year>> number>string write bl - dup hour>> write-00 ":" write - dup minute>> write-00 ":" write - second>> >integer write-00 ; + { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ; : timestamp>string ( timestamp -- str ) [ (timestamp>string) ] with-string-writer ; : (write-gmt-offset) ( duration -- ) - [ hour>> write-00 ] [ minute>> write-00 ] bi ; + [ hh ] [ mm ] bi ; : write-gmt-offset ( gmt-offset -- ) dup instant <=> { - { [ dup 0 = ] [ 2drop "GMT" write ] } - { [ dup 0 < ] [ drop "-" write before (write-gmt-offset) ] } - { [ dup 0 > ] [ drop "+" write (write-gmt-offset) ] } - } cond ; + { +eq+ [ drop "GMT" write ] } + { +lt+ [ "-" write before (write-gmt-offset) ] } + { +gt+ [ "+" write (write-gmt-offset) ] } + } case ; : timestamp>rfc822 ( timestamp -- str ) #! RFC822 timestamp format #! Example: Tue, 15 Nov 1994 08:12:31 +0200 [ - dup (timestamp>string) - " " write - gmt-offset>> write-gmt-offset + [ (timestamp>string) " " write ] + [ gmt-offset>> write-gmt-offset ] + bi ] with-string-writer ; : timestamp>http-string ( timestamp -- str ) @@ -78,42 +107,42 @@ M: timestamp year. ( timestamp -- ) #! Example: Tue, 15 Nov 1994 08:12:31 GMT >gmt timestamp>rfc822 ; +: (timestamp>cookie-string) ( timestamp -- ) + >gmt + { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ; + +: timestamp>cookie-string ( timestamp -- str ) + [ (timestamp>cookie-string) ] with-string-writer ; + : (write-rfc3339-gmt-offset) ( duration -- ) - [ hour>> write-00 CHAR: : write1 ] - [ minute>> write-00 ] bi ; + [ hh ":" write ] [ mm ] bi ; : write-rfc3339-gmt-offset ( duration -- ) dup instant <=> { - { [ dup 0 = ] [ 2drop "Z" write ] } - { [ dup 0 < ] [ drop CHAR: - write1 before (write-rfc3339-gmt-offset) ] } - { [ dup 0 > ] [ drop CHAR: + write1 (write-rfc3339-gmt-offset) ] } - } cond ; + { +eq+ [ drop "Z" write ] } + { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] } + { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] } + } case ; : (timestamp>rfc3339) ( timestamp -- ) - dup year>> number>string write CHAR: - write1 - dup month>> write-00 CHAR: - write1 - dup day>> write-00 CHAR: T write1 - dup hour>> write-00 CHAR: : write1 - dup minute>> write-00 CHAR: : write1 - dup second>> >fixnum write-00 - gmt-offset>> write-rfc3339-gmt-offset ; + { + YYYY "-" MM "-" DD "T" hh ":" mm ":" ss + [ gmt-offset>> write-rfc3339-gmt-offset ] + } formatted ; : timestamp>rfc3339 ( timestamp -- str ) [ (timestamp>rfc3339) ] with-string-writer ; -: expect ( str -- ) - read1 swap member? [ "Parse error" throw ] unless ; +: signed-gmt-offset ( dt ch -- dt' ) + { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ; -: read-00 2 read string>number ; - -: read-0000 4 read string>number ; - -: read-rfc3339-gmt-offset ( -- n ) - read1 dup CHAR: Z = [ drop 0 ] [ - { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case - read-00 - read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case - 60 / + * +: read-rfc3339-gmt-offset ( ch -- dt ) + dup CHAR: Z = [ drop instant ] [ + >r + read-00 hours + read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes + time+ + r> signed-gmt-offset ] if ; : read-ymd ( -- y m d ) @@ -126,66 +155,127 @@ M: timestamp year. ( timestamp -- ) read-ymd "Tt" expect read-hms - read-rfc3339-gmt-offset ! timezone + read1 { { CHAR: . [ read-000 1000 / + read1 ] } [ ] } case + read-rfc3339-gmt-offset ; : rfc3339>timestamp ( str -- timestamp ) [ (rfc3339>timestamp) ] with-string-reader ; +ERROR: invalid-timestamp-format ; + +: check-timestamp ( obj/f -- obj ) + [ invalid-timestamp-format ] unless* ; + +: read-token ( seps -- token ) + [ read-until ] keep member? check-timestamp drop ; + +: read-sp ( -- token ) " " read-token ; + +: checked-number ( str -- n ) + string>number check-timestamp ; + +: parse-rfc822-gmt-offset ( string -- dt ) + dup "GMT" = [ drop instant ] [ + unclip >r + 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+ + r> signed-gmt-offset + ] if ; + +: (rfc822>timestamp) ( -- timestamp ) + timestamp new + "," read-token day-abbreviations3 member? check-timestamp drop + read1 CHAR: \s assert= + read-sp checked-number >>day + read-sp month-abbreviations index check-timestamp >>month + read-sp checked-number >>year + ":" read-token checked-number >>hour + ":" read-token checked-number >>minute + " " read-token checked-number >>second + readln parse-rfc822-gmt-offset >>gmt-offset ; + +: rfc822>timestamp ( str -- timestamp ) + [ (rfc822>timestamp) ] with-string-reader ; + +: (cookie-string>timestamp-1) ( -- timestamp ) + timestamp new + "," read-token day-abbreviations3 member? check-timestamp drop + read1 CHAR: \s assert= + "-" read-token checked-number >>day + "-" read-token month-abbreviations index check-timestamp >>month + read-sp checked-number >>year + ":" read-token checked-number >>hour + ":" read-token checked-number >>minute + " " read-token checked-number >>second + readln parse-rfc822-gmt-offset >>gmt-offset ; + +: cookie-string>timestamp-1 ( str -- timestamp ) + [ (cookie-string>timestamp-1) ] with-string-reader ; + +: (cookie-string>timestamp-2) ( -- timestamp ) + timestamp new + read-sp day-abbreviations3 member? check-timestamp drop + read-sp month-abbreviations index check-timestamp >>month + read-sp checked-number >>day + ":" read-token checked-number >>hour + ":" read-token checked-number >>minute + " " read-token checked-number >>second + read-sp checked-number >>year + readln parse-rfc822-gmt-offset >>gmt-offset ; + +: cookie-string>timestamp-2 ( str -- timestamp ) + [ (cookie-string>timestamp-2) ] with-string-reader ; + +: cookie-string>timestamp ( str -- timestamp ) + { + [ cookie-string>timestamp-1 ] + [ cookie-string>timestamp-2 ] + [ rfc822>timestamp ] + } attempt-all-quots ; + : (ymdhms>timestamp) ( -- timestamp ) - read-ymd " " expect read-hms 0 ; + read-ymd " " expect read-hms instant ; : ymdhms>timestamp ( str -- timestamp ) [ (ymdhms>timestamp) ] with-string-reader ; : (hms>timestamp) ( -- timestamp ) - f f f read-hms f ; + f f f read-hms instant ; : hms>timestamp ( str -- timestamp ) [ (hms>timestamp) ] with-string-reader ; : (ymd>timestamp) ( -- timestamp ) - read-ymd f f f f ; + read-ymd f f f instant ; : ymd>timestamp ( str -- timestamp ) [ (ymd>timestamp) ] with-string-reader ; : (timestamp>ymd) ( timestamp -- ) - dup timestamp-year write-0000 - "-" write - dup timestamp-month write-00 - "-" write - timestamp-day write-00 ; + { YYYY "-" MM "-" DD } formatted ; : timestamp>ymd ( timestamp -- str ) [ (timestamp>ymd) ] with-string-writer ; : (timestamp>hms) - dup timestamp-hour write-00 - ":" write - dup timestamp-minute write-00 - ":" write - timestamp-second >integer write-00 ; + { hh ":" mm ":" ss } formatted ; : timestamp>hms ( timestamp -- str ) [ (timestamp>hms) ] with-string-writer ; : timestamp>ymdhms ( timestamp -- str ) - >gmt [ - dup (timestamp>ymd) - " " write - (timestamp>hms) + >gmt + { (timestamp>ymd) " " (timestamp>hms) } formatted ] with-string-writer ; : file-time-string ( timestamp -- string ) [ - [ month>> month-abbreviations nth write ] keep bl - [ day>> number>string 2 32 pad-left write ] keep bl - dup now [ year>> ] bi@ = [ - [ hour>> write-00 ] keep ":" write - minute>> write-00 - ] [ - year>> number>string 5 32 pad-left write - ] if + { + MONTH " " DD " " + [ + dup now [ year>> ] bi@ = + [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if + ] + } formatted ] with-string-writer ; diff --git a/extra/calendar/format/macros/macros-tests.factor b/extra/calendar/format/macros/macros-tests.factor new file mode 100644 index 0000000000..91a8f80894 --- /dev/null +++ b/extra/calendar/format/macros/macros-tests.factor @@ -0,0 +1,14 @@ +USING: tools.test kernel ; +IN: calendar.format.macros + +[ 2 ] [ { [ 2 ] } attempt-all-quots ] unit-test + +[ 2 ] [ { [ 1 throw ] [ 2 ] } attempt-all-quots ] unit-test + +[ { [ 1 throw ] } attempt-all-quots ] [ 1 = ] must-fail-with + +: compiled-test-1 { [ 1 throw ] [ 2 ] } attempt-all-quots ; + +\ compiled-test-1 must-infer + +[ 2 ] [ compiled-test-1 ] unit-test diff --git a/extra/calendar/format/macros/macros.factor b/extra/calendar/format/macros/macros.factor new file mode 100644 index 0000000000..6d6dd3ae23 --- /dev/null +++ b/extra/calendar/format/macros/macros.factor @@ -0,0 +1,19 @@ +USING: macros kernel words quotations io sequences combinators +continuations ; +IN: calendar.format.macros + +MACRO: formatted ( spec -- ) + [ + { + { [ dup word? ] [ 1quotation ] } + { [ dup quotation? ] [ ] } + [ [ nip write ] curry [ ] like ] + } cond + ] map [ cleave ] curry ; + +MACRO: attempt-all-quots ( quots -- ) + dup length 1 = [ first ] [ + unclip swap + [ nip attempt-all-quots ] curry + [ recover ] 2curry + ] if ; diff --git a/extra/classes/tuple/lib/lib-docs.factor b/extra/classes/tuple/lib/lib-docs.factor index 34dd181d3b..0c4c11e46f 100644 --- a/extra/classes/tuple/lib/lib-docs.factor +++ b/extra/classes/tuple/lib/lib-docs.factor @@ -6,6 +6,7 @@ HELP: >tuple< { $description "Explodes the tuple so that tuple slots are on the stack in the order listed in the tuple." } { $example "USING: kernel prettyprint classes.tuple.lib ;" + "IN: scratchpad" "TUPLE: foo a b c ;" "1 2 3 \\ foo boa \\ foo >tuple< .s" "1\n2\n3" @@ -18,6 +19,7 @@ HELP: >tuple*< { $description "Explodes the tuple so that tuple slots ending with '*' are on the stack in the order listed in the tuple." } { $example "USING: kernel prettyprint classes.tuple.lib ;" + "IN: scratchpad" "TUPLE: foo a bb* ccc dddd* ;" "1 2 3 4 \\ foo boa \\ foo >tuple*< .s" "2\n4" diff --git a/extra/classes/tuple/lib/lib.factor b/extra/classes/tuple/lib/lib.factor index 38104a45db..10261a1df7 100755 --- a/extra/classes/tuple/lib/lib.factor +++ b/extra/classes/tuple/lib/lib.factor @@ -7,11 +7,11 @@ IN: classes.tuple.lib [ slot-spec-reader ] map [ get-slots ] curry ; MACRO: >tuple< ( class -- ) - all-slots 1 tail-slice reader-slots ; + all-slots rest-slice reader-slots ; MACRO: >tuple*< ( class -- ) all-slots - [ slot-spec-name "*" tail? ] subset + [ slot-spec-name "*" tail? ] filter reader-slots ; diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor index ca9509c3ec..f917e20bc4 100755 --- a/extra/cocoa/messages/messages.factor +++ b/extra/cocoa/messages/messages.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.compiler +USING: alien alien.c-types alien.strings alien.compiler arrays assocs combinators compiler inference.transforms kernel math namespaces parser prettyprint prettyprint.sections quotations sequences strings words cocoa.runtime io macros -memoize debugger ; +memoize debugger io.encodings.ascii ; IN: cocoa.messages : make-sender ( method function -- quot ) @@ -104,7 +104,7 @@ MACRO: (send) ( selector super? -- quot ) : method-arg-type ( method i -- type ) f 0 over >r method_getArgumentInfo drop - r> *char* ; + r> *void* ascii alien>string ; SYMBOL: objc>alien-types @@ -142,7 +142,7 @@ H{ } assoc-union alien>objc-types set-global : objc-struct-type ( i string -- ctype ) - 2dup CHAR: = -rot index* swap subseq + 2dup CHAR: = -rot index-from swap subseq dup c-types get key? [ "Warning: no such C type: " write dup print drop "void*" diff --git a/extra/cocoa/subclassing/subclassing.factor b/extra/cocoa/subclassing/subclassing.factor index 48f45f21c0..6b3e1d330e 100755 --- a/extra/cocoa/subclassing/subclassing.factor +++ b/extra/cocoa/subclassing/subclassing.factor @@ -1,14 +1,15 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays assocs combinators compiler -hashtables kernel libc math namespaces parser sequences words -cocoa.messages cocoa.runtime compiler.units ; +USING: alien alien.c-types alien.strings arrays assocs +combinators compiler hashtables kernel libc math namespaces +parser sequences words cocoa.messages cocoa.runtime +compiler.units io.encodings.ascii ; IN: cocoa.subclassing : init-method ( method alien -- ) >r first3 r> [ >r execute r> set-objc-method-imp ] keep - [ >r malloc-char-string r> set-objc-method-types ] keep + [ >r ascii malloc-string r> set-objc-method-types ] keep >r sel_registerName r> set-objc-method-name ; : ( n -- alien ) @@ -26,7 +27,7 @@ IN: cocoa.subclassing : ( name info -- class ) "objc-class" malloc-object [ set-objc-class-info ] keep - [ >r malloc-char-string r> set-objc-class-name ] keep ; + [ >r ascii malloc-string r> set-objc-class-name ] keep ; : ( name -- protocol-list ) "objc-protocol-list" malloc-object diff --git a/extra/columns/authors.txt b/extra/columns/authors.txt new file mode 100644 index 0000000000..a44f8d7f8d --- /dev/null +++ b/extra/columns/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Daniel Ehrenberg diff --git a/extra/columns/columns-docs.factor b/extra/columns/columns-docs.factor new file mode 100644 index 0000000000..a2f0cccf3b --- /dev/null +++ b/extra/columns/columns-docs.factor @@ -0,0 +1,26 @@ +USING: help.markup help.syntax sequences ; +IN: columns + +ARTICLE: "columns" "Column sequences" +"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:" +{ $subsection column } +{ $subsection } ; + +HELP: column +{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link } "." } ; + +HELP: ( seq n -- column ) +{ $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } } +{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." } +{ $examples + { $example + "USING: arrays prettyprint columns ;" + "{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 >array ." + "{ 1 4 7 }" + } +} +{ $notes + "In the same sense that " { $link } " is a virtual variant of " { $link reverse } ", " { $link } " is a virtual variant of " { $snippet "swap [ nth ] curry map" } "." +} ; + +ABOUT: "columns" diff --git a/extra/columns/columns-tests.factor b/extra/columns/columns-tests.factor new file mode 100644 index 0000000000..657b9e0a25 --- /dev/null +++ b/extra/columns/columns-tests.factor @@ -0,0 +1,9 @@ +IN: columns.tests +USING: columns sequences kernel namespaces arrays tools.test math ; + +! Columns +{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set + +[ { 1 4 7 } ] [ "seq" get 0 >array ] unit-test +[ ] [ "seq" get 1 [ sq ] change-each ] unit-test +[ { 4 25 64 } ] [ "seq" get 1 >array ] unit-test diff --git a/extra/columns/columns.factor b/extra/columns/columns.factor new file mode 100644 index 0000000000..7e4a7fd408 --- /dev/null +++ b/extra/columns/columns.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: sequences kernel accessors ; +IN: columns + +! A column of a matrix +TUPLE: column seq col ; + +C: column + +M: column virtual-seq seq>> ; +M: column virtual@ dup col>> -rot seq>> nth bounds-check ; +M: column length seq>> length ; + +INSTANCE: column virtual-sequence diff --git a/extra/columns/summary.txt b/extra/columns/summary.txt new file mode 100644 index 0000000000..c4ade7fb51 --- /dev/null +++ b/extra/columns/summary.txt @@ -0,0 +1 @@ +Virtual sequence view of a matrix column diff --git a/core/float-vectors/tags.txt b/extra/columns/tags.txt similarity index 100% rename from core/float-vectors/tags.txt rename to extra/columns/tags.txt diff --git a/extra/concurrency/combinators/combinators-docs.factor b/extra/concurrency/combinators/combinators-docs.factor index 0db235d9e6..bbf8fb0f5f 100755 --- a/extra/concurrency/combinators/combinators-docs.factor +++ b/extra/concurrency/combinators/combinators-docs.factor @@ -11,15 +11,15 @@ HELP: parallel-each { $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." } { $errors "Throws an error if one of the iterations throws an error." } ; -HELP: parallel-subset +HELP: parallel-filter { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "newseq" sequence } } { $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." } { $errors "Throws an error if one of the iterations throws an error." } ; ARTICLE: "concurrency.combinators" "Concurrent combinators" -"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link subset } ":" +"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link filter } ":" { $subsection parallel-each } { $subsection parallel-map } -{ $subsection parallel-subset } ; +{ $subsection parallel-filter } ; ABOUT: "concurrency.combinators" diff --git a/extra/concurrency/combinators/combinators-tests.factor b/extra/concurrency/combinators/combinators-tests.factor index 731a740983..3381cba5e8 100755 --- a/extra/concurrency/combinators/combinators-tests.factor +++ b/extra/concurrency/combinators/combinators-tests.factor @@ -4,7 +4,7 @@ concurrency.mailboxes threads sequences accessors ; [ [ drop ] parallel-each ] must-infer [ [ ] parallel-map ] must-infer -[ [ ] parallel-subset ] must-infer +[ [ ] parallel-filter ] must-infer [ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test @@ -14,7 +14,7 @@ concurrency.mailboxes threads sequences accessors ; [ error>> "Even" = ] must-fail-with [ V{ 0 3 6 9 } ] -[ 10 [ 3 mod zero? ] parallel-subset ] unit-test +[ 10 [ 3 mod zero? ] parallel-filter ] unit-test [ 10 ] [ diff --git a/extra/concurrency/combinators/combinators.factor b/extra/concurrency/combinators/combinators.factor index 76c3cfa77d..3c4101e381 100755 --- a/extra/concurrency/combinators/combinators.factor +++ b/extra/concurrency/combinators/combinators.factor @@ -13,5 +13,5 @@ IN: concurrency.combinators [ [ >r curry r> spawn-stage ] 2curry each ] keep await ; inline -: parallel-subset ( seq quot -- newseq ) +: parallel-filter ( seq quot -- newseq ) over >r pusher >r each r> r> like ; inline diff --git a/extra/core-foundation/core-foundation.factor b/extra/core-foundation/core-foundation.factor index 77ad30ad8f..a4bd24ccca 100644 --- a/extra/core-foundation/core-foundation.factor +++ b/extra/core-foundation/core-foundation.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax kernel math sequences ; +USING: alien alien.c-types alien.strings alien.syntax kernel +math sequences io.encodings.utf16 ; IN: core-foundation TYPEDEF: void* CFAllocatorRef @@ -31,7 +32,7 @@ FUNCTION: CFURLRef CFURLCreateWithString ( CFAllocatorRef allocator, CFStringRef FUNCTION: CFURLRef CFURLCopyFileSystemPath ( CFURLRef url, int pathStyle ) ; -FUNCTION: CFStringRef CFStringCreateWithCharacters ( CFAllocatorRef allocator, ushort* cStr, CFIndex numChars ) ; +FUNCTION: CFStringRef CFStringCreateWithCharacters ( CFAllocatorRef allocator, wchar_t* cStr, CFIndex numChars ) ; FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ; @@ -57,7 +58,7 @@ FUNCTION: void CFRelease ( void* cf ) ; : CF>string ( alien -- string ) dup CFStringGetLength 1+ "ushort" [ >r 0 over CFStringGetLength r> CFStringGetCharacters - ] keep alien>u16-string ; + ] keep utf16n alien>string ; : CF>string-array ( alien -- seq ) CF>array [ CF>string ] map ; diff --git a/extra/core-foundation/fsevents/fsevents.factor b/extra/core-foundation/fsevents/fsevents.factor index 3c9dbdbef0..4698aa45ae 100644 --- a/extra/core-foundation/fsevents/fsevents.factor +++ b/extra/core-foundation/fsevents/fsevents.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax kernel math sequences -namespaces assocs init accessors continuations combinators -core-foundation core-foundation.run-loop ; +USING: alien alien.c-types alien.strings alien.syntax kernel +math sequences namespaces assocs init accessors continuations +combinators core-foundation core-foundation.run-loop +io.encodings.utf8 ; IN: core-foundation.fsevents ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! @@ -152,7 +153,7 @@ SYMBOL: event-stream-callbacks [ event-stream-callbacks global - [ [ drop expired? not ] assoc-subset H{ } assoc-like ] change-at + [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-at ] "core-foundation" add-init-hook : add-event-source-callback ( quot -- id ) @@ -165,7 +166,7 @@ SYMBOL: event-stream-callbacks : >event-triple ( n eventPaths eventFlags eventIds -- triple ) [ >r >r >r dup dup - r> char*-nth , + r> void*-nth utf8 alien>string , r> int-nth , r> longlong-nth , ] { } make ; diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index ecc998e99c..f1af0ef15e 100755 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -573,7 +573,7 @@ SYMBOL: $4 #! $1, $2, etc with the relevant item from the #! given index. dup quotation? over [ ] = not and [ ! vector tree - dup first swap 1 tail ! vector car cdr + dup first swap rest ! vector car cdr >r dupd replace-patterns ! vector v R: cdr swap r> replace-patterns >r 1quotation r> append ] [ ! vector value diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index 37e92db60f..3a74d1f5db 100755 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -123,6 +123,6 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; : byte-array>sha1-interleave ( string -- seq ) [ zero? ] left-trim - dup length odd? [ 1 tail ] when + dup length odd? [ rest ] when seq>2seq [ byte-array>sha1 ] bi@ 2seq>seq ; diff --git a/extra/csv/authors.txt b/extra/csv/authors.txt new file mode 100644 index 0000000000..0be42b2faa --- /dev/null +++ b/extra/csv/authors.txt @@ -0,0 +1 @@ +Phil Dawes diff --git a/extra/csv/csv-docs.factor b/extra/csv/csv-docs.factor new file mode 100644 index 0000000000..c9f39900ab --- /dev/null +++ b/extra/csv/csv-docs.factor @@ -0,0 +1,21 @@ +USING: help.syntax help.markup kernel prettyprint sequences ; +IN: csv + +HELP: csv +{ $values { "stream" "a stream" } + { "rows" "an array of arrays of fields" } } +{ $description "parses a csv stream into an array of row arrays" +} ; + +HELP: csv-row +{ $values { "stream" "a stream" } + { "row" "an array of fields" } } +{ $description "parses a row from a csv stream" +} ; + + +HELP: with-delimiter +{ $values { "char" "field delimiter (e.g. CHAR: \t)" } + { "quot" "a quotation" } } +{ $description "Sets the field delimiter for csv or csv-row words " +} ; diff --git a/extra/csv/csv-tests.factor b/extra/csv/csv-tests.factor new file mode 100644 index 0000000000..6ab26c7e40 --- /dev/null +++ b/extra/csv/csv-tests.factor @@ -0,0 +1,67 @@ +USING: io.streams.string csv tools.test shuffle ; +IN: csv.tests + +! I like to name my unit tests +: named-unit-test ( name output input -- ) + nipd unit-test ; inline + +! tests nicked from the wikipedia csv article +! http://en.wikipedia.org/wiki/Comma-separated_values + +"Fields are separated by commas" +[ { { "1997" "Ford" "E350" } } ] +[ "1997,Ford,E350" csv ] named-unit-test + +"ignores whitespace before and after elements. n.b.specifically prohibited by RFC 4180, which states, 'Spaces are considered part of a field and should not be ignored.'" +[ { { "1997" "Ford" "E350" } } ] +[ "1997, Ford , E350" csv ] named-unit-test + +"keeps spaces in quotes" +[ { { "1997" "Ford" "E350" "Super, luxurious truck" } } ] +[ "1997,Ford,E350,\"Super, luxurious truck\"" csv ] named-unit-test + +"double quotes mean escaped in quotes" +[ { { "1997" "Ford" "E350" "Super \"luxurious\" truck" } } ] +[ "1997,Ford,E350,\"Super \"\"luxurious\"\" truck\"" + csv ] named-unit-test + +"Fields with embedded line breaks must be delimited by double-quote characters." +[ { { "1997" "Ford" "E350" "Go get one now\nthey are going fast" } } ] +[ "1997,Ford,E350,\"Go get one now\nthey are going fast\"" + csv ] named-unit-test + +"Fields with leading or trailing spaces must be delimited by double-quote characters. (See comment about leading and trailing spaces above)" +[ { { "1997" "Ford" "E350" " Super luxurious truck " } } ] +[ "1997,Ford,E350,\" Super luxurious truck \"" + csv ] named-unit-test + +"Fields may always be delimited by double-quote characters, whether necessary or not." +[ { { "1997" "Ford" "E350" } } ] +[ "\"1997\",\"Ford\",\"E350\"" csv ] named-unit-test + +"The first record in a csv file may contain column names in each of the fields." +[ { { "Year" "Make" "Model" } + { "1997" "Ford" "E350" } + { "2000" "Mercury" "Cougar" } } ] +[ "Year,Make,Model\n1997,Ford,E350\n2000,Mercury,Cougar" + csv ] named-unit-test + + + + +! !!!!!!!! other tests + +[ { { "Phil Dawes" } } ] +[ "\"Phil Dawes\"" csv ] unit-test + +[ { { "1" "2" "3" } { "4" "5" "6" } } ] +[ "1,2,3\n4,5,6\n" csv ] unit-test + +"trims leading and trailing whitespace - n.b. this isn't really conformant, but lots of csv seems to assume this" +[ { { "foo yeah" "bah" "baz" } } ] +[ " foo yeah , bah ,baz\n" csv ] named-unit-test + + +"allows setting of delimiting character" +[ { { "foo" "bah" "baz" } } ] +[ "foo\tbah\tbaz\n" CHAR: \t [ csv ] with-delimiter ] named-unit-test diff --git a/extra/csv/csv.factor b/extra/csv/csv.factor new file mode 100644 index 0000000000..3953ce057b --- /dev/null +++ b/extra/csv/csv.factor @@ -0,0 +1,70 @@ +! Copyright (C) 2007, 2008 Phil Dawes +! See http://factorcode.org/license.txt for BSD license. + +! Simple CSV Parser +! Phil Dawes phil@phildawes.net + +USING: kernel sequences io namespaces combinators unicode.categories vars ; +IN: csv + +DEFER: quoted-field + +VAR: delimiter + +! trims whitespace from either end of string +: trim-whitespace ( str -- str ) + [ blank? ] trim ; inline + +: skip-to-field-end ( -- endchar ) + "\n" delimiter> suffix read-until nip ; inline + +: not-quoted-field ( -- endchar ) + "\"\n" delimiter> suffix read-until ! " + dup + { { CHAR: " [ drop drop quoted-field ] } ! " + { delimiter> [ swap trim-whitespace % ] } + { CHAR: \n [ swap trim-whitespace % ] } + { f [ swap trim-whitespace % ] } ! eof + } case ; + +: maybe-escaped-quote ( -- endchar ) + read1 dup + { { CHAR: " [ , quoted-field ] } ! " is an escaped quote + { delimiter> [ ] } ! end of quoted field + [ 2drop skip-to-field-end ] ! end of quoted field + padding + } case ; + +: quoted-field ( -- endchar ) + "\"" read-until ! " + drop % maybe-escaped-quote ; + +: field ( -- sep string ) + [ not-quoted-field ] "" make ; ! trim-whitespace + +: (row) ( -- sep ) + field , + dup delimiter> = [ drop (row) ] when ; + +: row ( -- eof? array[string] ) + [ (row) ] { } make ; + +: append-if-row-not-empty ( row -- ) + dup { "" } = [ drop ] [ , ] if ; + +: (csv) ( -- ) + row append-if-row-not-empty + [ (csv) ] when ; + +: init-vars ( -- ) + delimiter> [ CHAR: , >delimiter ] unless ; inline + +: csv-row ( stream -- row ) + init-vars + [ row nip ] with-stream ; + +: csv ( stream -- rows ) + init-vars + [ [ (csv) ] { } make ] with-stream ; + +: with-delimiter ( char quot -- ) + delimiter swap with-variable ; inline diff --git a/extra/csv/summary.txt b/extra/csv/summary.txt new file mode 100644 index 0000000000..503cc1b38d --- /dev/null +++ b/extra/csv/summary.txt @@ -0,0 +1 @@ +CSV parser diff --git a/extra/db/db-tests.factor b/extra/db/db-tests.factor index 9c32f9e326..0d95e3aea7 100755 --- a/extra/db/db-tests.factor +++ b/extra/db/db-tests.factor @@ -3,3 +3,4 @@ USING: tools.test db kernel ; { 1 0 } [ [ drop ] query-each ] must-infer-as { 1 1 } [ [ ] query-map ] must-infer-as +{ 2 0 } [ [ ] with-db ] must-infer-as diff --git a/extra/db/db.factor b/extra/db/db.factor index baf4e9db5a..237d8698a6 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes continuations kernel math namespaces sequences sequences.lib classes.tuple words strings -tools.walker accessors ; +tools.walker accessors combinators.lib ; IN: db TUPLE: db @@ -11,7 +11,7 @@ TUPLE: db update-statements delete-statements ; -: construct-db ( class -- obj ) +: new-db ( class -- obj ) new H{ } clone >>insert-statements H{ } clone >>update-statements @@ -20,7 +20,7 @@ TUPLE: db GENERIC: make-db* ( seq class -- db ) : make-db ( seq class -- db ) - construct-db make-db* ; + new-db make-db* ; GENERIC: db-open ( db -- db ) HOOK: db-close db ( handle -- ) @@ -35,18 +35,25 @@ HOOK: db-close db ( handle -- ) handle>> db-close ] with-variable ; -! TUPLE: sql sql in-params out-params ; -TUPLE: statement handle sql in-params out-params bind-params bound? ; +TUPLE: statement handle sql in-params out-params bind-params bound? type ; TUPLE: simple-statement < statement ; TUPLE: prepared-statement < statement ; -TUPLE: nonthrowable-statement < statement ; -TUPLE: throwable-statement < statement ; + +SINGLETON: throwable +SINGLETON: nonthrowable + +: make-throwable ( obj -- obj' ) + dup sequence? [ + [ make-throwable ] map + ] [ + throwable >>type + ] if ; : make-nonthrowable ( obj -- obj' ) dup sequence? [ [ make-nonthrowable ] map ] [ - nonthrowable-statement construct-delegate + nonthrowable >>type ] if ; TUPLE: result-set sql in-params out-params handle n max ; @@ -55,12 +62,14 @@ TUPLE: result-set sql in-params out-params handle n max ; new swap >>out-params swap >>in-params - swap >>sql ; + swap >>sql + throwable >>type ; HOOK: db ( str in out -- statement ) HOOK: db ( str in out -- statement ) GENERIC: prepare-statement ( statement -- ) GENERIC: bind-statement* ( statement -- ) +GENERIC: low-level-bind ( statement -- ) GENERIC: bind-tuple ( tuple statement -- ) GENERIC: query-results ( query -- result-set ) GENERIC: #rows ( result-set -- n ) @@ -70,20 +79,19 @@ GENERIC# row-column-typed 1 ( result-set column -- sql ) GENERIC: advance-row ( result-set -- ) GENERIC: more-rows? ( result-set -- ? ) -GENERIC: execute-statement ( statement -- ) +GENERIC: execute-statement* ( statement type -- ) -M: throwable-statement execute-statement ( statement -- ) +M: throwable execute-statement* ( statement type -- ) + drop query-results dispose ; + +M: nonthrowable execute-statement* ( statement type -- ) + drop [ query-results dispose ] [ 2drop ] recover ; + +: execute-statement ( statement -- ) dup sequence? [ [ execute-statement ] each ] [ - query-results dispose - ] if ; - -M: nonthrowable-statement execute-statement ( statement -- ) - dup sequence? [ - [ execute-statement ] each - ] [ - [ query-results dispose ] [ 2drop ] recover + dup type>> execute-statement* ] if ; : bind-statement ( obj statement -- ) @@ -121,7 +129,8 @@ M: nonthrowable-statement execute-statement ( statement -- ) : with-db ( db seq quot -- ) >r make-db db-open db r> - [ db get swap [ drop ] swap compose with-disposal ] curry with-variable ; + [ db get swap [ drop ] prepose with-disposal ] curry with-variable ; + inline : default-query ( query -- result-set ) query-results [ [ sql-row ] query-map ] with-disposal ; diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index bfe7dab3ce..8b0026b6e5 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -4,8 +4,8 @@ USING: arrays continuations db io kernel math namespaces quotations sequences db.postgresql.ffi alien alien.c-types db.types tools.walker ascii splitting math.parser combinators libc shuffle calendar.format byte-arrays destructors prettyprint -accessors strings serialize io.encodings.binary -io.streams.byte-array ; +accessors strings serialize io.encodings.binary io.encodings.utf8 +alien.strings io.streams.byte-array inspector ; IN: db.postgresql.lib : postgresql-result-error-message ( res -- str/f ) @@ -23,12 +23,18 @@ IN: db.postgresql.lib "\n" split [ [ blank? ] trim ] map "\n" join ; : postgresql-error-message ( -- str ) - db get db-handle (postgresql-error-message) ; + db get handle>> (postgresql-error-message) ; : postgresql-error ( res -- res ) dup [ postgresql-error-message throw ] unless ; -: postgresql-result-ok? ( n -- ? ) +ERROR: postgresql-result-null ; + +M: postgresql-result-null summary ( obj -- str ) + drop "PQexec returned f." ; + +: postgresql-result-ok? ( res -- ? ) + [ postgresql-result-null ] unless* PQresultStatus PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ; @@ -37,8 +43,8 @@ IN: db.postgresql.lib dup PQstatus zero? [ (postgresql-error-message) throw ] unless ; : do-postgresql-statement ( statement -- res ) - db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [ - dup postgresql-result-error-message swap PQclear throw + db get handle>> swap sql>> PQexec dup postgresql-result-ok? [ + [ postgresql-result-error-message ] [ PQclear ] bi throw ] unless ; : type>oid ( symbol -- n ) @@ -58,30 +64,29 @@ IN: db.postgresql.lib } case ; : param-types ( statement -- seq ) - statement-in-params - [ sql-spec-type type>oid ] map - >c-uint-array ; + in-params>> [ type>> type>oid ] map >c-uint-array ; : malloc-byte-array/length [ malloc-byte-array dup free-always ] [ length ] bi ; - + +: default-param-value + number>string* dup [ + utf8 malloc-string dup free-always + ] when 0 ; : param-values ( statement -- seq seq2 ) - [ statement-bind-params ] - [ statement-in-params ] bi + [ bind-params>> ] [ in-params>> ] bi [ - sql-spec-type { + >r value>> r> type>> { { FACTOR-BLOB [ - dup [ - object>bytes - malloc-byte-array/length ] [ 0 ] if ] } - { BLOB [ - dup [ malloc-byte-array/length ] [ 0 ] if ] } - [ - drop number>string* dup [ - malloc-char-string dup free-always - ] when 0 - ] + dup [ object>bytes malloc-byte-array/length ] [ 0 ] if + ] } + { BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] } + { DATE [ dup [ timestamp>ymd ] when default-param-value ] } + { TIME [ dup [ timestamp>hms ] when default-param-value ] } + { DATETIME [ dup [ timestamp>ymdhms ] when default-param-value ] } + { TIMESTAMP [ dup [ timestamp>ymdhms ] when default-param-value ] } + [ drop default-param-value ] } case 2array ] 2map flip dup empty? [ drop f f @@ -90,22 +95,20 @@ IN: db.postgresql.lib ] if ; : param-formats ( statement -- seq ) - statement-in-params - [ sql-spec-type type>param-format ] map - >c-uint-array ; + in-params>> [ type>> type>param-format ] map >c-uint-array ; : do-postgresql-bound-statement ( statement -- res ) [ - >r db get db-handle r> + >r db get handle>> r> { - [ statement-sql ] - [ statement-bind-params length ] + [ sql>> ] + [ bind-params>> length ] [ param-types ] [ param-values ] [ param-formats ] } cleave 0 PQexecParams dup postgresql-result-ok? [ - dup postgresql-result-error-message swap PQclear throw + [ postgresql-result-error-message ] [ PQclear ] bi throw ] unless ] with-destructors ; @@ -113,8 +116,8 @@ IN: db.postgresql.lib PQgetisnull 1 = ; : pq-get-string ( handle row column -- obj ) - 3dup PQgetvalue alien>char-string - dup "" = [ >r pq-get-is-null f r> ? ] [ 3nip ] if ; + 3dup PQgetvalue utf8 alien>string + dup empty? [ >r pq-get-is-null f r> ? ] [ 3nip ] if ; : pq-get-number ( handle row column -- obj ) pq-get-string dup [ string>number ] when ; @@ -151,7 +154,8 @@ M: postgresql-malloc-destructor dispose ( obj -- ) : postgresql-column-typed ( handle row column type -- obj ) dup array? [ first ] when { - { +native-id+ [ pq-get-number ] } + { +db-assigned-id+ [ pq-get-number ] } + { +random-id+ [ pq-get-number ] } { INTEGER [ pq-get-number ] } { BIG-INTEGER [ pq-get-number ] } { DOUBLE [ pq-get-number ] } @@ -167,4 +171,3 @@ M: postgresql-malloc-destructor dispose ( obj -- ) dup [ bytes>object ] when ] } [ no-sql-type ] } case ; - ! PQgetlength PQgetisnull diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 322143e7a2..9f747082c6 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -5,19 +5,17 @@ kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi db.tuples db.types tools.annotations math.ranges combinators sequences.lib classes locals words tools.walker -namespaces.lib accessors ; +namespaces.lib accessors random db.queries ; +USE: tools.walker IN: db.postgresql TUPLE: postgresql-db < db host port pgopts pgtty db user pass ; -TUPLE: postgresql-statement < throwable-statement ; +TUPLE: postgresql-statement < statement ; TUPLE: postgresql-result-set < result-set ; -: ( statement in out -- postgresql-statement ) - postgresql-statement construct-statement ; - M: postgresql-db make-db* ( seq tuple -- db ) >r first4 r> swap >>db @@ -42,11 +40,22 @@ M: postgresql-db dispose ( db -- ) M: postgresql-statement bind-statement* ( statement -- ) drop ; +GENERIC: postgresql-bind-conversion ( tuple obj -- low-level-binding ) + +M: sql-spec postgresql-bind-conversion ( tuple spec -- obj ) + slot-name>> swap get-slot-named ; + +M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- obj ) + nip value>> ; + +M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- obj ) + dup generator-singleton>> eval-generator + [ swap slot-name>> rot set-slot-named ] [ ] bi ; + M: postgresql-statement bind-tuple ( tuple statement -- ) - [ - statement-in-params - [ sql-spec-slot-name swap get-slot-named ] with map - ] keep set-statement-bind-params ; + tuck in-params>> + [ postgresql-bind-conversion ] with map + >>bind-params drop ; M: postgresql-result-set #rows ( result-set -- n ) handle>> PQntuples ; @@ -54,15 +63,18 @@ M: postgresql-result-set #rows ( result-set -- n ) M: postgresql-result-set #columns ( result-set -- n ) handle>> PQnfields ; +: result-handle-n ( result-set -- handle n ) + [ handle>> ] [ n>> ] bi ; + M: postgresql-result-set row-column ( result-set column -- obj ) - >r dup result-set-handle swap result-set-n r> pq-get-string ; + >r result-handle-n r> pq-get-string ; M: postgresql-result-set row-column-typed ( result-set column -- obj ) - dup pick result-set-out-params nth sql-spec-type - >r >r [ result-set-handle ] [ result-set-n ] bi r> r> postgresql-column-typed ; + dup pick out-params>> nth type>> + >r >r result-handle-n r> r> postgresql-column-typed ; M: postgresql-statement query-results ( query -- result-set ) - dup statement-bind-params [ + dup bind-params>> [ over [ bind-statement ] keep do-postgresql-bound-statement ] [ @@ -72,67 +84,56 @@ M: postgresql-statement query-results ( query -- result-set ) dup init-result-set ; M: postgresql-result-set advance-row ( result-set -- ) - dup result-set-n 1+ swap set-result-set-n ; + [ 1+ ] change-n drop ; M: postgresql-result-set more-rows? ( result-set -- ? ) - dup result-set-n swap result-set-max < ; + [ n>> ] [ max>> ] bi < ; M: postgresql-statement dispose ( query -- ) - dup statement-handle PQclear - f swap set-statement-handle ; + dup handle>> PQclear + f >>handle drop ; M: postgresql-result-set dispose ( result-set -- ) - dup result-set-handle PQclear - 0 0 f roll { - set-result-set-n set-result-set-max set-result-set-handle - } set-slots ; + [ handle>> PQclear ] + [ + 0 >>n + 0 >>max + f >>handle drop + ] bi ; M: postgresql-statement prepare-statement ( statement -- ) - [ - >r db get handle>> "" r> - dup statement-sql swap statement-in-params - length f PQprepare postgresql-error - ] keep set-statement-handle ; + dup + >r db get handle>> f r> + [ sql>> ] [ in-params>> ] bi + length f PQprepare postgresql-error + >>handle drop ; M: postgresql-db ( sql in out -- statement ) - ; + postgresql-statement construct-statement ; M: postgresql-db ( sql in out -- statement ) - dup prepare-statement ; + dup prepare-statement ; -M: postgresql-db begin-transaction ( -- ) - "BEGIN" sql-command ; - -M: postgresql-db commit-transaction ( -- ) - "COMMIT" sql-command ; - -M: postgresql-db rollback-transaction ( -- ) - "ROLLBACK" sql-command ; - -SYMBOL: postgresql-counter : bind-name% ( -- ) CHAR: $ 0, - postgresql-counter [ inc ] keep get 0# ; + sql-counter [ inc ] [ get 0# ] bi ; M: postgresql-db bind% ( spec -- ) - 1, bind-name% ; + bind-name% 1, ; -: postgresql-make ( class quot -- ) - >r sql-props r> - [ postgresql-counter off call ] { "" { } { } } nmake - ; inline +M: postgresql-db bind# ( spec obj -- ) + >r bind-name% f swap type>> r> 1, ; : create-table-sql ( class -- statement ) [ "create table " 0% 0% - "(" 0% - [ ", " 0% ] [ - dup sql-spec-column-name 0% + "(" 0% [ ", " 0% ] [ + dup column-name>> 0% " " 0% - dup sql-spec-type t lookup-type 0% + dup type>> lookup-create-type 0% modifiers 0% ] interleave ");" 0% - ] postgresql-make ; + ] query-make ; : create-function-sql ( class -- statement ) [ @@ -141,7 +142,7 @@ M: postgresql-db bind% ( spec -- ) "(" 0% over [ "," 0% ] [ - sql-spec-type f lookup-type 0% + type>> lookup-type 0% ] interleave ")" 0% " returns bigint as '" 0% @@ -149,17 +150,17 @@ M: postgresql-db bind% ( spec -- ) "insert into " 0% dup 0% "(" 0% - over [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + over [ ", " 0% ] [ column-name>> 0% ] interleave ") values(" 0% swap [ ", " 0% ] [ drop bind-name% ] interleave "); " 0% "select currval(''" 0% 0% "_id_seq'');' language sql;" 0% - ] postgresql-make ; + ] query-make ; M: postgresql-db create-sql-statement ( class -- seq ) [ [ create-table-sql , ] keep - dup db-columns find-primary-key native-id? + dup db-columns find-primary-key db-assigned-id-spec? [ create-function-sql , ] [ drop ] if ] { } make ; @@ -168,23 +169,23 @@ M: postgresql-db create-sql-statement ( class -- seq ) "drop function add_" 0% 0% "(" 0% remove-id - [ ", " 0% ] [ sql-spec-type f lookup-type 0% ] interleave + [ ", " 0% ] [ type>> lookup-type 0% ] interleave ");" 0% - ] postgresql-make ; + ] query-make ; : drop-table-sql ( table -- statement ) [ "drop table " 0% 0% ";" 0% drop - ] postgresql-make ; + ] query-make ; M: postgresql-db drop-sql-statement ( class -- seq ) [ [ drop-table-sql , ] keep - dup db-columns find-primary-key native-id? + dup db-columns find-primary-key db-assigned-id-spec? [ drop-function-sql , ] [ drop ] if ] { } make ; -M: postgresql-db ( class -- statement ) +M: postgresql-db ( class -- statement ) [ "select add_" 0% 0% "(" 0% @@ -192,107 +193,71 @@ M: postgresql-db ( class -- statement ) remove-id [ ", " 0% ] [ bind% ] interleave ");" 0% - ] postgresql-make ; + ] query-make ; -M: postgresql-db ( class -- statement ) +M: postgresql-db ( class -- statement ) [ "insert into " 0% 0% "(" 0% - dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + dup [ ", " 0% ] [ column-name>> 0% ] interleave ")" 0% " values(" 0% - [ ", " 0% ] [ bind% ] interleave + [ ", " 0% ] [ + dup type>> +random-id+ = [ + [ + bind-name% + slot-name>> + f + random-id-generator + ] [ type>> ] bi 1, + ] [ + bind% + ] if + ] interleave ");" 0% - ] postgresql-make ; + ] query-make ; M: postgresql-db insert-tuple* ( tuple statement -- ) query-modify-tuple ; -M: postgresql-db ( class -- statement ) - [ - "update " 0% 0% - " set " 0% - dup remove-id - [ ", " 0% ] - [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave - " where " 0% - find-primary-key - dup sql-spec-column-name 0% " = " 0% bind% - ] postgresql-make ; - -M: postgresql-db ( class -- statement ) - [ - "delete from " 0% 0% - " where " 0% - find-primary-key - dup sql-spec-column-name 0% " = " 0% bind% - ] postgresql-make ; - -M: postgresql-db ( tuple class -- statement ) - [ - ! tuple columns table - "select " 0% - over [ ", " 0% ] - [ dup sql-spec-column-name 0% 2, ] interleave - - " from " 0% 0% - [ sql-spec-slot-name swap get-slot-named ] with subset - dup empty? [ - drop - ] [ - " where " 0% - [ " and " 0% ] - [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave - ] if ";" 0% - ] postgresql-make ; - -M: postgresql-db type-table ( -- hash ) +M: postgresql-db persistent-table ( -- hashtable ) H{ - { +native-id+ "integer" } - { TEXT "text" } - { VARCHAR "varchar" } - { INTEGER "integer" } - { DOUBLE "real" } - { DATE "date" } - { TIME "time" } - { DATETIME "timestamp" } - { TIMESTAMP "timestamp" } - { BLOB "bytea" } - { FACTOR-BLOB "bytea" } + { +db-assigned-id+ { "integer" "serial primary key" f } } + { +user-assigned-id+ { f f "primary key" } } + { +random-id+ { "bigint" "bigint primary key" f } } + { TEXT { "text" "text" f } } + { VARCHAR { "varchar" "varchar" f } } + { INTEGER { "integer" "integer" f } } + { BIG-INTEGER { "bigint" "bigint" f } } + { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } } + { SIGNED-BIG-INTEGER { "bigint" "bigint" f } } + { DOUBLE { "real" "real" f } } + { DATE { "date" "date" f } } + { TIME { "time" "time" f } } + { DATETIME { "timestamp" "timestamp" f } } + { TIMESTAMP { "timestamp" "timestamp" f } } + { BLOB { "bytea" "bytea" f } } + { FACTOR-BLOB { "bytea" "bytea" f } } + { +foreign-id+ { f f "references" } } + { +autoincrement+ { f f "autoincrement" } } + { +unique+ { f f "unique" } } + { +default+ { f f "default" } } + { +null+ { f f "null" } } + { +not-null+ { f f "not null" } } + { system-random-generator { f f f } } + { secure-random-generator { f f f } } + { random-generator { f f f } } } ; -M: postgresql-db create-type-table ( -- hash ) - H{ - { +native-id+ "serial primary key" } - } ; - -: postgresql-compound ( str n -- newstr ) +M: postgresql-db compound ( str obj -- str' ) over { { "default" [ first number>string join-space ] } { "varchar" [ first number>string paren append ] } { "references" [ first2 >r [ unparse join-space ] keep db-columns r> - swap [ sql-spec-slot-name = ] with find nip - sql-spec-column-name paren append + swap [ slot-name>> = ] with find nip + column-name>> paren append ] } [ "no compound found" 3array throw ] } case ; - -M: postgresql-db compound-modifier ( str seq -- newstr ) - postgresql-compound ; - -M: postgresql-db modifier-table ( -- hashtable ) - H{ - { +native-id+ "primary key" } - { +assigned-id+ "primary key" } - { +foreign-id+ "references" } - { +autoincrement+ "autoincrement" } - { +unique+ "unique" } - { +default+ "default" } - { +null+ "null" } - { +not-null+ "not null" } - } ; - -M: postgresql-db compound-type ( str n -- newstr ) - postgresql-compound ; diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor new file mode 100644 index 0000000000..6dab4f80b8 --- /dev/null +++ b/extra/db/queries/queries.factor @@ -0,0 +1,129 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel math namespaces sequences random +strings +math.bitfields.lib namespaces.lib db db.tuples db.types +math.intervals ; +IN: db.queries + +GENERIC: where ( specs obj -- ) + +: maybe-make-retryable ( statement -- statement ) + dup in-params>> [ generator-bind? ] contains? [ + make-retryable + ] when ; + +: query-make ( class quot -- ) + >r sql-props r> + [ 0 sql-counter rot with-variable ";" 0% ] { "" { } { } } nmake + maybe-make-retryable ; inline + +M: db begin-transaction ( -- ) "BEGIN" sql-command ; +M: db commit-transaction ( -- ) "COMMIT" sql-command ; +M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ; + +: where-primary-key% ( specs -- ) + " where " 0% + find-primary-key dup column-name>> 0% " = " 0% bind% ; + +M: db ( class -- statement ) + [ + "update " 0% 0% + " set " 0% + dup remove-id + [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave + where-primary-key% + ] query-make ; + +M: random-id-generator eval-generator ( singleton -- obj ) + drop + system-random-generator get [ + 63 [ 2^ random ] keep 1 - set-bit + ] with-random ; + +: interval-comparison ( ? str -- str ) + "from" = " >" " <" ? swap [ "= " append ] when ; + +: fp-infinity? ( float -- ? ) + dup float? [ + double>bits -52 shift 11 2^ 1- [ bitand ] keep = + ] [ + drop f + ] if ; + +: (infinite-interval?) ( interval -- ?1 ?2 ) + [ from>> ] [ to>> ] bi + [ first fp-infinity? ] bi@ ; + +: double-infinite-interval? ( obj -- ? ) + dup interval? [ (infinite-interval?) and ] [ drop f ] if ; + +: infinite-interval? ( obj -- ? ) + dup interval? [ (infinite-interval?) or ] [ drop f ] if ; + +: where-interval ( spec obj from/to -- ) + over first fp-infinity? [ + 3drop + ] [ + pick column-name>> 0% + >r first2 r> interval-comparison 0% + bind# + ] if ; + +: in-parens ( quot -- ) + "(" 0% call ")" 0% ; inline + +M: interval where ( spec obj -- ) + [ + [ from>> "from" where-interval ] [ + nip infinite-interval? [ " and " 0% ] unless + ] [ to>> "to" where-interval ] 2tri + ] in-parens ; + +M: sequence where ( spec obj -- ) + [ + [ " or " 0% ] [ dupd where ] interleave drop + ] in-parens ; + +: object-where ( spec obj -- ) + over column-name>> 0% " = " 0% bind# ; + +M: object where ( spec obj -- ) object-where ; + +M: integer where ( spec obj -- ) object-where ; + +M: string where ( spec obj -- ) object-where ; + +: filter-slots ( tuple specs -- specs' ) + [ + slot-name>> swap get-slot-named + dup double-infinite-interval? [ drop f ] when + ] with filter ; + +: where-clause ( tuple specs -- ) + dupd filter-slots + dup empty? [ + 2drop + ] [ + " where " 0% [ + " and " 0% + ] [ + 2dup slot-name>> swap get-slot-named where + ] interleave drop + ] if ; + +M: db ( tuple table -- sql ) + [ + "delete from " 0% 0% + where-clause + ] query-make ; + +M: db ( tuple class -- statement ) + [ + "select " 0% + over [ ", " 0% ] + [ dup column-name>> 0% 2, ] interleave + + " from " 0% 0% + where-clause + ] query-make ; diff --git a/extra/db/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor index 488026fcc7..cab7b83ced 100644 --- a/extra/db/sql/sql-tests.factor +++ b/extra/db/sql/sql-tests.factor @@ -1,7 +1,7 @@ USING: kernel namespaces db.sql sequences math ; IN: db.sql.tests -TUPLE: person name age ; +! TUPLE: person name age ; : insert-1 { insert { table "person" } @@ -28,7 +28,7 @@ TUPLE: person name age ; { select { columns "salary" } { from "staff" } - { where { "branchno" "b003" } } + { where { "branchno" = "b003" } } } } { "branchno" > 3 } } diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor index 26e8429efd..82c6e370bd 100755 --- a/extra/db/sql/sql.factor +++ b/extra/db/sql/sql.factor @@ -1,7 +1,6 @@ -USING: kernel parser quotations classes.tuple words +USING: kernel parser quotations classes.tuple words math.order namespaces.lib namespaces sequences arrays combinators prettyprint strings math.parser sequences.lib math symbols ; -USE: tools.walker IN: db.sql SYMBOLS: insert update delete select distinct columns from as @@ -27,27 +26,27 @@ DEFER: sql% : sql-array% ( array -- ) unclip { - { columns [ "," (sql-interleave) ] } - { from [ "from" "," sql-interleave ] } - { where [ "where" "and" sql-interleave ] } - { group-by [ "group by" "," sql-interleave ] } - { having [ "having" "," sql-interleave ] } - { order-by [ "order by" "," sql-interleave ] } - { offset [ "offset" sql% sql% ] } - { limit [ "limit" sql% sql% ] } - { select [ "(select" sql% sql% ")" sql% ] } - { table [ sql% ] } - { set [ "set" "," sql-interleave ] } - { values [ "values(" sql% "," (sql-interleave) ")" sql% ] } - { count [ "count" sql-function, ] } - { sum [ "sum" sql-function, ] } - { avg [ "avg" sql-function, ] } - { min [ "min" sql-function, ] } - { max [ "max" sql-function, ] } + { \ columns [ "," (sql-interleave) ] } + { \ from [ "from" "," sql-interleave ] } + { \ where [ "where" "and" sql-interleave ] } + { \ group-by [ "group by" "," sql-interleave ] } + { \ having [ "having" "," sql-interleave ] } + { \ order-by [ "order by" "," sql-interleave ] } + { \ offset [ "offset" sql% sql% ] } + { \ limit [ "limit" sql% sql% ] } + { \ select [ "(select" sql% sql% ")" sql% ] } + { \ table [ sql% ] } + { \ set [ "set" "," sql-interleave ] } + { \ values [ "values(" sql% "," (sql-interleave) ")" sql% ] } + { \ count [ "count" sql-function, ] } + { \ sum [ "sum" sql-function, ] } + { \ avg [ "avg" sql-function, ] } + { \ min [ "min" sql-function, ] } + { \ max [ "max" sql-function, ] } [ sql% [ sql% ] each ] } case ; -TUPLE: no-sql-match ; +ERROR: no-sql-match ; : sql% ( obj -- ) { { [ dup string? ] [ " " 0% 0% ] } @@ -55,15 +54,18 @@ TUPLE: no-sql-match ; { [ dup number? ] [ number>string sql% ] } { [ dup symbol? ] [ unparse sql% ] } { [ dup word? ] [ unparse sql% ] } - [ T{ no-sql-match } throw ] + { [ dup quotation? ] [ call ] } + [ no-sql-match ] } cond ; : parse-sql ( obj -- sql in-spec out-spec in out ) [ unclip { - { insert [ "insert into" sql% ] } - { update [ "update" sql% ] } - { delete [ "delete" sql% ] } - { select [ "select" sql% ] } + { \ create [ "create table" sql% ] } + { \ drop [ "drop table" sql% ] } + { \ insert [ "insert into" sql% ] } + { \ update [ "update" sql% ] } + { \ delete [ "delete" sql% ] } + { \ select [ "select" sql% ] } } case [ sql% ] each ] { "" { } { } { } { } } nmake ; diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index c724025874..b443f53e78 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -3,7 +3,7 @@ ! An interface to the sqlite database. Tested against sqlite v3.1.3. ! Not all functions have been wrapped. USING: alien compiler kernel math namespaces sequences strings alien.syntax - system combinators ; + system combinators alien.c-types ; IN: db.sqlite.ffi << "sqlite" { @@ -109,23 +109,31 @@ FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ; FUNCTION: int sqlite3_close ( sqlite3* pDb ) ; FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ; FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ; +FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ; FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ; -FUNCTION: sqlite3_int64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; +FUNCTION: sqlite3_uint64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ; FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ; FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ; +: sqlite3-bind-uint64 ( pStmt index in64 -- int ) + "int" "sqlite" "sqlite3_bind_int64" + { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ; FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ; FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ; FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ; +FUNCTION: int sqlite3_clear_bindings ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ; FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ; +: sqlite3-column-uint64 ( pStmt col -- uint64 ) + "sqlite3_uint64" "sqlite" "sqlite3_column_int64" + { "sqlite3_stmt*" "int" } alien-invoke ; FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index e66accd7e9..e92c4bbd8a 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -4,7 +4,7 @@ USING: alien.c-types arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators continuations db.types calendar.format serialize io.streams.byte-array byte-arrays io.encodings.binary -tools.walker ; +io.backend ; IN: db.sqlite.lib : sqlite-error ( n -- * ) @@ -23,7 +23,8 @@ IN: db.sqlite.lib [ sqlite-error ] } cond ; -: sqlite-open ( filename -- db ) +: sqlite-open ( path -- db ) + normalize-path "void*" [ sqlite3_open sqlite-check-result ] keep *void* ; @@ -32,7 +33,7 @@ IN: db.sqlite.lib : sqlite-prepare ( db sql -- handle ) dup length "void*" "void*" - [ sqlite3_prepare sqlite-check-result ] 2keep + [ sqlite3_prepare_v2 sqlite-check-result ] 2keep drop *void* ; : sqlite-bind-parameter-index ( handle name -- index ) @@ -51,6 +52,9 @@ IN: db.sqlite.lib : sqlite-bind-int64 ( handle i n -- ) sqlite3_bind_int64 sqlite-check-result ; +: sqlite-bind-uint64 ( handle i n -- ) + sqlite3-bind-uint64 sqlite-check-result ; + : sqlite-bind-double ( handle i x -- ) sqlite3_bind_double sqlite-check-result ; @@ -68,7 +72,10 @@ IN: db.sqlite.lib parameter-index sqlite-bind-int ; : sqlite-bind-int64-by-name ( handle name int64 -- ) - parameter-index sqlite-bind-int ; + parameter-index sqlite-bind-int64 ; + +: sqlite-bind-uint64-by-name ( handle name int64 -- ) + parameter-index sqlite-bind-uint64 ; : sqlite-bind-double-by-name ( handle name double -- ) parameter-index sqlite-bind-double ; @@ -85,25 +92,30 @@ IN: db.sqlite.lib { { INTEGER [ sqlite-bind-int-by-name ] } { BIG-INTEGER [ sqlite-bind-int64-by-name ] } + { SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] } + { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] } { TEXT [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] } - { DATE [ sqlite-bind-text-by-name ] } - { TIME [ sqlite-bind-text-by-name ] } - { DATETIME [ sqlite-bind-text-by-name ] } - { TIMESTAMP [ sqlite-bind-text-by-name ] } + { DATE [ timestamp>ymd sqlite-bind-text-by-name ] } + { TIME [ timestamp>hms sqlite-bind-text-by-name ] } + { DATETIME [ timestamp>ymdhms sqlite-bind-text-by-name ] } + { TIMESTAMP [ timestamp>ymdhms sqlite-bind-text-by-name ] } { BLOB [ sqlite-bind-blob-by-name ] } { FACTOR-BLOB [ object>bytes sqlite-bind-blob-by-name ] } - { +native-id+ [ sqlite-bind-int-by-name ] } + { +db-assigned-id+ [ sqlite-bind-int-by-name ] } + { +random-id+ [ sqlite-bind-int64-by-name ] } { NULL [ sqlite-bind-null-by-name ] } [ no-sql-type ] } case ; : sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ; : sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ; +: sqlite-clear-bindings ( handle -- ) + sqlite3_clear_bindings sqlite-check-result ; : sqlite-#columns ( query -- int ) sqlite3_column_count ; : sqlite-column ( handle index -- string ) sqlite3_column_text ; : sqlite-column-name ( handle index -- string ) sqlite3_column_name ; @@ -120,10 +132,12 @@ IN: db.sqlite.lib : sqlite-column-typed ( handle index type -- obj ) dup array? [ first ] when { - { +native-id+ [ sqlite3_column_int64 ] } - { +random-id+ [ sqlite3_column_int64 ] } + { +db-assigned-id+ [ sqlite3_column_int64 ] } + { +random-id+ [ sqlite3-column-uint64 ] } { INTEGER [ sqlite3_column_int ] } { BIG-INTEGER [ sqlite3_column_int64 ] } + { SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] } + { UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] } { DOUBLE [ sqlite3_column_double ] } { TEXT [ sqlite3_column_text ] } { VARCHAR [ sqlite3_column_text ] } diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 11c0150cd2..4aaa9668f0 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -4,8 +4,10 @@ USING: alien arrays assocs classes compiler db hashtables io.files kernel math math.parser namespaces prettyprint sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples -words combinators.lib db.types combinators -io namespaces.lib accessors ; +words combinators.lib db.types combinators math.intervals +io namespaces.lib accessors vectors math.ranges random +math.bitfields.lib db.queries ; +USE: tools.walker IN: db.sqlite TUPLE: sqlite-db < db path ; @@ -19,7 +21,7 @@ M: sqlite-db db-open ( db -- db ) M: sqlite-db db-close ( handle -- ) sqlite-close ; M: sqlite-db dispose ( db -- ) dispose-db ; -TUPLE: sqlite-statement < throwable-statement ; +TUPLE: sqlite-statement < statement ; TUPLE: sqlite-result-set < result-set has-more? ; @@ -42,28 +44,50 @@ M: sqlite-statement dispose ( statement -- ) M: sqlite-result-set dispose ( result-set -- ) f >>handle drop ; -: sqlite-bind ( triples handle -- ) - swap [ first3 sqlite-bind-type ] with each ; - : reset-statement ( statement -- ) sqlite-maybe-prepare handle>> sqlite-reset ; +: reset-bindings ( statement -- ) + sqlite-maybe-prepare + handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ; + +M: sqlite-statement low-level-bind ( statement -- ) + [ statement-bind-params ] [ statement-handle ] bi + swap [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ; + M: sqlite-statement bind-statement* ( statement -- ) sqlite-maybe-prepare - dup statement-bound? [ dup reset-statement ] when - [ statement-bind-params ] [ statement-handle ] bi - sqlite-bind ; + dup statement-bound? [ dup reset-bindings ] when + low-level-bind ; + +GENERIC: sqlite-bind-conversion ( tuple obj -- array ) + +TUPLE: sqlite-low-level-binding < low-level-binding key type ; +: ( key value type -- obj ) + sqlite-low-level-binding new + swap >>type + swap >>value + swap >>key ; + +M: sql-spec sqlite-bind-conversion ( tuple spec -- array ) + [ column-name>> ":" prepend ] + [ slot-name>> rot get-slot-named ] + [ type>> ] tri ; + +M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array ) + nip [ key>> ] [ value>> ] [ type>> ] tri + ; + +M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array ) + tuck + [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi + rot set-slot-named + >r [ key>> ] [ type>> ] bi r> swap ; M: sqlite-statement bind-tuple ( tuple statement -- ) [ - in-params>> - [ - [ column-name>> ":" prepend ] - [ slot-name>> rot get-slot-named ] - [ type>> ] tri 3array - ] with map - ] keep - bind-statement ; + in-params>> [ sqlite-bind-conversion ] with map + ] keep bind-statement ; : last-insert-id ( -- id ) db get db-handle sqlite3_last_insert_rowid @@ -93,120 +117,84 @@ M: sqlite-statement query-results ( query -- result-set ) dup handle>> sqlite-result-set construct-result-set dup advance-row ; -M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; -M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ; -M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; - -: sqlite-make ( class quot -- ) - >r sql-props r> - { "" { } { } } nmake ; inline - M: sqlite-db create-sql-statement ( class -- statement ) [ "create table " 0% 0% "(" 0% [ ", " 0% ] [ dup column-name>> 0% " " 0% - dup type>> t lookup-type 0% + dup type>> lookup-create-type 0% modifiers 0% ] interleave ");" 0% - ] sqlite-make ; + ] query-make ; M: sqlite-db drop-sql-statement ( class -- statement ) - [ "drop table " 0% 0% ";" 0% drop ] sqlite-make ; + [ "drop table " 0% 0% ";" 0% drop ] query-make ; -M: sqlite-db ( tuple -- statement ) +M: sqlite-db ( tuple -- statement ) [ "insert into " 0% 0% "(" 0% - maybe-remove-id + remove-db-assigned-id dup [ ", " 0% ] [ column-name>> 0% ] interleave ") values(" 0% - [ ", " 0% ] [ bind% ] interleave + [ ", " 0% ] [ + dup type>> +random-id+ = [ + [ slot-name>> ] + [ + column-name>> ":" prepend dup 0% + random-id-generator + ] [ type>> ] tri 1, + ] [ + bind% + ] if + ] interleave ");" 0% - ] sqlite-make ; + ] query-make ; -M: sqlite-db ( tuple -- statement ) - ; +M: sqlite-db ( tuple -- statement ) + ; -: where-primary-key% ( specs -- ) - " where " 0% - find-primary-key dup column-name>> 0% " = " 0% bind% ; - -: where-clause ( specs -- ) - " where " 0% - [ " and " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave ; - -M: sqlite-db ( class -- statement ) - [ - "update " 0% - 0% - " set " 0% - dup remove-id - [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave - where-primary-key% - ] sqlite-make ; - -M: sqlite-db ( specs table -- sql ) - [ - "delete from " 0% 0% - " where " 0% - find-primary-key - dup column-name>> 0% " = " 0% bind% - ] sqlite-make ; - -! : select-interval ( interval name -- ) ; -! : select-sequence ( seq name -- ) ; +M: sqlite-db bind# ( spec obj -- ) + >r + [ column-name>> ":" swap next-sql-counter 3append dup 0% ] + [ type>> ] bi + r> 1, ; M: sqlite-db bind% ( spec -- ) dup 1, column-name>> ":" prepend 0% ; -M: sqlite-db ( tuple class -- statement ) - [ - "select " 0% - over [ ", " 0% ] - [ dup column-name>> 0% 2, ] interleave - - " from " 0% 0% - [ slot-name>> swap get-slot-named ] with subset - dup empty? [ drop ] [ where-clause ] if ";" 0% - ] sqlite-make ; - -M: sqlite-db modifier-table ( -- hashtable ) +M: sqlite-db persistent-table ( -- assoc ) H{ - { +native-id+ "primary key" } - { +assigned-id+ "primary key" } - { +random-id+ "primary key" } - ! { +nonnative-id+ "primary key" } - { +autoincrement+ "autoincrement" } - { +unique+ "unique" } - { +default+ "default" } - { +null+ "null" } - { +not-null+ "not null" } + { +db-assigned-id+ { "integer primary key" "integer primary key" "primary key" } } + { +user-assigned-id+ { f f "primary key" } } + { +random-id+ { "integer primary key" "integer primary key" "primary key" } } + { INTEGER { "integer" "integer" "primary key" } } + { BIG-INTEGER { "bigint" "bigint" } } + { SIGNED-BIG-INTEGER { "bigint" "bigint" } } + { UNSIGNED-BIG-INTEGER { "bigint" "bigint" } } + { TEXT { "text" "text" } } + { VARCHAR { "text" "text" } } + { DATE { "date" "date" } } + { TIME { "time" "time" } } + { DATETIME { "datetime" "datetime" } } + { TIMESTAMP { "timestamp" "timestamp" } } + { DOUBLE { "real" "real" } } + { BLOB { "blob" "blob" } } + { FACTOR-BLOB { "blob" "blob" } } + { +autoincrement+ { f f "autoincrement" } } + { +unique+ { f f "unique" } } + { +default+ { f f "default" } } + { +null+ { f f "null" } } + { +not-null+ { f f "not null" } } + { system-random-generator { f f f } } + { secure-random-generator { f f f } } + { random-generator { f f f } } } ; -M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ; - -M: sqlite-db compound-type ( str seq -- str' ) +M: sqlite-db compound ( str seq -- str' ) over { { "default" [ first number>string join-space ] } - [ 2drop ] ! "no sqlite compound data type" 3array throw ] + [ 2drop ] } case ; -M: sqlite-db type-table ( -- assoc ) - H{ - { +native-id+ "integer primary key" } - { +random-id+ "integer primary key" } - { INTEGER "integer" } - { TEXT "text" } - { VARCHAR "text" } - { DATE "date" } - { TIME "time" } - { DATETIME "datetime" } - { TIMESTAMP "timestamp" } - { DOUBLE "real" } - { BLOB "blob" } - { FACTOR-BLOB "blob" } - } ; - -M: sqlite-db create-type-table ( symbol -- str ) type-table ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 951ded32ea..4da82d92d6 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files kernel tools.test db db.tuples -db.types continuations namespaces math -prettyprint tools.walker db.sqlite calendar -math.intervals db.postgresql ; +USING: io.files kernel tools.test db db.tuples classes +db.types continuations namespaces math math.ranges +prettyprint calendar sequences db.sqlite math.intervals +db.postgresql accessors random math.bitfields.lib ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real @@ -21,7 +21,7 @@ ts date time blob factor-blob ; set-person-factor-blob } person construct ; -: ( id name age real ts date time blob factor-blob -- person ) +: ( id name age real ts date time blob factor-blob -- person ) [ set-person-the-id ] keep ; SYMBOL: person1 @@ -30,6 +30,7 @@ SYMBOL: person3 SYMBOL: person4 : test-tuples ( -- ) + [ ] [ person recreate-table ] unit-test [ ] [ person ensure-table ] unit-test [ ] [ person drop-table ] unit-test [ ] [ person create-table ] unit-test @@ -40,7 +41,7 @@ SYMBOL: person4 [ 1 ] [ person1 get person-the-id ] unit-test - 200 person1 get set-person-the-number + [ ] [ 200 person1 get set-person-the-number ] unit-test [ ] [ person1 get update-tuple ] unit-test @@ -67,7 +68,7 @@ SYMBOL: person4 ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test - [ ] [ person1 get delete-tuple ] unit-test + [ ] [ person1 get delete-tuples ] unit-test [ f ] [ T{ person f 1 } select-tuple ] unit-test [ ] [ person3 get insert-tuple ] unit-test @@ -80,9 +81,9 @@ SYMBOL: person4 "teddy" 10 3.14 - T{ timestamp f 2008 3 5 16 24 11 0 } - T{ timestamp f 2008 11 22 f f f f } - T{ timestamp f f f f 12 34 56 f } + T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f 2008 11 22 f f f T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } B{ 115 116 111 114 101 105 110 97 98 108 111 98 } } ] [ T{ person f 3 } select-tuple ] unit-test @@ -96,9 +97,9 @@ SYMBOL: person4 "eddie" 10 3.14 - T{ timestamp f 2008 3 5 16 24 11 0 } - T{ timestamp f 2008 11 22 f f f f } - T{ timestamp f f f f 12 34 56 f } + T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f 2008 11 22 f f f T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } f H{ { 1 2 } { 3 4 } { 5 "lol" } } } @@ -106,17 +107,10 @@ SYMBOL: person4 [ ] [ person drop-table ] unit-test ; -: make-native-person-table ( -- ) - [ person drop-table ] [ drop ] recover - person create-table - T{ person f f "billy" 200 3.14 } insert-tuple - T{ person f f "johnny" 10 3.14 } insert-tuple - ; - -: native-person-schema ( -- ) +: db-assigned-person-schema ( -- ) person "PERSON" { - { "the-id" "ID" +native-id+ } + { "the-id" "ID" +db-assigned-id+ } { "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-number" "AGE" INTEGER { +default+ 0 } } { "the-real" "REAL" DOUBLE { +default+ 0.3 } } @@ -128,13 +122,21 @@ SYMBOL: person4 } define-persistent "billy" 10 3.14 f f f f f person1 set "johnny" 10 3.14 f f f f f person2 set - "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f person3 set - "eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } person4 set ; + "teddy" 10 3.14 + T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } + B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f person3 set + "eddie" 10 3.14 + T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } + f H{ { 1 2 } { 3 4 } { 5 "lol" } } person4 set ; -: assigned-person-schema ( -- ) +: user-assigned-person-schema ( -- ) person "PERSON" { - { "the-id" "ID" INTEGER +assigned-id+ } + { "the-id" "ID" INTEGER +user-assigned-id+ } { "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-number" "AGE" INTEGER { +default+ 0 } } { "the-real" "REAL" DOUBLE { +default+ 0.3 } } @@ -144,18 +146,27 @@ SYMBOL: person4 { "blob" "B" BLOB } { "factor-blob" "FB" FACTOR-BLOB } } define-persistent - 1 "billy" 10 3.14 f f f f f person1 set - 2 "johnny" 10 3.14 f f f f f person2 set - 3 "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f person3 set - 4 "eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } person4 set ; + 1 "billy" 10 3.14 f f f f f person1 set + 2 "johnny" 10 3.14 f f f f f person2 set + 3 "teddy" 10 3.14 + T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } + B{ 115 116 111 114 101 105 110 97 98 108 111 98 } + f person3 set + 4 "eddie" 10 3.14 + T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } + f H{ { 1 2 } { 3 4 } { 5 "lol" } } person4 set ; TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; -: native-paste-schema ( -- ) +: db-assigned-paste-schema ( -- ) paste "PASTE" { - { "n" "ID" +native-id+ } + { "n" "ID" +db-assigned-id+ } { "summary" "SUMMARY" TEXT } { "author" "AUTHOR" TEXT } { "channel" "CHANNEL" TEXT } @@ -167,7 +178,7 @@ TUPLE: annotation n paste-id summary author mode contents ; annotation "ANNOTATION" { - { "n" "ID" +native-id+ } + { "n" "ID" +db-assigned-id+ } { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } } { "summary" "SUMMARY" TEXT } { "author" "AUTHOR" TEXT } @@ -192,7 +203,6 @@ TUPLE: annotation n paste-id summary author mode contents ; : test-repeated-insert [ ] [ person ensure-table ] unit-test - [ ] [ person1 get insert-tuple ] unit-test [ person1 get insert-tuple ] must-fail ; @@ -201,7 +211,7 @@ TUPLE: serialize-me id data ; : test-serialize ( -- ) serialize-me "SERIALIZED" { - { "id" "ID" +native-id+ } + { "id" "ID" +db-assigned-id+ } { "data" "DATA" FACTOR-BLOB } } define-persistent [ serialize-me drop-table ] [ drop ] recover @@ -212,15 +222,12 @@ TUPLE: serialize-me id data ; { T{ serialize-me f 1 H{ { 1 2 } } } } ] [ T{ serialize-me f 1 } select-tuples ] unit-test ; -[ test-serialize ] test-sqlite -! [ test-serialize ] test-postgresql - TUPLE: exam id name score ; -: test-ranges ( -- ) +: test-intervals ( -- ) exam "EXAM" { - { "id" "ID" +native-id+ } + { "id" "ID" +db-assigned-id+ } { "name" "NAME" TEXT } { "score" "SCORE" INTEGER } } define-persistent @@ -233,12 +240,124 @@ TUPLE: exam id name score ; [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test [ - T{ exam f 3 "Kenny" 60 } - T{ exam f 4 "Cartman" 41 } - ] [ T{ exam f 4 f T{ interval f { 0 t } { 70 t } } } select-tuples ] unit-test - ; + { + T{ exam f 3 "Kenny" 60 } + T{ exam f 4 "Cartman" 41 } + } + ] [ + T{ exam f f f T{ interval f { 0 t } { 70 t } } } select-tuples + ] unit-test -! [ test-ranges ] test-sqlite + [ + { } + ] [ + T{ exam f T{ interval f { 3 f } { 4 f } } f } select-tuples + ] unit-test + [ + { + T{ exam f 4 "Cartman" 41 } + } + ] [ + T{ exam f T{ interval f { 3 f } { 4 t } } f } select-tuples + ] unit-test + [ + { + T{ exam f 3 "Kenny" 60 } + } + ] [ + T{ exam f T{ interval f { 3 t } { 4 f } } f } select-tuples + ] unit-test + [ + { + T{ exam f 3 "Kenny" 60 } + T{ exam f 4 "Cartman" 41 } + } + ] [ + T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples + ] unit-test + + [ + { + T{ exam f 1 "Kyle" 100 } + T{ exam f 2 "Stan" 80 } + } + ] [ + T{ exam f f { "Stan" "Kyle" } } select-tuples + ] unit-test + + [ + { + T{ exam f 1 "Kyle" 100 } + T{ exam f 2 "Stan" 80 } + T{ exam f 3 "Kenny" 60 } + } + ] [ + T{ exam f T{ range f 1 3 1 } } select-tuples + ] unit-test + + [ + { + T{ exam f 2 "Stan" 80 } + T{ exam f 3 "Kenny" 60 } + T{ exam f 4 "Cartman" 41 } + } + ] [ + T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples + ] unit-test + + [ + { + T{ exam f 1 "Kyle" 100 } + } + ] [ + T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples + ] unit-test + + [ + { + T{ exam f 1 "Kyle" 100 } + T{ exam f 2 "Stan" 80 } + T{ exam f 3 "Kenny" 60 } + T{ exam f 4 "Cartman" 41 } + } + ] [ + T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples + ] unit-test + + [ + { + T{ exam f 1 "Kyle" 100 } + T{ exam f 2 "Stan" 80 } + T{ exam f 3 "Kenny" 60 } + T{ exam f 4 "Cartman" 41 } + } + ] [ + T{ exam } select-tuples + ] unit-test ; + +TUPLE: bignum-test id m n o ; +: ( m n o -- obj ) + bignum-test new + swap >>o + swap >>n + swap >>m ; + +: test-bignum + bignum-test "BIGNUM_TEST" + { + { "id" "ID" +db-assigned-id+ } + { "m" "M" BIG-INTEGER } + { "n" "N" UNSIGNED-BIG-INTEGER } + { "o" "O" SIGNED-BIG-INTEGER } + } define-persistent + [ bignum-test drop-table ] ignore-errors + [ ] [ bignum-test ensure-table ] unit-test + [ ] [ 63 2^ 1- dup dup insert-tuple ] unit-test ; + + ! sqlite only + ! [ T{ bignum-test f 1 + ! -9223372036854775808 9223372036854775808 -9223372036854775808 } ] + ! [ T{ bignum-test f 1 } select-tuple ] unit-test ; TUPLE: secret n message ; C: secret @@ -246,27 +365,62 @@ C: secret : test-random-id secret "SECRET" { - { "n" "ID" +random-id+ } + { "n" "ID" +random-id+ system-random-generator } { "message" "MESSAGE" TEXT } } define-persistent - [ ] [ secret ensure-table ] unit-test - [ ] [ f "kilroy was here" insert-tuple ] unit-test - [ ] [ T{ secret } select-tuples ] unit-test - ; + [ ] [ secret recreate-table ] unit-test + [ t ] [ f "kilroy was here" [ insert-tuple ] keep n>> integer? ] unit-test + [ ] [ f "kilroy was here2" insert-tuple ] unit-test -! [ test-random-id ] test-sqlite - [ native-person-schema test-tuples ] test-sqlite - [ assigned-person-schema test-tuples ] test-sqlite - [ assigned-person-schema test-repeated-insert ] test-sqlite - [ native-person-schema test-tuples ] test-postgresql - [ assigned-person-schema test-tuples ] test-postgresql - [ assigned-person-schema test-repeated-insert ] test-postgresql + [ ] [ f "kilroy was here3" insert-tuple ] unit-test -! \ insert-tuple must-infer -! \ update-tuple must-infer -! \ delete-tuple must-infer -! \ select-tuple must-infer -! \ define-persistent must-infer + [ t ] [ + T{ secret } select-tuples + first message>> "kilroy was here" head? + ] unit-test + + [ t ] [ + T{ secret } select-tuples length 3 = + ] unit-test ; + +[ db-assigned-person-schema test-tuples ] test-sqlite +[ user-assigned-person-schema test-tuples ] test-sqlite +[ user-assigned-person-schema test-repeated-insert ] test-sqlite +[ test-bignum ] test-sqlite +[ test-serialize ] test-sqlite +[ test-intervals ] test-sqlite +[ test-random-id ] test-sqlite + +[ db-assigned-person-schema test-tuples ] test-postgresql +[ user-assigned-person-schema test-tuples ] test-postgresql +[ user-assigned-person-schema test-repeated-insert ] test-postgresql +[ test-bignum ] test-postgresql +[ test-serialize ] test-postgresql +[ test-intervals ] test-postgresql +[ test-random-id ] test-postgresql + +TUPLE: does-not-persist ; + +[ + [ does-not-persist create-sql-statement ] + [ class \ not-persistent = ] must-fail-with +] test-sqlite + +[ + [ does-not-persist create-sql-statement ] + [ class \ not-persistent = ] must-fail-with +] test-postgresql + +! Don't comment these out. These words must infer +\ bind-tuple must-infer +\ insert-tuple must-infer +\ update-tuple must-infer +\ delete-tuples must-infer +\ select-tuple must-infer +\ define-persistent must-infer +\ ensure-table must-infer +\ create-table must-infer +\ drop-table must-infer diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 311f18daa9..5747fa7de7 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes db kernel namespaces -classes.tuple words sequences slots math +classes.tuple words sequences slots math accessors math.parser io prettyprint db.types continuations -mirrors sequences.lib tools.walker combinators.lib ; +mirrors sequences.lib combinators.lib ; IN: db.tuples : define-persistent ( class table columns -- ) @@ -13,59 +13,94 @@ IN: db.tuples "db-columns" set-word-prop "db-relations" set-word-prop ; -: db-table ( class -- obj ) "db-table" word-prop ; -: db-columns ( class -- obj ) "db-columns" word-prop ; -: db-relations ( class -- obj ) "db-relations" word-prop ; +ERROR: not-persistent ; + +: db-table ( class -- obj ) + "db-table" word-prop [ not-persistent ] unless* ; + +: db-columns ( class -- obj ) + "db-columns" word-prop ; + +: db-relations ( class -- obj ) + "db-relations" word-prop ; : set-primary-key ( key tuple -- ) [ - class db-columns find-primary-key sql-spec-slot-name + class db-columns find-primary-key slot-name>> ] keep set-slot-named ; +SYMBOL: sql-counter +: next-sql-counter ( -- str ) + sql-counter [ inc ] [ get ] bi number>string ; + ! returns a sequence of prepared-statements HOOK: create-sql-statement db ( class -- obj ) HOOK: drop-sql-statement db ( class -- obj ) -HOOK: db ( class -- obj ) -HOOK: db ( class -- obj ) - +HOOK: db ( class -- obj ) +HOOK: db ( class -- obj ) HOOK: db ( class -- obj ) -HOOK: db ( class -- obj ) - -HOOK: db ( class -- obj ) -HOOK: db ( class -- obj ) - +HOOK: db ( tuple class -- obj ) HOOK: db ( tuple class -- tuple ) HOOK: insert-tuple* db ( tuple statement -- ) +GENERIC: eval-generator ( singleton -- obj ) +SINGLETON: retryable + +: make-retryable ( obj -- obj' ) + dup sequence? [ + [ make-retryable ] map + ] [ + retryable >>type + ] if ; + +: regenerate-params ( statement -- statement ) + dup + [ bind-params>> ] [ in-params>> ] bi + [ + dup generator-bind? [ + generator-singleton>> eval-generator >>value + ] [ + drop + ] if + ] 2map >>bind-params ; + +M: retryable execute-statement* ( statement type -- ) + drop + [ + [ query-results dispose t ] + [ ] + [ regenerate-params bind-statement* f ] cleanup + ] curry 10 retry drop ; + : resulting-tuple ( row out-params -- tuple ) - dup first sql-spec-class new [ + dup first class>> new [ [ - >r sql-spec-slot-name r> set-slot-named + >r slot-name>> r> set-slot-named ] curry 2each ] keep ; : query-tuples ( statement -- seq ) - [ statement-out-params ] keep query-results [ + [ out-params>> ] keep query-results [ [ sql-row-typed swap resulting-tuple ] with query-map ] with-disposal ; : query-modify-tuple ( tuple statement -- ) [ query-results [ sql-row-typed ] with-disposal ] keep - statement-out-params rot [ - >r sql-spec-slot-name r> set-slot-named + out-params>> rot [ + >r slot-name>> r> set-slot-named ] curry 2each ; : sql-props ( class -- columns table ) - dup db-columns swap db-table ; + [ db-columns ] [ db-table ] bi ; : with-disposals ( seq quot -- ) over sequence? [ [ with-disposal ] curry each ] [ with-disposal - ] if ; + ] if ; inline : create-table ( class -- ) create-sql-statement [ execute-statement ] with-disposals ; @@ -73,39 +108,38 @@ HOOK: insert-tuple* db ( tuple statement -- ) : drop-table ( class -- ) drop-sql-statement [ execute-statement ] with-disposals ; -: ensure-table ( class -- ) +: recreate-table ( class -- ) [ drop-sql-statement make-nonthrowable [ execute-statement ] with-disposals ] [ create-table ] bi ; -: insert-native ( tuple -- ) +: ensure-table ( class -- ) + [ create-table ] curry ignore-errors ; + +: insert-db-assigned-statement ( tuple -- ) dup class - db get db-insert-statements [ ] cache + db get db-insert-statements [ ] cache [ bind-tuple ] 2keep insert-tuple* ; -: insert-nonnative ( tuple -- ) -! TODO logic here for unique ids +: insert-user-assigned-statement ( tuple -- ) dup class - db get db-insert-statements [ ] cache + db get db-insert-statements [ ] cache [ bind-tuple ] keep execute-statement ; : insert-tuple ( tuple -- ) - dup class db-columns find-primary-key nonnative-id? [ - insert-nonnative - ] [ - insert-native - ] if ; + dup class db-columns find-primary-key db-assigned-id-spec? + [ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ; : update-tuple ( tuple -- ) dup class db get db-update-statements [ ] cache [ bind-tuple ] keep execute-statement ; -: delete-tuple ( tuple -- ) - dup class - db get db-delete-statements [ ] cache - [ bind-tuple ] keep execute-statement ; +: delete-tuples ( tuple -- ) + dup dup class [ + [ bind-tuple ] keep execute-statement + ] with-disposal ; : select-tuples ( tuple -- tuples ) dup dup class [ diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 98bc451a6f..8dbf6786bc 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -2,116 +2,126 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib -words namespaces tools.walker slots slots.private classes -mirrors classes.tuple combinators calendar.format symbols -classes.singleton ; +words namespaces slots slots.private classes mirrors +classes.tuple combinators calendar.format symbols +classes.singleton accessors quotations random ; IN: db.types -HOOK: modifier-table db ( -- hash ) -HOOK: compound-modifier db ( str seq -- hash ) -HOOK: type-table db ( -- hash ) -HOOK: create-type-table db ( -- hash ) -HOOK: compound-type db ( str n -- hash ) +HOOK: persistent-table db ( -- hash ) +HOOK: compound db ( str obj -- hash ) -TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; +TUPLE: sql-spec class slot-name column-name type primary-key modifiers ; -SINGLETON: +native-id+ -SINGLETON: +assigned-id+ +TUPLE: literal-bind key type value ; +C: literal-bind + +TUPLE: generator-bind slot-name key generator-singleton type ; +C: generator-bind +SINGLETON: random-id-generator + +TUPLE: low-level-binding value ; +C: low-level-binding + +SINGLETON: +db-assigned-id+ +SINGLETON: +user-assigned-id+ SINGLETON: +random-id+ -UNION: +primary-key+ +native-id+ +assigned-id+ +random-id+ ; -UNION: +nonnative-id+ +random-id+ +assigned-id+ ; +UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ; SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ +foreign-id+ +has-many+ ; +: find-random-generator ( seq -- obj ) + [ + { + random-generator + system-random-generator + secure-random-generator + } member? + ] find nip [ system-random-generator ] unless* ; + : primary-key? ( spec -- ? ) - sql-spec-primary-key +primary-key+? ; + primary-key>> +primary-key+? ; -: native-id? ( spec -- ? ) - sql-spec-primary-key +native-id+? ; +: db-assigned-id-spec? ( spec -- ? ) + primary-key>> +db-assigned-id+? ; -: nonnative-id? ( spec -- ? ) - sql-spec-primary-key +nonnative-id+? ; +: assigned-id-spec? ( spec -- ? ) + primary-key>> +user-assigned-id+? ; : normalize-spec ( spec -- ) - dup sql-spec-type dup +primary-key+? [ - swap set-sql-spec-primary-key + dup type>> dup +primary-key+? [ + >>primary-key drop ] [ - drop dup sql-spec-modifiers [ + drop dup modifiers>> [ +primary-key+? ] deep-find - [ swap set-sql-spec-primary-key ] [ drop ] if* + [ >>primary-key drop ] [ drop ] if* ] if ; : find-primary-key ( specs -- obj ) - [ sql-spec-primary-key ] find nip ; + [ primary-key>> ] find nip ; : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; -SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR -DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ; +SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER +DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB +FACTOR-BLOB NULL ; : spec>tuple ( class spec -- tuple ) - [ ?first3 ] keep 3 ?tail* - { - set-sql-spec-class - set-sql-spec-slot-name - set-sql-spec-column-name - set-sql-spec-type - set-sql-spec-modifiers - } sql-spec construct + 3 f pad-right + [ first3 ] keep 3 tail + sql-spec new + swap >>modifiers + swap >>type + swap >>column-name + swap >>slot-name + swap >>class dup normalize-spec ; -TUPLE: no-sql-type ; -: no-sql-type ( -- * ) T{ no-sql-type } throw ; - -TUPLE: no-sql-modifier ; -: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ; - : number>string* ( n/str -- str ) dup number? [ number>string ] when ; -: maybe-remove-id ( specs -- obj ) - [ +native-id+? not ] subset ; +: remove-db-assigned-id ( specs -- obj ) + [ +db-assigned-id+? not ] filter ; : remove-relations ( specs -- newcolumns ) - [ relation? not ] subset ; + [ relation? not ] filter ; : remove-id ( specs -- obj ) - [ sql-spec-primary-key not ] subset ; + [ primary-key>> not ] filter ; ! SQLite Types: http://www.sqlite.org/datatype3.html ! NULL INTEGER REAL TEXT BLOB ! PostgreSQL Types: ! http://developer.postgresql.org/pgdocs/postgres/datatype.html -: lookup-modifier ( obj -- str ) - dup array? [ - unclip lookup-modifier swap compound-modifier - ] [ - modifier-table at* - [ "unknown modifier" throw ] unless - ] if ; +ERROR: unknown-modifier ; -: lookup-type* ( obj -- str ) +: lookup-modifier ( obj -- str ) + { + { [ dup array? ] [ unclip lookup-modifier swap compound ] } + [ persistent-table at* [ unknown-modifier ] unless third ] + } cond ; + +ERROR: no-sql-type ; + +: (lookup-type) ( obj -- str ) + persistent-table at* [ no-sql-type ] unless ; + +: lookup-type ( obj -- str ) dup array? [ - first lookup-type* + unclip (lookup-type) first nip ] [ - type-table at* - [ no-sql-type ] unless + (lookup-type) first ] if ; : lookup-create-type ( obj -- str ) dup array? [ - unclip lookup-create-type swap compound-type + unclip (lookup-type) second swap compound ] [ - dup create-type-table at* - [ nip ] [ drop lookup-type* ] if + (lookup-type) second ] if ; -: lookup-type ( obj create? -- str ) - [ lookup-create-type ] [ lookup-type* ] if ; - : single-quote ( str -- newstr ) "'" swap "'" 3append ; @@ -125,11 +135,11 @@ TUPLE: no-sql-modifier ; " " swap 3append ; : modifiers ( spec -- str ) - sql-spec-modifiers - [ lookup-modifier ] map " " join + modifiers>> [ lookup-modifier ] map " " join dup empty? [ " " prepend ] unless ; HOOK: bind% db ( spec -- ) +HOOK: bind# db ( spec obj -- ) : offset-of-slot ( str obj -- n ) class "slots" word-prop slot-named slot-spec-offset ; @@ -141,10 +151,10 @@ HOOK: bind% db ( spec -- ) tuck offset-of-slot set-slot ; : tuple>filled-slots ( tuple -- alist ) - [ nip ] assoc-subset ; + [ nip ] assoc-filter ; : tuple>params ( specs tuple -- obj ) [ - >r dup sql-spec-type swap sql-spec-slot-name r> + >r [ type>> ] [ slot-name>> ] bi r> get-slot-named swap ] curry { } map>assoc ; diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 677375a970..59e2210ae0 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -54,11 +54,11 @@ M: tuple-class group-words >r protocol-words r> diff ; : forget-old-definitions ( protocol new-wordlist -- ) - values [ drop protocol-users ] [ lost-words ] 2bi - forget-all-methods ; + >r users-and-words r> + swap diff forget-all-methods ; : added-words ( protocol wordlist -- added-words ) - swap protocol-words diff ; + swap protocol-words swap diff ; : add-new-definitions ( protocol wordlist -- ) dupd added-words >r protocol-consult >alist r> diff --git a/extra/documents/documents.factor b/extra/documents/documents.factor index 4fa4ed3c09..435a0aca55 100755 --- a/extra/documents/documents.factor +++ b/extra/documents/documents.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays io kernel math models namespaces sequences strings -splitting combinators unicode.categories ; +splitting combinators unicode.categories math.order ; IN: documents : +col ( loc n -- newloc ) >r first2 r> + 2array ; @@ -184,10 +184,10 @@ M: one-char-elt next-elt 2drop ; [ >r blank? r> xor ] curry ; inline : (prev-word) ( ? col str -- col ) - rot break-detector find-last* drop ?1+ ; + rot break-detector find-last-from drop ?1+ ; : (next-word) ( ? col str -- col ) - [ rot break-detector find* drop ] keep + [ rot break-detector find-from drop ] keep over not [ nip length ] [ drop ] if ; TUPLE: one-word-elt ; diff --git a/extra/editors/vim/vim.factor b/extra/editors/vim/vim.factor index 8d60942d67..9ce256868b 100755 --- a/extra/editors/vim/vim.factor +++ b/extra/editors/vim/vim.factor @@ -1,5 +1,5 @@ USING: definitions io io.launcher kernel math math.parser -namespaces parser prettyprint sequences editors ; +namespaces parser prettyprint sequences editors accessors ; IN: editors.vim SYMBOL: vim-path @@ -17,8 +17,9 @@ M: vim vim-command ( file line -- array ) : vim-location ( file line -- ) vim-command - vim-detach get-global - [ run-detached ] [ run-process ] if drop ; + swap >>command + vim-detach get-global [ t >>detached ] when + try-process ; "vim" vim-path set-global [ vim-location ] edit-hook set-global diff --git a/extra/factory/commands/commands.factor b/extra/factory/commands/commands.factor index 5b0c575771..6bf5ee8d4f 100644 --- a/extra/factory/commands/commands.factor +++ b/extra/factory/commands/commands.factor @@ -35,7 +35,7 @@ pointer-window up-till-frame dup is? [ ] [ drop f ] if ; wm-root> <- children - [ <- mapped? ] subset + [ <- mapped? ] filter [ check-window-table ] map reverse @@ -64,7 +64,7 @@ drop ! wm-root> ! <- children -! [ <- mapped? ] subset +! [ <- mapped? ] filter ! [ check-window-table ] map ! reverse diff --git a/extra/factory/factory.factor b/extra/factory/factory.factor index ca534f12c1..6faf334fc3 100644 --- a/extra/factory/factory.factor +++ b/extra/factory/factory.factor @@ -13,7 +13,7 @@ IN: factory ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : manage-windows ( -- ) -dpy get $default-root <- children [ <- mapped? ] subset +dpy get $default-root <- children [ <- mapped? ] filter [ $id new* drop ] each ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor index 1022a02d7e..3cb17cf08b 100644 --- a/extra/faq/faq.factor +++ b/extra/faq/faq.factor @@ -16,7 +16,7 @@ TUPLE: q/a question answer ; C: q/a : li>q/a ( li -- q/a ) - [ "br" tag-named*? not ] subset + [ "br" tag-named*? not ] filter [ "strong" tag-named*? ] find-after >r tag-children r> ; @@ -39,7 +39,7 @@ C: question-list : xml>question-list ( list -- question-list ) [ "title" swap at ] keep - tag-children [ tag? ] subset [ xml>q/a ] map + tag-children [ tag? ] filter [ xml>q/a ] map ; : question-list>xml ( question-list -- list ) @@ -85,7 +85,7 @@ C: faq : toc, ( faq -- ) "div" { { "style" "background-color: #eee; margin-left: 30%; margin-right: 30%; width: auto; padding: 5px; margin-top: 1em; margin-bottom: 1em" } } [ "strong" [ "The big questions" , ] tag, br, - faq-lists 1 tail dup length [ toc-link, ] 2each + faq-lists rest dup length [ toc-link, ] 2each ] tag*, ; : faq-sections, ( question-lists -- ) diff --git a/core/float-vectors/float-vectors-docs.factor b/extra/float-vectors/float-vectors-docs.factor similarity index 76% rename from core/float-vectors/float-vectors-docs.factor rename to extra/float-vectors/float-vectors-docs.factor index ef0645a0af..5e06f05a2b 100755 --- a/core/float-vectors/float-vectors-docs.factor +++ b/extra/float-vectors/float-vectors-docs.factor @@ -3,7 +3,7 @@ float-vectors.private combinators ; IN: float-vectors ARTICLE: "float-vectors" "Float vectors" -"A float vector is a resizable mutable sequence of unsigned floats. The literal syntax is covered in " { $link "syntax-float-vectors" } ". Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary." +"A float vector is a resizable mutable sequence of unsigned floats. Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary." $nl "Float vectors form a class:" { $subsection float-vector } @@ -11,13 +11,15 @@ $nl "Creating float vectors:" { $subsection >float-vector } { $subsection } +"Literal syntax:" +{ $subsection POSTPONE: FV{ } "If you don't care about initial capacity, a more elegant way to create a new float vector is to write:" { $code "FV{ } clone" } ; ABOUT: "float-vectors" HELP: float-vector -{ $description "The class of resizable float vectors. See " { $link "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general information." } ; +{ $description "The class of resizable float vectors. See " { $link "float-vectors" } " for information." } ; HELP: { $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } } @@ -32,3 +34,9 @@ HELP: float-array>vector { $values { "float-array" "an array" } { "length" "a non-negative integer" } { "float-vector" float-vector } } { $description "Creates a new float vector using the array for underlying storage with the specified initial length." } { $warning "This word is in the " { $vocab-link "float-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >float-vector } " instead." } ; + +HELP: FV{ +{ $syntax "FV{ elements... }" } +{ $values { "elements" "a list of real numbers" } } +{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." } +{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ; diff --git a/core/float-vectors/float-vectors-tests.factor b/extra/float-vectors/float-vectors-tests.factor similarity index 100% rename from core/float-vectors/float-vectors-tests.factor rename to extra/float-vectors/float-vectors-tests.factor diff --git a/core/float-vectors/float-vectors.factor b/extra/float-vectors/float-vectors.factor similarity index 56% rename from core/float-vectors/float-vectors.factor rename to extra/float-vectors/float-vectors.factor index 7f62f6f95c..d51f0d4e44 100755 --- a/core/float-vectors/float-vectors.factor +++ b/extra/float-vectors/float-vectors.factor @@ -1,9 +1,20 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences -sequences.private growable float-arrays ; +sequences.private growable float-arrays prettyprint.backend +parser accessors ; IN: float-vectors +TUPLE: float-vector underlying fill ; + +M: float-vector underlying underlying>> { float-array } declare ; + +M: float-vector set-underlying (>>underlying) ; + +M: float-vector length fill>> { array-capacity } declare ; + +M: float-vector set-fill (>>fill) ; + vector ( float-array length -- float-vector ) @@ -14,7 +25,8 @@ PRIVATE> : ( n -- float-vector ) 0.0 0 float-array>vector ; inline -: >float-vector ( seq -- float-vector ) FV{ } clone-like ; +: >float-vector ( seq -- float-vector ) + T{ float-vector f F{ } 0 } clone-like ; M: float-vector like drop dup float-vector? [ @@ -31,3 +43,9 @@ M: float-vector equal? M: float-array new-resizable drop ; INSTANCE: float-vector growable + +: FV{ \ } [ >float-vector ] parse-literal ; parsing + +M: float-vector >pprint-sequence ; + +M: float-vector pprint-delims drop \ FV{ \ } ; diff --git a/core/float-vectors/summary.txt b/extra/float-vectors/summary.txt similarity index 100% rename from core/float-vectors/summary.txt rename to extra/float-vectors/summary.txt diff --git a/extra/float-vectors/tags.txt b/extra/float-vectors/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/float-vectors/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/fry/fry-tests.factor b/extra/fry/fry-tests.factor index 4d2c9fe1c8..7586e254b2 100755 --- a/extra/fry/fry-tests.factor +++ b/extra/fry/fry-tests.factor @@ -44,3 +44,7 @@ sequences ; : funny-dip '[ @ _ ] call ; inline [ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test + +[ { 1 2 3 } ] [ + 3 1 '[ , [ , + ] map ] call +] unit-test diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor index 6c20aac7f2..1b9e2dc82b 100755 --- a/extra/fry/fry.factor +++ b/extra/fry/fry.factor @@ -9,41 +9,54 @@ IN: fry : @ "Only valid inside a fry" throw ; : _ "Only valid inside a fry" throw ; -DEFER: (fry) +DEFER: (shallow-fry) -: ((fry)) ( accum quot adder -- result ) - >r [ ] swap (fry) r> +: ((shallow-fry)) ( accum quot adder -- result ) + >r [ ] swap (shallow-fry) r> append swap dup empty? [ drop ] [ - [ swap compose ] curry append + [ prepose ] curry append ] if ; inline -: (fry) ( accum quot -- result ) +: (shallow-fry) ( accum quot -- result ) dup empty? [ drop 1quotation ] [ unclip { - { \ , [ [ curry ] ((fry)) ] } - { \ @ [ [ compose ] ((fry)) ] } + { \ , [ [ curry ] ((shallow-fry)) ] } + { \ @ [ [ compose ] ((shallow-fry)) ] } ! to avoid confusion, remove if fry goes core - { \ namespaces:, [ [ curry ] ((fry)) ] } + { \ namespaces:, [ [ curry ] ((shallow-fry)) ] } - [ swap >r suffix r> (fry) ] + [ swap >r suffix r> (shallow-fry) ] } case ] if ; -: trivial-fry ( quot -- quot' ) [ ] swap (fry) ; +: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ; -: fry ( quot -- quot' ) +: deep-fry ( quot -- quot' ) { _ } last-split1 [ [ - trivial-fry % + shallow-fry % [ >r ] % - fry % + deep-fry % [ [ dip ] curry r> compose ] % ] [ ] make ] [ - trivial-fry + shallow-fry ] if* ; +: fry ( quot -- quot' ) + [ + [ + dup callable? [ + [ + [ { , namespaces:, @ } member? ] filter length + \ , % + ] + [ deep-fry % ] bi + ] [ namespaces:, ] if + ] each + ] [ ] make deep-fry ; + : '[ \ ] parse-until fry over push-all ; parsing diff --git a/extra/gap-buffer/gap-buffer.factor b/extra/gap-buffer/gap-buffer.factor index d3b946afe9..55a1276dd4 100644 --- a/extra/gap-buffer/gap-buffer.factor +++ b/extra/gap-buffer/gap-buffer.factor @@ -4,7 +4,8 @@ ! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain ! for a good introduction see: ! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf -USING: kernel arrays sequences sequences.private circular math math.functions generic ; +USING: kernel arrays sequences sequences.private circular math +math.order math.functions generic ; IN: gap-buffer ! gap-start -- the first element of the gap diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index 861894c8f4..611319e28b 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays byte-arrays combinators -graphics.viewer io io.binary io.files kernel libc math -math.functions namespaces opengl opengl.gl prettyprint +USING: alien arrays byte-arrays combinators inspector +io.backend graphics.viewer io io.binary io.files kernel libc +math math.functions namespaces opengl opengl.gl prettyprint sequences strings ui ui.gadgets.panes io.encodings.binary ; IN: graphics.bitmap @@ -25,10 +25,14 @@ TUPLE: bitmap magic size reserved offset header-length width { 1 [ "1bit" throw ] } } case ; +ERROR: bitmap-magic ; + +M: bitmap-magic summary + drop "First two bytes of bitmap stream must be 'BM'" ; + : parse-file-header ( bitmap -- ) - 2 read [ over set-bitmap-magic ] keep "BM" = [ - "BITMAPFILEHEADER: First two bytes must be BM" throw - ] unless + 2 read >string dup "BM" = [ bitmap-magic ] unless + over set-bitmap-magic 4 read le> over set-bitmap-size 4 read le> over set-bitmap-reserved 4 read le> swap set-bitmap-offset ; @@ -59,7 +63,7 @@ TUPLE: bitmap magic size reserved offset header-length width dup color-index-length read swap set-bitmap-color-index ; : load-bitmap ( path -- bitmap ) - binary [ + normalize-path binary [ T{ bitmap } clone dup parse-file-header dup parse-bitmap-header @@ -113,20 +117,18 @@ M: bitmap height ( bitmap -- ) bitmap-height ; : bitmap. ( path -- ) load-bitmap gadget. ; -: bitmap-window ( path -- ) - load-bitmap [ "bitmap" open-window ] keep ; +: bitmap-window ( path -- gadget ) + load-bitmap [ "bitmap" open-window ] keep ; : test-bitmap24 ( -- ) - "extra/graphics/bitmap/test-data/thiswayup24.bmp" resource-path bitmap. ; + "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ; : test-bitmap8 ( -- ) - "extra/graphics/bitmap/test-data/rgb8bit.bmp" resource-path bitmap. ; + "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ; : test-bitmap4 ( -- ) - "extra/graphics/bitmap/test-data/rgb4bit.bmp" resource-path - load-bitmap ; - ! bitmap. ; + "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ; : test-bitmap1 ( -- ) - "extra/graphics/bitmap/test-data/1bit.bmp" resource-path bitmap. ; + "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ; diff --git a/extra/hardware-info/linux/linux.factor b/extra/hardware-info/linux/linux.factor index de7b3f40a5..5d9ca6eaa7 100644 --- a/extra/hardware-info/linux/linux.factor +++ b/extra/hardware-info/linux/linux.factor @@ -7,7 +7,7 @@ IN: hardware-info.linux : uname ( -- seq ) 65536 "char" [ (uname) io-error ] keep - "\0" split [ empty? not ] subset [ >string ] map + "\0" split [ empty? not ] filter [ >string ] map 6 "" pad-right ; : sysname ( -- string ) uname first ; @@ -18,4 +18,4 @@ IN: hardware-info.linux : domainname ( -- string ) uname 5 swap nth ; : kernel-version ( -- seq ) - release ".-" split [ ] subset 5 "" pad-right ; + release ".-" split [ ] filter 5 "" pad-right ; diff --git a/extra/hardware-info/macosx/macosx.factor b/extra/hardware-info/macosx/macosx.factor index 91838d2a53..fe1fd72a21 100644 --- a/extra/hardware-info/macosx/macosx.factor +++ b/extra/hardware-info/macosx/macosx.factor @@ -1,6 +1,7 @@ -USING: alien alien.c-types alien.syntax byte-arrays kernel -namespaces sequences unix hardware-info.backend system -io.unix.backend ; +USING: alien alien.c-types alien.strings alien.syntax +byte-arrays kernel namespaces sequences unix +hardware-info.backend system io.unix.backend io.encodings.ascii +; IN: hardware-info.macosx ! See /usr/include/sys/sysctl.h for constants @@ -19,7 +20,7 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi [ ] [ ] bi (sysctl-query) ; : sysctl-query-string ( seq -- n ) - 4096 sysctl-query alien>char-string ; + 4096 sysctl-query ascii malloc-string ; : sysctl-query-uint ( seq -- n ) 4 sysctl-query *uint ; diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor index ba9c1d74b5..2599a33754 100755 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -1,4 +1,4 @@ -USING: alien alien.c-types +USING: alien alien.c-types alien.strings kernel libc math namespaces hardware-info.backend windows windows.advapi32 windows.kernel32 system ; IN: hardware-info.windows.nt @@ -35,12 +35,14 @@ M: winnt total-virtual-mem ( -- n ) M: winnt available-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailVirtual ; +: pull-win32-string [ utf16n alien>string ] keep free ; + : computer-name ( -- string ) MAX_COMPUTERNAME_LENGTH 1+ [ malloc ] keep dupd GetComputerName zero? [ free win32-error f ] [ - [ alien>u16-string ] keep free + pull-win32-string ] if ; : username ( -- string ) @@ -48,5 +50,5 @@ M: winnt available-virtual-mem ( -- n ) dupd GetUserName zero? [ free win32-error f ] [ - [ alien>u16-string ] keep free + pull-win32-string ] if ; diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index 807fd158ba..3162496974 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -1,7 +1,7 @@ USING: alien alien.c-types kernel libc math namespaces windows windows.kernel32 windows.advapi32 words combinators vocabs.loader hardware-info.backend -system ; +system alien.strings ; IN: hardware-info.windows : system-info ( -- SYSTEM_INFO ) @@ -36,7 +36,7 @@ IN: hardware-info.windows os-version OSVERSIONINFO-dwPlatformId ; : windows-service-pack ( -- string ) - os-version OSVERSIONINFO-szCSDVersion alien>u16-string ; + os-version OSVERSIONINFO-szCSDVersion utf16n alien>string ; : feature-present? ( n -- ? ) IsProcessorFeaturePresent zero? not ; @@ -52,7 +52,7 @@ IN: hardware-info.windows : get-directory ( word -- str ) >r MAX_UNICODE_PATH [ ] keep dupd r> - execute win32-error=0/f alien>u16-string ; inline + execute win32-error=0/f utf16n alien>string ; inline : windows-directory ( -- str ) \ GetWindowsDirectory get-directory ; diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index 9b21bf7fff..995b8540f5 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -111,7 +111,7 @@ $nl "You can create a new array, only containing elements which satisfy some condition:" { $example ": negative? ( n -- ? ) 0 < ;" - "{ -12 10 16 0 -1 -3 -9 } [ negative? ] subset ." + "{ -12 10 16 0 -1 -3 -9 } [ negative? ] filter ." "{ -12 -1 -3 -9 }" } { $references diff --git a/extra/help/crossref/crossref.factor b/extra/help/crossref/crossref.factor index 0b17461a99..54ede93aa1 100644 --- a/extra/help/crossref/crossref.factor +++ b/extra/help/crossref/crossref.factor @@ -14,7 +14,7 @@ M: link uses collect-elements [ \ f or ] map ; : help-path ( topic -- seq ) - [ article-parent ] follow 1 tail ; + [ article-parent ] follow rest ; : set-article-parents ( parent article -- ) article-children [ set-article-parent ] with each ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 4e6bfe4888..ce875b32d1 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -104,6 +104,7 @@ $nl ARTICLE: "objects" "Objects" "An " { $emphasis "object" } " is any datum which may be identified. All values are objects in Factor. Each object carries type information, and types are checked at runtime; Factor is dynamically typed." { $subsection "equality" } +{ $subsection "math.order" } { $subsection "classes" } { $subsection "tuples" } { $subsection "generic" } @@ -145,9 +146,9 @@ ARTICLE: "collections" "Collections" { $subsection "vectors" } "Resizable specialized sequences:" { $subsection "sbufs" } -{ $subsection "bit-vectors" } -{ $subsection "byte-vectors" } -{ $subsection "float-vectors" } +{ $vocab-subsection "Bit vectors" "bit-vectors" } +{ $vocab-subsection "Byte vectors" "byte-vectors" } +{ $vocab-subsection "Float vectors" "float-vectors" } { $heading "Associative mappings" } { $subsection "assocs" } { $subsection "namespaces" } @@ -163,7 +164,7 @@ ARTICLE: "collections" "Collections" { $subsection "buffers" } ; USING: io.sockets io.launcher io.mmap io.monitors -io.encodings.utf8 io.encodings.binary io.encodings.ascii io.files ; +io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ; ARTICLE: "encodings-introduction" "An introduction to encodings" "In order to express text in terms of binary, some sort of encoding has to be used. In a modern context, this is understood as a two-way mapping between Unicode code points (characters) and some amount of binary. Since English isn't the only language in the world, ASCII is not sufficient as a mapping from binary to Unicode; it can't even express em-dashes or curly quotes. Unicode was designed as a universal character set that could potentially represent everything." $nl @@ -228,13 +229,13 @@ ARTICLE: "article-index" "Article index" { $index [ articles get keys ] } ; ARTICLE: "primitive-index" "Primitive index" -{ $index [ all-words [ primitive? ] subset ] } ; +{ $index [ all-words [ primitive? ] filter ] } ; ARTICLE: "error-index" "Error index" { $index [ all-errors ] } ; ARTICLE: "type-index" "Type index" -{ $index [ builtins get [ ] subset ] } ; +{ $index [ builtins get [ ] filter ] } ; ARTICLE: "class-index" "Class index" { $index [ classes ] } ; diff --git a/extra/help/help-docs.factor b/extra/help/help-docs.factor index 1d2af5fb39..d4981751e2 100755 --- a/extra/help/help-docs.factor +++ b/extra/help/help-docs.factor @@ -113,7 +113,7 @@ ARTICLE: "help" "Help system" "The help system maintains documentation written in a simple markup language, along with cross-referencing and search. Documentation can either exist as free-standing " { $emphasis "articles" } " or be associated with words." { $subsection "browsing-help" } { $subsection "writing-help" } -{ $subsection "help.lint" } +{ $vocab-subsection "Help lint tool" "help.lint" } { $subsection "help-impl" } ; IN: help diff --git a/extra/help/help.factor b/extra/help/help.factor index aa2704a799..2d56251392 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -29,7 +29,7 @@ M: predicate word-help* drop \ $predicate ; : all-articles ( -- seq ) articles get keys - all-words [ word-help ] subset append ; + all-words [ word-help ] filter append ; : xref-help ( -- ) all-articles [ xref-article ] each ; @@ -38,10 +38,10 @@ M: predicate word-help* drop \ $predicate ; \ $error-description swap word-help elements empty? not ; : sort-articles ( seq -- newseq ) - [ dup article-title ] { } map>assoc sort-values 0 ; + [ dup article-title ] { } map>assoc sort-values keys ; : all-errors ( -- seq ) - all-words [ error? ] subset sort-articles ; + all-words [ error? ] filter sort-articles ; M: word article-name word-name ; @@ -135,7 +135,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; ":vars - list all variables at error time" print ; : :help ( -- ) - error get delegates [ error-help ] map [ ] subset + error get delegates [ error-help ] map [ ] filter { { [ dup empty? ] [ (:help-none) ] } { [ dup length 1 = ] [ first help ] } diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index 28af93f295..fc4b7f6f25 100755 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -9,7 +9,7 @@ macros combinators.lib sequences.lib math sets ; IN: help.lint : check-example ( element -- ) - 1 tail [ + rest [ 1 head* "\n" join 1vector [ use [ clone ] change @@ -23,7 +23,7 @@ IN: help.lint : extract-values ( element -- seq ) \ $values swap elements dup empty? [ - first 1 tail [ first ] map prune natural-sort + first rest [ first ] map prune natural-sort ] unless ; : effect-values ( word -- seq ) @@ -59,7 +59,7 @@ IN: help.lint : check-see-also ( word element -- ) nip \ $see-also swap elements [ - 1 tail dup prune [ length ] bi@ assert= + rest dup prune [ length ] bi@ assert= ] each ; : vocab-exists? ( name -- ? ) @@ -75,7 +75,7 @@ IN: help.lint [ help ] with-string-writer drop ; : all-word-help ( words -- seq ) - [ word-help ] subset ; + [ word-help ] filter ; TUPLE: help-error topic ; @@ -131,7 +131,7 @@ M: help-error error. articles get keys "group-articles" set child-vocabs [ dup check-vocab ] { } map>assoc - [ nip empty? not ] assoc-subset + [ nip empty? not ] assoc-filter ] with-scope ; : typos. ( assoc -- ) @@ -150,12 +150,12 @@ M: help-error error. : help-lint-all ( -- ) "" help-lint ; : unlinked-words ( words -- seq ) - all-word-help [ article-parent not ] subset ; + all-word-help [ article-parent not ] filter ; : linked-undocumented-words ( -- seq ) all-words - [ word-help not ] subset - [ article-parent ] subset - [ "predicating" word-prop not ] subset ; + [ word-help not ] filter + [ article-parent ] filter + [ "predicating" word-prop not ] filter ; MAIN: help-lint diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 2e2b34ebfd..378dd1e2fe 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -311,7 +311,7 @@ M: array elements* [ swap [ elements [ - 1 tail [ dup set ] each + rest [ dup set ] each ] each ] curry each ] H{ } make-assoc keys ; diff --git a/extra/help/tutorial/tutorial.factor b/extra/help/tutorial/tutorial.factor index f01840d927..fffcda69b6 100755 --- a/extra/help/tutorial/tutorial.factor +++ b/extra/help/tutorial/tutorial.factor @@ -123,8 +123,8 @@ $nl { $code "\"A man, a plan, a canal: Panama.\"" } "Now, place a quotation containing " { $link Letter? } " on the stack; quoting code places it on the stack instead of executing it immediately:" { $code "[ Letter? ]" } -"Finally, pass the string and the quotation to the " { $link subset } " word:" -{ $code "subset" } +"Finally, pass the string and the quotation to the " { $link filter } " word:" +{ $code "filter" } "Now the stack should contain the following string:" { "\"AmanaplanacanalPanama\"" } "This is almost what we want; we just need to convert the string to lower case now. This can be done by calling " { $link >lower } "; the " { $snippet ">" } " prefix is a naming convention for conversion operations, and should be read as ``to'':" @@ -132,9 +132,9 @@ $nl "Finally, let's print the top of the stack and discard it:" { $code "." } "This will output " { $snippet "amanaplanacanalpanama" } ". This string is in the form that we want, and we evaluated the following code to get it into this form:" -{ $code "[ Letter? ] subset >lower" } +{ $code "[ Letter? ] filter >lower" } "This code starts with a string on the stack, removes non-alphabetical characters, and converts the result to lower case, leaving a new string on the stack. We put this code in a new word, and add the new word to " { $snippet "palindrome.factor" } ":" -{ $code ": normalize ( str -- newstr ) [ Letter? ] subset >lower ;" } +{ $code ": normalize ( str -- newstr ) [ Letter? ] filter >lower ;" } "You will need to add " { $vocab-link "unicode.categories" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file." $nl "We modify " { $snippet "palindrome?" } " to first apply " { $snippet "normalize" } " to its input:" diff --git a/extra/html/html.factor b/extra/html/html.factor index 5c82b7f038..f0ae424760 100755 --- a/extra/html/html.factor +++ b/extra/html/html.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: generic assocs help http io io.styles io.files continuations -io.streams.string kernel math math.parser namespaces +io.streams.string kernel math math.order math.parser namespaces quotations assocs sequences strings words html.elements xml.entities sbufs continuations ; IN: html diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 1a60390f64..160b95ab1d 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -11,7 +11,7 @@ IN: html.parser.analyzer (find-relative) ; : (find-all) ( n seq quot -- ) - 2dup >r >r find* [ + 2dup >r >r find-from [ dupd 2array , 1+ r> r> (find-all) ] [ r> r> 3drop @@ -21,7 +21,7 @@ IN: html.parser.analyzer [ 0 -rot (find-all) ] { } make ; : (find-nth) ( offset seq quot n count -- obj ) - >r >r [ find* ] 2keep 4 npick [ + >r >r [ find-from ] 2keep 4 npick [ r> r> 1+ 2dup <= [ 4drop ] [ @@ -46,7 +46,7 @@ IN: html.parser.analyzer ] [ drop t ] if - ] subset ; + ] filter ; : trim-text ( vector -- vector' ) [ @@ -57,14 +57,14 @@ IN: html.parser.analyzer ] map ; : find-by-id ( id vector -- vector ) - [ tag-attributes "id" swap at = ] with subset ; + [ tag-attributes "id" swap at = ] with filter ; : find-by-class ( id vector -- vector ) - [ tag-attributes "class" swap at = ] with subset ; + [ tag-attributes "class" swap at = ] with filter ; : find-by-name ( str vector -- vector ) >r >lower r> - [ tag-name = ] with subset ; + [ tag-name = ] with filter ; : find-first-name ( str vector -- i/f tag/f ) >r >lower r> @@ -76,13 +76,13 @@ IN: html.parser.analyzer : find-by-attribute-key ( key vector -- vector ) >r >lower r> - [ tag-attributes at ] with subset - [ ] subset ; + [ tag-attributes at ] with filter + [ ] filter ; : find-by-attribute-key-value ( value key vector -- vector ) >r >lower r> - [ tag-attributes at over = ] with subset nip - [ ] subset ; + [ tag-attributes at over = ] with filter nip + [ ] filter ; : find-first-attribute-key-value ( value key vector -- i/f tag/f ) >r >lower r> @@ -99,7 +99,7 @@ IN: html.parser.analyzer : find-between ( i/f tag/f vector -- vector ) find-between* dup length 3 >= [ - [ 1 tail-slice 1 head-slice* ] keep like + [ rest-slice 1 head-slice* ] keep like ] when ; : find-between-first ( string vector -- vector' ) @@ -109,12 +109,12 @@ IN: html.parser.analyzer tag-attributes [ "href" swap at ] [ f ] if* ; : find-links ( vector -- vector ) - [ tag-name "a" = ] subset - [ tag-link ] subset ; + [ tag-name "a" = ] filter + [ tag-link ] filter ; : find-by-text ( seq quot -- tag ) - [ dup tag-name text = ] swap compose find drop ; + [ dup tag-name text = ] prepose find drop ; : find-opening-tags-by-name ( name seq -- seq ) [ [ tag-name = ] keep tag-closing? not and ] with find-all ; @@ -125,11 +125,11 @@ IN: html.parser.analyzer : query>assoc* ( str -- hash ) "?" split1 nip query>assoc ; -! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map +! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] filter [ "=" split peek ] map ! clear "http://www.sailwx.info/shiptrack/cruiseships.phtml" http-get parse-html remove-blank-text ! "a" over find-opening-tags-by-name -! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-subset +! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-filter ! first first 8 + over nth ! tag-attributes "href" swap at query>assoc* ! "lat" over at "lon" rot at diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor index b574799b38..0ae75e41fd 100644 --- a/extra/html/parser/utils/utils.factor +++ b/extra/html/parser/utils/utils.factor @@ -36,7 +36,7 @@ IN: html.parser.utils dup quoted? [ quote ] unless ; : unquote ( str -- newstr ) - dup quoted? [ 1 head-slice* 1 tail-slice >string ] when ; + dup quoted? [ 1 head-slice* rest-slice >string ] when ; : quote? ( ch -- ? ) "'\"" member? ; diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index 0f684f782a..1d947b99e5 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -6,9 +6,9 @@ tuple-syntax namespaces ; [ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test [ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test -[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test -[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test -[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test +[ "foo.txt" ] [ "http://www.arc.com/foo.txt?xxx" download-name ] unit-test +[ "foo.txt" ] [ "http://www.arc.com/foo.txt/" download-name ] unit-test +[ "www.arc.com" ] [ "http://www.arc.com////" download-name ] unit-test [ TUPLE{ request @@ -18,7 +18,7 @@ tuple-syntax namespaces ; port: 80 version: "1.1" cookies: V{ } - header: H{ } + header: H{ { "connection" "close" } } } ] [ [ diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index e4bbf0279f..7762b01843 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -2,10 +2,18 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files io.timeouts strings -splitting calendar continuations accessors vectors -io.encodings.8-bit io.encodings.binary fry ; +splitting calendar continuations accessors vectors math.order +io.encodings.8-bit io.encodings.binary fry debugger inspector ; IN: http.client +: max-redirects 10 ; + +ERROR: too-many-redirects ; + +M: too-many-redirects summary + drop + [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ; + DEFER: http-request > "location" swap at - dup "http://" head? [ - absolute-redirect + redirects inc + redirects get max-redirects < [ + header>> "location" swap at + dup absolute-url? [ + absolute-redirect + ] [ + relative-redirect + ] if "GET" >>method http-request ] [ - relative-redirect - ] if "GET" >>method http-request + too-many-redirects + ] if ] [ stdio get ] if ; -: request-addr ( request -- addr ) - dup host>> swap port>> ; - : close-on-error ( stream quot -- ) '[ , with-stream* ] [ ] pick '[ , dispose ] cleanup ; inline @@ -61,28 +76,55 @@ PRIVATE> ] close-on-error ] with-variable ; +: read-chunks ( -- ) + read-crlf ";" split1 drop hex> dup { f 0 } member? + [ drop ] [ read % read-crlf "" assert= read-chunks ] if ; + +: do-chunked-encoding ( response stream -- response stream/string ) + over "transfer-encoding" header "chunked" = [ + [ [ read-chunks ] "" make ] with-stream + ] when ; + : ( url -- request ) request-with-url "GET" >>method ; -: http-get-stream ( url -- response stream ) - http-request ; +: string-or-contents ( stream/string -- string ) + dup string? [ contents ] unless ; + +: http-get-stream ( url -- response stream/string ) + http-request do-chunked-encoding ; : success? ( code -- ? ) 200 = ; -: check-response ( response -- ) - code>> success? - [ "HTTP download failed" throw ] unless ; +ERROR: download-failed response body ; + +M: download-failed error. + "HTTP download failed:" print nl + [ + response>> + write-response-code + write-response-message nl + drop + ] + [ body>> write ] bi ; + +: check-response ( response string -- string ) + over code>> success? [ nip ] [ download-failed ] if ; : http-get ( url -- string ) - http-get-stream contents swap check-response ; + http-get-stream string-or-contents check-response ; : download-name ( url -- name ) file-name "?" split1 drop "/" ?tail drop ; : download-to ( url file -- ) #! Downloads the contents of a URL to a file. - swap http-get-stream swap check-response - [ swap latin1 stream-copy ] with-disposal ; + swap http-get-stream check-response + dup string? [ + latin1 [ write ] with-file-writer + ] [ + [ swap latin1 stream-copy ] with-disposal + ] if ; : download ( url -- ) dup download-name download-to ; @@ -95,4 +137,4 @@ PRIVATE> swap >>post-data-type ; : http-post ( content-type content url -- response string ) - http-request contents ; + http-request do-chunked-encoding string-or-contents ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index d1ffce721d..39e708c879 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,6 +1,6 @@ USING: http tools.test multiline tuple-syntax io.streams.string kernel arrays splitting sequences -assocs io.sockets ; +assocs io.sockets db db.sqlite ; IN: http.tests [ "hello%20world" ] [ "hello world" url-encode ] unit-test @@ -24,6 +24,8 @@ IN: http.tests [ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test [ "/bar" ] [ "/bar" url>path ] unit-test +: lf>crlf "\n" split "\r\n" join ; + STRING: read-request-test-1 GET http://foo/bar HTTP/1.1 Some-Header: 1 @@ -45,7 +47,7 @@ blah cookies: V{ } } ] [ - read-request-test-1 [ + read-request-test-1 lf>crlf [ read-request ] with-string-reader ] unit-test @@ -59,7 +61,7 @@ blah ; read-request-test-1' 1array [ - read-request-test-1 + read-request-test-1 lf>crlf [ read-request ] with-string-reader [ write-request ] with-string-writer ! normalize crlf @@ -69,6 +71,7 @@ read-request-test-1' 1array [ STRING: read-request-test-2 HEAD http://foo/bar HTTP/1.1 Host: www.sex.com + ; [ @@ -83,7 +86,7 @@ Host: www.sex.com cookies: V{ } } ] [ - read-request-test-2 [ + read-request-test-2 lf>crlf [ read-request ] with-string-reader ] unit-test @@ -104,7 +107,7 @@ blah cookies: V{ } } ] [ - read-response-test-1 + read-response-test-1 lf>crlf [ read-response ] with-string-reader ] unit-test @@ -117,7 +120,7 @@ content-type: text/html ; read-response-test-1' 1array [ - read-response-test-1 + read-response-test-1 lf>crlf [ read-response ] with-string-reader [ write-response ] with-string-writer ! normalize crlf @@ -130,19 +133,32 @@ read-response-test-1' 1array [ ] unit-test ! Live-fire exercise -USING: http.server http.server.static http.server.actions -http.client io.server io.files io accessors namespaces threads -io.encodings.ascii ; +USING: http.server http.server.static http.server.sessions +http.server.actions http.server.auth.login http.server.db http.client +io.server io.files io io.encodings.ascii +accessors namespaces threads ; + +: add-quit-action + + [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>display + "quit" add-responder ; + +: test-db "test.db" temp-file sqlite-db ; + +test-db [ + init-sessions-table +] with-db [ ] [ [ - - [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>display - "quit" add-responder + add-quit-action "extra/http/test" resource-path >>default "nested" add-responder + + [ "redirect-loop" f ] >>display + "redirect-loop" add-responder main-responder set [ 1237 httpd ] "HTTPD test" spawn drop @@ -159,11 +175,66 @@ io.encodings.ascii ; "localhost" 1237 ascii [ "GET nested HTTP/1.0\r\n" write flush "\r\n" write flush - readln drop - read-header USE: prettyprint - ] with-stream dup . "location" swap at "/" head? + read-crlf drop + read-header + ] with-stream "location" swap at "/" head? ] unit-test +[ "http://localhost:1237/redirect-loop" http-get ] +[ too-many-redirects? ] must-fail-with + [ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test + +! Dispatcher bugs +[ ] [ + [ + + + + + "" add-responder + add-quit-action + + "a" add-main-responder + "d" add-responder + test-db + main-responder set + + [ 1237 httpd ] "HTTPD test" spawn drop + ] with-scope +] unit-test + +[ ] [ 1000 sleep ] unit-test + +: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ; + +! This should give a 404 not an infinite redirect loop +[ "http://localhost:1237/d/blah" http-get ] [ 404? ] must-fail-with + +! This should give a 404 not an infinite redirect loop +[ "http://localhost:1237/blah/" http-get ] [ 404? ] must-fail-with + +[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test + +[ ] [ + [ + + [ "text/plain" [ "Hi" write ] >>body ] >>display + + + "" add-responder + add-quit-action + test-db + main-responder set + + [ 1237 httpd ] "HTTPD test" spawn drop + ] with-scope +] unit-test + +[ ] [ 1000 sleep ] unit-test + +[ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test + +[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 9e31855e53..9729542ea4 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -1,10 +1,18 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry hashtables io io.streams.string kernel math sets -namespaces math.parser assocs sequences strings splitting ascii -io.encodings.utf8 io.encodings.string namespaces unicode.case -combinators vectors sorting accessors calendar -calendar.format quotations arrays combinators.lib byte-arrays ; +USING: accessors kernel combinators math namespaces + +assocs sequences splitting sorting sets debugger +strings vectors hashtables quotations arrays byte-arrays +math.parser calendar calendar.format + +io io.streams.string io.encodings.utf8 io.encodings.string +io.sockets + +unicode.case unicode.categories qualified ; + +EXCLUDE: fry => , ; + IN: http : http-port 80 ; inline @@ -13,11 +21,12 @@ IN: http #! In a URL, can this character be used without #! URL-encoding? { - [ dup letter? ] - [ dup LETTER? ] - [ dup digit? ] - [ dup "/_-.:" member? ] - } || nip ; foldable + { [ dup letter? ] [ t ] } + { [ dup LETTER? ] [ t ] } + { [ dup digit? ] [ t ] } + { [ dup "/_-.:" member? ] [ t ] } + [ f ] + } cond nip ; foldable : push-utf8 ( ch -- ) 1string utf8 encode @@ -75,8 +84,15 @@ IN: http ] if ] if ; +: read-lf ( -- string ) + "\n" read-until CHAR: \n assert= ; + +: read-crlf ( -- string ) + "\r" read-until + [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ; + : read-header-line ( -- ) - readln dup + read-crlf dup empty? [ drop ] [ header-line read-header-line ] if ; : read-header ( -- assoc ) @@ -119,11 +135,12 @@ IN: http ] { } assoc>map "&" join ; -TUPLE: cookie name value path domain expires http-only ; +TUPLE: cookie name value path domain expires max-age http-only ; : ( value name -- cookie ) cookie new - swap >>name swap >>value ; + swap >>name + swap >>value ; : parse-cookies ( string -- seq ) [ @@ -131,7 +148,8 @@ TUPLE: cookie name value path domain expires http-only ; ";" split [ [ blank? ] trim "=" split1 swap >lower { - { "expires" [ >>expires ] } + { "expires" [ cookie-string>timestamp >>expires ] } + { "max-age" [ string>number seconds >>max-age ] } { "domain" [ >>domain ] } { "path" [ >>path ] } { "httponly" [ drop t >>http-only ] } @@ -147,7 +165,14 @@ TUPLE: cookie name value path domain expires http-only ; { { f [ drop ] } { t [ , ] } - [ "=" swap 3append , ] + [ + { + { [ dup timestamp? ] [ timestamp>cookie-string ] } + { [ dup duration? ] [ dt>seconds number>string ] } + [ ] + } cond + "=" swap 3append , + ] } case ; : unparse-cookie ( cookie -- strings ) @@ -156,6 +181,7 @@ TUPLE: cookie name value path domain expires http-only ; "path" over path>> (unparse-cookie) "domain" over domain>> (unparse-cookie) "expires" over expires>> (unparse-cookie) + "max-age" over max-age>> (unparse-cookie) "httponly" over http-only>> (unparse-cookie) drop ] { } make ; @@ -175,13 +201,17 @@ post-data post-data-type cookies ; +: set-header ( request/response value key -- request/response ) + pick header>> set-at ; + : request new "1.1" >>version http-port >>port H{ } clone >>header H{ } clone >>query - V{ } clone >>cookies ; + V{ } clone >>cookies + "close" "connection" set-header ; : query-param ( request key -- value ) swap query>> at ; @@ -220,7 +250,7 @@ cookies ; dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ; : read-request-version ( request -- request ) - readln [ CHAR: \s = ] left-trim + read-crlf [ CHAR: \s = ] left-trim parse-version >>version ; @@ -295,9 +325,16 @@ SYMBOL: max-post-request "application/x-www-form-urlencoded" >>post-data-type ] if ; +: request-addr ( request -- addr ) + [ host>> ] [ port>> ] bi ; + +: request-host ( request -- string ) + [ host>> ] [ port>> ] bi + dup 80 = [ drop ] [ ":" swap number>string 3append ] if ; + : write-request-header ( request -- request ) dup header>> >hashtable - over host>> [ "host" pick set-at ] when* + over host>> [ over request-host "host" pick set-at ] when over post-data>> [ length "content-length" pick set-at ] when* over post-data-type>> [ "content-type" pick set-at ] when* over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when* @@ -330,9 +367,6 @@ SYMBOL: max-post-request tri ] with-string-writer ; -: set-header ( request/response value key -- request/response ) - pick header>> set-at ; - GENERIC: write-response ( response -- ) GENERIC: write-full-response ( request response -- ) @@ -347,11 +381,11 @@ body ; : response new - "1.1" >>version - H{ } clone >>header - "close" "connection" set-header - now timestamp>http-string "date" set-header - V{ } clone >>cookies ; + "1.1" >>version + H{ } clone >>header + "close" "connection" set-header + now timestamp>http-string "date" set-header + V{ } clone >>cookies ; : read-response-version " \t" read-until @@ -365,7 +399,7 @@ body ; >>code ; : read-response-message - readln >>message ; + read-crlf >>message ; : read-response-header read-header >>header diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor index ebf8e8770b..5aa761603f 100755 --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/http/server/actions/actions-tests.factor @@ -1,7 +1,7 @@ -IN: http.server.actions.tests USING: http.server.actions http.server.validators tools.test math math.parser multiline namespaces http -io.streams.string http.server sequences accessors ; +io.streams.string http.server sequences splitting accessors ; +IN: http.server.actions.tests [ "a" [ v-number ] { { "a" "123" } } validate-param @@ -13,6 +13,8 @@ io.streams.string http.server sequences accessors ; { { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params "action-1" set +: lf>crlf "\n" split "\r\n" join ; + STRING: action-request-test-1 GET http://foo/bar?a=12&b=13 HTTP/1.1 @@ -20,28 +22,9 @@ blah ; [ 25 ] [ - action-request-test-1 [ read-request ] with-string-reader + init-request + action-request-test-1 lf>crlf + [ read-request ] with-string-reader request set - "/blah" - "action-1" get call-responder -] unit-test - - - [ +append-path get "xxx" get "X" concat append ] >>submit - { { +append-path [ ] } { "xxx" [ v-number ] } } >>post-params -"action-2" set - -STRING: action-request-test-2 -POST http://foo/bar/baz HTTP/1.1 -content-length: 5 -content-type: application/x-www-form-urlencoded - -xxx=4 -; - -[ "/blahXXXX" ] [ - action-request-test-2 [ read-request ] with-string-reader - request set - "/blah" - "action-2" get call-responder + { } "action-1" get call-responder ] unit-test diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index 2b2aaea6a8..6e1aac9627 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -5,7 +5,7 @@ http.server http.server.validators http hashtables namespaces fry continuations locals ; IN: http.server.actions -SYMBOL: +append-path +SYMBOL: +path+ SYMBOL: params @@ -37,14 +37,20 @@ TUPLE: action init display submit get-params post-params ; : validation-failed ( -- * ) action get display>> call exit-with ; -M: action call-responder ( path action -- response ) +M: action call-responder* ( path action -- response ) '[ - , , - [ +append-path associate request-params assoc-union params set ] - [ action set ] bi* - request get method>> { - { "GET" [ handle-get ] } - { "HEAD" [ handle-get ] } - { "POST" [ handle-post ] } - } case + , [ CHAR: / = ] right-trim empty? [ + , action set + request get + [ request-params params set ] + [ + method>> { + { "GET" [ handle-get ] } + { "HEAD" [ handle-get ] } + { "POST" [ handle-post ] } + } case + ] bi + ] [ + <404> + ] if ] with-exit-continuation ; diff --git a/extra/http/server/auth/admin/admin.factor b/extra/http/server/auth/admin/admin.factor new file mode 100644 index 0000000000..c9d2769292 --- /dev/null +++ b/extra/http/server/auth/admin/admin.factor @@ -0,0 +1,152 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences accessors namespaces combinators +locals db.tuples +http.server.templating.chloe +http.server.boilerplate +http.server.auth.providers +http.server.auth.providers.db +http.server.auth.login +http.server.forms +http.server.components.inspector +http.server.components +http.server.validators +http.server.sessions +http.server.actions +http.server.crud +http.server ; +IN: http.server.auth.admin + +: admin-template ( name -- template ) + "resource:extra/http/server/auth/admin/" swap ".xml" 3append ; + +: ( -- form ) + "user"
+ "new-user" admin-template >>edit-template + "username" add-field + "realname" add-field + "new-password" t >>required add-field + "verify-password" t >>required add-field + "email" add-field ; + +: ( -- form ) + "user" + "edit-user" admin-template >>edit-template + "user-summary" admin-template >>summary-template + "username" hidden >>renderer add-field + "realname" add-field + "new-password" add-field + "verify-password" add-field + "email" add-field + "profile" add-field ; + +: ( -- form ) + "user-list" + "user-list" admin-template >>view-template + "list" +unordered+ add-field ; + +:: ( form ctor next -- action ) + + [ + blank-values + + "username" get ctor call + + { + [ username>> "username" set-value ] + [ realname>> "realname" set-value ] + [ email>> "email" set-value ] + [ profile>> "profile" set-value ] + } cleave + ] >>init + + [ form edit-form ] >>display + + [ + blank-values + + form validate-form + + same-password-twice + + user new "username" value >>username select-tuple [ + user-exists? on + validation-failed + ] when + + "username" value + "realname" value >>realname + "email" value >>email + "new-password" value >>password + H{ } clone >>profile + + insert-tuple + + next f + ] >>submit ; + +:: ( form ctor next -- action ) + + { { "username" [ v-required ] } } >>get-params + + [ + blank-values + + "username" get ctor call select-tuple + + { + [ username>> "username" set-value ] + [ realname>> "realname" set-value ] + [ email>> "email" set-value ] + [ profile>> "profile" set-value ] + } cleave + ] >>init + + [ form edit-form ] >>display + + [ + blank-values + + form validate-form + + "username" value select-tuple + "realname" value >>realname + "email" value >>email + + { "new-password" "verify-password" } + [ value empty? ] all? [ + same-password-twice + "new-password" value >>password + ] unless + + update-tuple + + next f + ] >>submit ; + +:: ( ctor next -- action ) + + { { "username" [ ] } } >>post-params + + [ + "username" get + [ select-tuple 1 >>deleted update-tuple ] + [ logout-all-sessions ] + bi + + next f + ] >>submit ; + +TUPLE: user-admin < dispatcher ; + +:: ( -- responder ) + [let | ctor [ [ ] ] | + user-admin new-dispatcher + ctor "" add-responder + ctor "$user-admin" "new" add-responder + ctor "$user-admin" "edit" add-responder + ctor "$user-admin" "delete" add-responder + + "admin" admin-template >>template + + ] ; diff --git a/extra/http/server/auth/admin/admin.xml b/extra/http/server/auth/admin/admin.xml new file mode 100644 index 0000000000..d3c0ff4c90 --- /dev/null +++ b/extra/http/server/auth/admin/admin.xml @@ -0,0 +1,24 @@ + + + + + + +
+ List Users + | Add User + + + | Edit Profile + + + + | + +
+ +

+ + + + diff --git a/extra/http/server/auth/admin/edit-user.xml b/extra/http/server/auth/admin/edit-user.xml new file mode 100644 index 0000000000..71feda82f8 --- /dev/null +++ b/extra/http/server/auth/admin/edit-user.xml @@ -0,0 +1,60 @@ + + + + + Edit User + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
User name:
Real name:
New password:
Verify:
E-mail:
Profile:
+ +

+ + + + passwords do not match + +

+ + + + + + + + + diff --git a/extra/http/server/auth/admin/new-user.xml b/extra/http/server/auth/admin/new-user.xml new file mode 100644 index 0000000000..6b5b2523d7 --- /dev/null +++ b/extra/http/server/auth/admin/new-user.xml @@ -0,0 +1,51 @@ + + + + + New User + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
User name:
Real name:
New password:
Verify:
E-mail:
+ +

+ + + + username taken + + + + passwords do not match + +

+ + + diff --git a/extra/http/server/auth/admin/user-list.xml b/extra/http/server/auth/admin/user-list.xml new file mode 100644 index 0000000000..520b7f2512 --- /dev/null +++ b/extra/http/server/auth/admin/user-list.xml @@ -0,0 +1,9 @@ + + + + + Users + + + + diff --git a/extra/http/server/auth/admin/user-summary.xml b/extra/http/server/auth/admin/user-summary.xml new file mode 100644 index 0000000000..c426e7c072 --- /dev/null +++ b/extra/http/server/auth/admin/user-summary.xml @@ -0,0 +1,9 @@ + + + + + + + + + diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor index 69a3c76c2b..a25baf3ed2 100755 --- a/extra/http/server/auth/auth.factor +++ b/extra/http/server/auth/auth.factor @@ -1,26 +1,35 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: http.server.sessions accessors -http.server.auth.providers assocs namespaces kernel ; +USING: accessors assocs namespaces kernel +http.server +http.server.sessions +http.server.auth.providers ; IN: http.server.auth SYMBOL: logged-in-user -SYMBOL: user-profile-changed? GENERIC: init-user-profile ( responder -- ) M: object init-user-profile drop ; -: uid ( -- string ) logged-in-user sget username>> ; +M: dispatcher init-user-profile + default>> init-user-profile ; -: profile ( -- assoc ) logged-in-user sget profile>> ; +M: filter-responder init-user-profile + responder>> init-user-profile ; + +: profile ( -- assoc ) logged-in-user get profile>> ; + +: user-changed ( -- ) + logged-in-user get t >>changed? drop ; : uget ( key -- value ) profile at ; : uset ( value key -- ) - profile set-at user-profile-changed? on ; + profile set-at + user-changed ; : uchange ( quot key -- ) profile swap change-at - user-profile-changed? on ; inline + user-changed ; inline diff --git a/extra/http/server/auth/basic/basic.factor b/extra/http/server/auth/basic/basic.factor index 04c0e62d07..daf6e30eae 100755 --- a/extra/http/server/auth/basic/basic.factor +++ b/extra/http/server/auth/basic/basic.factor @@ -6,7 +6,7 @@ http.server.auth.providers http.server.auth.providers.null http sequences ; IN: http.server.auth.basic -TUPLE: basic-auth responder realm provider ; +TUPLE: basic-auth < filter-responder realm provider ; C: basic-auth @@ -36,6 +36,6 @@ C: basic-auth : logged-in? ( request responder -- ? ) provider>> swap "authorization" header authorization-ok? ; -M: basic-auth call-responder ( request path responder -- response ) +M: basic-auth call-responder* ( request path responder -- response ) pick over logged-in? - [ responder>> call-responder ] [ 2nip realm>> <401> ] if ; + [ call-next-method ] [ 2nip realm>> <401> ] if ; diff --git a/extra/http/server/auth/login/edit-profile.xml b/extra/http/server/auth/login/edit-profile.xml index 86a4e86551..107dbba2b8 100644 --- a/extra/http/server/auth/login/edit-profile.xml +++ b/extra/http/server/auth/login/edit-profile.xml @@ -4,18 +4,18 @@ Edit Profile - + - + - + @@ -25,7 +25,7 @@ - + @@ -35,12 +35,12 @@ - + - + @@ -50,7 +50,7 @@ - + @@ -63,11 +63,11 @@

- + invalid password - + passwords do not match

diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index b0cc0c21d1..453f4cc4d6 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -13,6 +13,7 @@ http.server.auth.providers http.server.auth.providers.null http.server.actions http.server.components +http.server.flows http.server.forms http.server.sessions http.server.boilerplate @@ -22,7 +23,6 @@ http.server.validators ; IN: http.server.auth.login QUALIFIED: smtp -SYMBOL: post-login-url SYMBOL: login-failed? TUPLE: login < dispatcher users ; @@ -35,9 +35,7 @@ TUPLE: user-saver user ; C: user-saver M: user-saver dispose - user-profile-changed? get [ - user>> users update-user - ] [ drop ] if ; + user>> dup changed?>> [ users update-user ] [ drop ] if ; : save-user-after ( user -- ) add-always-destructor ; @@ -59,9 +57,8 @@ M: user-saver dispose add-field ; : successful-login ( user -- response ) - logged-in-user sset - post-login-url sget "" or f - f post-login-url sset ; + username>> set-uid + "$login" end-flow ; :: ( -- action ) [let | form [ ] | @@ -126,11 +123,11 @@ SYMBOL: user-exists? same-password-twice - - "username" value >>username + "username" value "realname" value >>realname "new-password" value >>password "email" value >>email + H{ } clone >>profile users new-user [ user-exists? on @@ -139,7 +136,7 @@ SYMBOL: user-exists? successful-login - login get default>> responder>> init-user-profile + login get init-user-profile ] >>submit ] ; @@ -155,17 +152,17 @@ SYMBOL: user-exists? "verify-password" add-field "email" add-field ; -SYMBOL: previous-page - :: ( -- action ) [let | form [ ] | [ blank-values - logged-in-user sget - dup username>> "username" set-value - dup realname>> "realname" set-value - dup email>> "email" set-value + + logged-in-user get + [ username>> "username" set-value ] + [ realname>> "realname" set-value ] + [ email>> "email" set-value ] + tri ] >>init [ form edit-form ] >>display @@ -176,9 +173,10 @@ SYMBOL: previous-page form validate-form - logged-in-user sget + logged-in-user get - "password" value empty? [ + { "password" "new-password" "verify-password" } + [ value empty? ] all? [ same-password-twice "password" value uid users check-login @@ -190,9 +188,11 @@ SYMBOL: previous-page "realname" value >>realname "email" value >>email - user-profile-changed? on + t >>changed? - previous-page sget f + drop + + "$login" end-flow ] >>submit ] ; @@ -328,32 +328,30 @@ SYMBOL: lost-password-from : ( -- action ) [ - f logged-in-user sset - "login" f + f set-uid + "$login/login" end-flow ] >>submit ; ! ! ! Authentication logic -TUPLE: protected responder ; +TUPLE: protected < filter-responder ; C: protected : show-login-page ( -- response ) - request get request-url post-login-url sset - "login" f ; + begin-flow + "$login/login" f ; -M: protected call-responder ( path responder -- response ) - logged-in-user sget dup [ - save-user-after - request get request-url previous-page sset - responder>> call-responder +M: protected call-responder* ( path responder -- response ) + uid dup [ + users get-user + [ logged-in-user set ] [ save-user-after ] bi + call-next-method ] [ - 3drop - request get method>> { "GET" "HEAD" } member? - [ show-login-page ] [ <400> ] if + 3drop show-login-page ] if ; -M: login call-responder ( path responder -- response ) +M: login call-responder* ( path responder -- response ) dup login set call-next-method ; @@ -363,7 +361,7 @@ M: login call-responder ( path responder -- response ) : ( responder -- auth ) login new-dispatcher - swap >>default + swap >>default "login" add-responder "logout" add-responder no-users >>users ; diff --git a/extra/http/server/auth/login/login.xml b/extra/http/server/auth/login/login.xml index 2f16c09d8d..0524d0889f 100644 --- a/extra/http/server/auth/login/login.xml +++ b/extra/http/server/auth/login/login.xml @@ -4,18 +4,18 @@ Login - +
User name:
Real name:
Current password:
New password:
Verify:
E-mail:
- + - +
User name:
Password:
@@ -24,7 +24,7 @@ - + invalid username or password

@@ -33,11 +33,11 @@

- Register + Register | - Recover Password + Recover Password

diff --git a/extra/http/server/auth/login/recover-1.xml b/extra/http/server/auth/login/recover-1.xml index dd3a60f1d1..7c72181c10 100644 --- a/extra/http/server/auth/login/recover-1.xml +++ b/extra/http/server/auth/login/recover-1.xml @@ -6,23 +6,23 @@

Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.

- + - + - + - + diff --git a/extra/http/server/auth/login/recover-3.xml b/extra/http/server/auth/login/recover-3.xml index 115c2cea21..61ef0aef86 100644 --- a/extra/http/server/auth/login/recover-3.xml +++ b/extra/http/server/auth/login/recover-3.xml @@ -6,21 +6,21 @@

Choose a new password for your account.

- +
User name:
E-mail:
Captcha:
- - + + - + - + @@ -33,7 +33,7 @@

- + passwords do not match

diff --git a/extra/http/server/auth/login/recover-4.xml b/extra/http/server/auth/login/recover-4.xml index 3c10869fbd..f5d02fa858 100755 --- a/extra/http/server/auth/login/recover-4.xml +++ b/extra/http/server/auth/login/recover-4.xml @@ -4,6 +4,6 @@ Recover lost password: step 4 of 4 -

Your password has been reset. You may now log in.

+

Your password has been reset. You may now log in.

diff --git a/extra/http/server/auth/login/register.xml b/extra/http/server/auth/login/register.xml index 1bacf71801..19917002b5 100644 --- a/extra/http/server/auth/login/register.xml +++ b/extra/http/server/auth/login/register.xml @@ -4,18 +4,18 @@ New User Registration - +
Password:
Verify password:
- + - + @@ -25,12 +25,12 @@ - + - + @@ -40,7 +40,7 @@ - + @@ -50,7 +50,7 @@ - + @@ -64,11 +64,11 @@ - + username taken - + passwords do not match diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor index a8f17d6f5d..82a2b54b0e 100755 --- a/extra/http/server/auth/providers/assoc/assoc-tests.factor +++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor @@ -6,17 +6,17 @@ namespaces accessors kernel ; "provider" set [ t ] [ - - "slava" >>username + "slava" "foobar" >>password "slava@factorcode.org" >>email + H{ } clone >>profile "provider" get new-user username>> "slava" = ] unit-test [ f ] [ - - "slava" >>username + "slava" + H{ } clone >>profile "provider" get new-user ] unit-test diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor index 6daddac304..1a5298f050 100755 --- a/extra/http/server/auth/providers/db/db-tests.factor +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -6,22 +6,24 @@ io.files accessors kernel ; users-in-db "provider" set +[ "auth-test.db" temp-file delete-file ] ignore-errors + "auth-test.db" temp-file sqlite-db [ init-users-table [ t ] [ - - "slava" >>username + "slava" "foobar" >>password "slava@factorcode.org" >>email + H{ } clone >>profile "provider" get new-user username>> "slava" = ] unit-test [ f ] [ - - "slava" >>username + "slava" + H{ } clone >>profile "provider" get new-user ] unit-test diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor index deab40e8d4..66d3a00a42 100755 --- a/extra/http/server/auth/providers/db/db.factor +++ b/extra/http/server/auth/providers/db/db.factor @@ -7,31 +7,28 @@ IN: http.server.auth.providers.db user "USERS" { - { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ } + { "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ } { "realname" "REALNAME" { VARCHAR 256 } } { "password" "PASSWORD" { VARCHAR 256 } +not-null+ } { "email" "EMAIL" { VARCHAR 256 } } { "ticket" "TICKET" { VARCHAR 256 } } { "profile" "PROFILE" FACTOR-BLOB } + { "deleted" "DELETED" INTEGER +not-null+ } } define-persistent : init-users-table user ensure-table ; SINGLETON: users-in-db -: find-user ( username -- user ) - - swap >>username - select-tuple ; - M: users-in-db get-user - drop - find-user ; + drop select-tuple ; M: users-in-db new-user drop [ - dup username>> find-user [ + user new + over username>> >>username + select-tuple [ drop f ] [ dup insert-tuple diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor index a867b2381e..512ddc5f5b 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/http/server/auth/providers/providers.factor @@ -4,9 +4,12 @@ USING: kernel accessors random math.parser locals sequences math crypto.sha2 ; IN: http.server.auth.providers -TUPLE: user username realname password email ticket profile ; +TUPLE: user username realname password email ticket profile deleted changed? ; -: user new H{ } clone >>profile ; +: ( username -- user ) + user new + swap >>username + 0 >>deleted ; GENERIC: get-user ( username provider -- user/f ) diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor index 4e847cff70..1dc5effbe2 100644 --- a/extra/http/server/boilerplate/boilerplate.factor +++ b/extra/http/server/boilerplate/boilerplate.factor @@ -1,13 +1,15 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces boxes sequences strings -io io.streams.string +io io.streams.string arrays +html.elements http http.server +http.server.sessions http.server.templating ; IN: http.server.boilerplate -TUPLE: boilerplate responder template ; +TUPLE: boilerplate < filter-responder template ; : f boilerplate boa ; @@ -28,6 +30,18 @@ SYMBOL: style : write-style ( -- ) style get >string write ; +SYMBOL: atom-feed + +: set-atom-feed ( title url -- ) + 2array atom-feed get >box ; + +: write-atom-feed ( -- ) + atom-feed get value>> [ + + ] when* ; + SYMBOL: nested-template? SYMBOL: next-template @@ -35,11 +49,12 @@ SYMBOL: next-template : call-next-template ( -- ) next-template get write ; -M: f call-template drop call-next-template ; +M: f call-template* drop call-next-template ; : with-boilerplate ( body template -- ) [ title get [ title set ] unless + atom-feed get [ atom-feed set ] unless style get [ SBUF" " clone style set ] unless [ @@ -53,6 +68,9 @@ M: f call-template drop call-next-template ; bi* ] with-scope ; inline -M: boilerplate call-responder - [ responder>> call-responder clone ] [ template>> ] bi - [ [ with-boilerplate ] 2curry ] curry change-body ; +M: boilerplate call-responder* + tuck call-next-method + dup "content-type" header "text/html" = [ + clone swap template>> + [ [ with-boilerplate ] 2curry ] curry change-body + ] [ nip ] if ; diff --git a/extra/http/server/callbacks/callbacks-tests.factor b/extra/http/server/callbacks/callbacks-tests.factor index 4cad097cf5..cca5942328 100755 --- a/extra/http/server/callbacks/callbacks-tests.factor +++ b/extra/http/server/callbacks/callbacks-tests.factor @@ -5,10 +5,12 @@ splitting kernel hashtables continuations ; [ 123 ] [ [ + init-request + "GET" >>method request set [ exit-continuation set - "xxx" + { } [ [ "hello" print 123 ] show-final ] >>display call-responder @@ -17,6 +19,8 @@ splitting kernel hashtables continuations ; ] unit-test [ + init-request + [ [ "hello" print @@ -31,7 +35,7 @@ splitting kernel hashtables continuations ; [ exit-continuation set "GET" >>method request set - "" "r" get call-responder + { } "r" get call-responder ] callcc1 body>> first @@ -44,7 +48,7 @@ splitting kernel hashtables continuations ; [ exit-continuation set - "/" + { } "r" get call-responder ] callcc1 @@ -57,7 +61,7 @@ splitting kernel hashtables continuations ; [ exit-continuation set - "/" + { } "r" get call-responder ] callcc1 ] unit-test diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor index 42213d015f..5325ee3b55 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/http/server/callbacks/callbacks.factor @@ -96,7 +96,7 @@ SYMBOL: current-show : resuming-callback ( responder request -- id ) cont-id query-param swap callbacks>> at ; -M: callback-responder call-responder ( path responder -- response ) +M: callback-responder call-responder* ( path responder -- response ) '[ , , diff --git a/extra/http/server/components/code/code.factor b/extra/http/server/components/code/code.factor new file mode 100644 index 0000000000..90b70c7bcc --- /dev/null +++ b/extra/http/server/components/code/code.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: splitting kernel io sequences xmode.code2html accessors +http.server.components ; +IN: http.server.components.code + +TUPLE: code-renderer < text-renderer mode ; + +: ( mode -- renderer ) + code-renderer new-text-renderer + swap >>mode ; + +M: code-renderer render-view* + [ string-lines ] [ mode>> value ] bi* htmlize-lines ; + +: ( id mode -- component ) + swap + swap >>renderer ; diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor index 6d3a048ac4..ff87bb71fb 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -129,3 +129,5 @@ TUPLE: test-tuple text number more-text ; [ t ] [ "wake up sheeple" dup "n" validate = ] unit-test [ ] [ "password" "p" set ] unit-test + +[ ] [ "pub-date" "d" set ] unit-test diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 50353c6b87..cb109fc847 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: html.elements http.server.validators accessors namespaces -kernel io math.parser assocs classes words classes.tuple arrays -sequences splitting mirrors hashtables fry combinators -continuations math ; +USING: accessors namespaces kernel io math.parser assocs classes +words classes.tuple arrays sequences splitting mirrors +hashtables fry combinators continuations math +calendar.format html.elements +http.server.validators ; IN: http.server.components ! Renderer protocol @@ -29,8 +30,6 @@ TUPLE: hidden < field ; : hidden ( -- renderer ) T{ hidden f "hidden" } ; inline -M: hidden render-view* 2drop ; - ! Component protocol SYMBOL: components @@ -59,9 +58,14 @@ SYMBOL: values : values-tuple values get mirror-object ; +: render-view-or-summary ( component -- value renderer ) + [ id>> value ] [ component-string ] [ renderer>> ] tri ; + : render-view ( component -- ) - [ id>> value ] [ component-string ] [ renderer>> ] tri - render-view* ; + render-view-or-summary render-view* ; + +: render-summary ( component -- ) + render-view-or-summary render-summary* ; ( id -- component ) + url new-string + 5 >>min-length + 60 >>max-length ; + +M: url validate* + call-next-method dup empty? [ v-url ] unless ; + ! Don't send passwords back to the user TUPLE: password-renderer < field ; @@ -206,20 +221,20 @@ M: captcha validate* drop v-captcha ; ! Text areas -TUPLE: textarea-renderer rows cols ; +TUPLE: text-renderer rows cols ; -: new-textarea-renderer ( class -- renderer ) +: new-text-renderer ( class -- renderer ) new 60 >>cols 20 >>rows ; -: ( -- renderer ) - textarea-renderer new-textarea-renderer ; +: ( -- renderer ) + text-renderer new-text-renderer ; -M: textarea-renderer render-view* +M: text-renderer render-view* drop write ; -M: textarea-renderer render-edit* +M: text-renderer render-edit*
User name:
Real name:
Password:
Verify:
E-mail:
Captcha: