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 <command>"
}
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 ;
: <alien> ( address -- alien )
f <displaced-alien> { 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 <displaced-alien> ] ;
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: <c-object>
{ <c-object> 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 <void*> } " 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 } <displaced-alien> <void*>
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 <int> *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 <byte-array> [ -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
<c-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
- <c-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
-
- <c-type>
- [ 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 dd2d9587cb..3d0f36e415 100755
--- a/core/alien/compiler/compiler-tests.factor
+++ b/core/alien/compiler/compiler-tests.factor
@@ -3,7 +3,7 @@ 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 ;
+tools.test math ;
FUNCTION: void ffi_test_0 ;
[ ] [ ffi_test_0 ] unit-test
@@ -280,6 +280,10 @@ 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 ;
@@ -354,3 +358,18 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
] 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 b6fcbe6176..3de4c61291 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>>
- [ <reversed> (make-prep-quot) ] [ ] make ;
+: param-prep-quot ( node -- quot )
+ parameters>> [ <reversed> (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>> [ <reversed> (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 f 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 f 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 f 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 f infer-quot
] "infer" set-word-prop
M: #alien-indirect generate-node
@@ -331,7 +345,7 @@ M: alien-callback-error summary
: callback-bottom ( node -- )
xt>> [ word-xt drop <alien> ] curry
- recursive-state get infer-quot ;
+ f infer-quot ;
\ alien-callback [
4 ensure-values
@@ -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 ;
@@ -403,12 +419,12 @@ TUPLE: callback-context ;
: generate-callback ( node -- )
dup xt>> dup [
init-templates
- %save-word-xt
%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 <memory-stream> r> <decoder>
+ "\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
+ <byte-writer>
+ [ 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 <decoder> drop utf16n <decoder> ;
+
+M: utf16n <encoder> drop utf16n <encoder> ;
+
+: 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 ] [ \ <displaced-alien> "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..f0f495cac9 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
<PRIVATE
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index f1e41ac2b6..dd3a4adf8b 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -58,16 +58,13 @@ num-types get f <array> 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"
@@ -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 ca90587ea9..dfd2e4be6f 100755
--- a/core/bootstrap/stage2.factor
+++ b/core/bootstrap/stage2.factor
@@ -27,10 +27,6 @@ SYMBOL: bootstrap-time
diff
[ "bootstrap." prepend require ] each ;
-! : compile-remaining ( -- )
-! "Compiling remaining words..." print flush
-! vocabs [ words [ compiled? not ] subset compile ] each ;
-
: count-words ( pred -- )
all-words swap subset length number>string write ;
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
";"
"<PRIVATE"
"?{"
- "?V{"
"BIN:"
"B{"
- "BV{"
"C:"
"CHAR:"
"DEFER:"
"ERROR:"
"F{"
- "FV{"
"FORGET:"
"GENERIC#"
"GENERIC:"
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index d61b62af3b..dba97c16f5 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -4,7 +4,7 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
-random inference effects kernel.private ;
+random inference effects kernel.private sbufs ;
: class= [ class< ] 2keep swap class< and ;
@@ -144,6 +144,48 @@ UNION: z1 b1 c1 ;
[ f ] [ null class-not null class= ] unit-test
+[ t ] [
+ fixnum class-not
+ fixnum fixnum class-not class-or
+ class<
+] 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
+
+[ f ] [ null { number fixnum null } min-class ] unit-test
+
! Test for hangs?
: random-class classes random ;
diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index b7a3e074e5..f2941e3cef 100755
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -77,10 +77,10 @@ C: <anonymous-complement> 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< ] }
@@ -193,9 +193,8 @@ C: <anonymous-complement> anonymous-complement
[ ] unfold nip ;
: min-class ( class seq -- class/f )
- [ dupd classes-intersect? ] subset dup empty? [
- 2drop f
- ] [
+ over [ classes-intersect? ] curry subset
+ dup empty? [ 2drop f ] [
tuck [ class< ] with all? [ peek ] [ drop f ] if
] if ;
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index ce6fd9367c..2932187152 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 ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index e3d0f88680..da98a78736 100755
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -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/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor
index fadc57dc8d..7d473871fe 100755
--- a/core/compiler/tests/intrinsics.factor
+++ b/core/compiler/tests/intrinsics.factor
@@ -4,8 +4,8 @@ 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 ;
+alien.accessors alien.c-types alien.syntax alien.strings
+namespaces libc sequences.private io.encodings.ascii ;
! 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 <void*> [ { byte-array } declare *void* ] compile-call alien>char-string ] unit-test
- [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call alien>char-string ] unit-test
+ [ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call ascii alien>string ] unit-test
+ [ "hello world" ] [ "s" get <void*> [ { 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/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 ;
: <int-vreg> ( n -- vreg ) int-regs <vreg> ;
diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor
index 845189ce2c..14d75cdc03 100755
--- a/core/compiler/tests/templates.factor
+++ b/core/compiler/tests/templates.factor
@@ -3,7 +3,7 @@ USING: arrays compiler kernel kernel.private math
hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts
-words definitions compiler.units io combinators ;
+words definitions compiler.units io combinators vectors ;
IN: compiler.tests
! Oops!
@@ -246,3 +246,12 @@ TUPLE: my-tuple ;
} cleave ;
[ t ] [ \ float-spill-bug compiled? ] unit-test
+
+! Regression
+: dispatch-alignment-regression ( -- c )
+ { tuple vector } 3 slot { word } declare
+ dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
+
+[ t ] [ \ dispatch-alignment-regression compiled? ] unit-test
+
+[ vector ] [ dispatch-alignment-regression ] unit-test
diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor
index 65d1763ea8..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
@@ -56,7 +63,7 @@ HOOK: %call cpu ( word -- )
HOOK: %jump-label cpu ( label -- )
! Test if vreg is 'f' or not
-HOOK: %jump-t cpu ( label -- )
+HOOK: %jump-f cpu ( label -- )
HOOK: %dispatch cpu ( -- )
@@ -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 09ffead029..1799411021 100755
--- a/core/cpu/ppc/architecture/architecture.factor
+++ b/core/cpu/ppc/architecture/architecture.factor
@@ -106,8 +106,8 @@ M: ppc %call ( label -- ) BL ;
M: ppc %jump-label ( label -- ) B ;
-M: ppc %jump-t ( label -- )
- 0 "flag" operand f v>operand CMPI BNE ;
+M: ppc %jump-f ( label -- )
+ 0 "flag" operand f v>operand CMPI BEQ ;
M: ppc %dispatch ( -- )
[
diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index d092473960..34e9900893 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/core/cpu/ppc/intrinsics/intrinsics.factor
@@ -217,11 +217,11 @@ IN: cpu.ppc.intrinsics
2array define-if-intrinsics ;
{
- { fixnum< BLT }
- { fixnum<= BLE }
- { fixnum> BGT }
- { fixnum>= BGE }
- { eq? BEQ }
+ { fixnum< BGE }
+ { fixnum<= BGT }
+ { fixnum> BLE }
+ { fixnum>= BLT }
+ { eq? BNE }
} [
first2 define-fixnum-jump
] each
@@ -356,11 +356,11 @@ IN: cpu.ppc.intrinsics
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
- { float< BLT }
- { float<= BLE }
- { float> BGT }
- { float>= BGE }
- { float= BEQ }
+ { float< BGE }
+ { float<= BGT }
+ { float> BLE }
+ { float>= BLT }
+ { float= BNE }
} [
first2 define-float-jump
] each
diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor
index cc3fceff23..50e38f2082 100755
--- a/core/cpu/x86/32/32.factor
+++ b/core/cpu/x86/32/32.factor
@@ -16,8 +16,9 @@ IN: cpu.x86.32
M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
-M: x86.32 xt-reg ECX ;
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 ;
@@ -267,7 +268,7 @@ os windows? [
EDX 26 SHR
EDX 1 AND
{ EAX EBX ECX EDX } [ POP ] each
- JNE
+ JE
] { } define-if-intrinsic
"-no-sse2" cli-args member? [
diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor
index 811387675a..d79ce58d88 100755
--- a/core/cpu/x86/64/64.factor
+++ b/core/cpu/x86/64/64.factor
@@ -11,8 +11,9 @@ IN: cpu.x86.64
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
-M: x86.64 xt-reg RCX ;
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 ;
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 25bb3c6e07..7e7ff8a334 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -9,7 +9,6 @@ IN: cpu.x86.architecture
HOOK: ds-reg cpu
HOOK: rs-reg cpu
HOOK: stack-reg cpu
-HOOK: xt-reg cpu
HOOK: stack-save-reg cpu
: stack@ stack-reg swap [+] ;
@@ -35,6 +34,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
@@ -47,13 +50,13 @@ M: x86 stack-frame ( n -- i )
3 cells + 16 align cell - ;
M: x86 %save-word-xt ( -- )
- xt-reg 0 MOV rc-absolute-cell rel-this ;
+ temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
: factor-area-size 4 cells ;
M: x86 %prologue ( n -- )
dup cell + PUSH
- xt-reg PUSH
+ temp-reg v>operand PUSH
stack-reg swap 2 cells - SUB ;
M: x86 %epilogue ( n -- )
@@ -76,8 +79,8 @@ M: x86 %call ( label -- ) CALL ;
M: x86 %jump-label ( label -- ) JMP ;
-M: x86 %jump-t ( label -- )
- "flag" operand f v>operand CMP JNE ;
+M: x86 %jump-f ( label -- )
+ "flag" operand f v>operand CMP JE ;
: code-alignment ( -- n )
building get length dup cell align swap - ;
diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor
index 80a786c9fa..c48f33b765 100755
--- a/core/cpu/x86/intrinsics/intrinsics.factor
+++ b/core/cpu/x86/intrinsics/intrinsics.factor
@@ -212,11 +212,11 @@ IN: cpu.x86.intrinsics
2array define-if-intrinsics ;
{
- { fixnum< JL }
- { fixnum<= JLE }
- { fixnum> JG }
- { fixnum>= JGE }
- { eq? JE }
+ { fixnum< JGE }
+ { fixnum<= JG }
+ { fixnum> JLE }
+ { fixnum>= JL }
+ { eq? JNE }
} [
first2 define-fixnum-jump
] each
diff --git a/core/cpu/x86/sse2/sse2.factor b/core/cpu/x86/sse2/sse2.factor
index 9c477b4132..fb96649753 100755
--- a/core/cpu/x86/sse2/sse2.factor
+++ b/core/cpu/x86/sse2/sse2.factor
@@ -27,11 +27,11 @@ IN: cpu.x86.sse2
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
- { float< JB }
- { float<= JBE }
- { float> JA }
- { float>= JAE }
- { float= JE }
+ { float< JAE }
+ { float<= JA }
+ { float> JBE }
+ { float>= JB }
+ { float= JNE }
} [
first2 define-float-jump
] each
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..ad6cd3051c 100755
--- a/core/generator/fixup/fixup.factor
+++ b/core/generator/fixup/fixup.factor
@@ -2,7 +2,7 @@
! 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
+quotations strings alien.strings layouts system combinators
math.bitfields words.private cpu.architecture ;
IN: generator.fixup
@@ -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 919e89d3c8..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 ;
@@ -131,14 +132,14 @@ M: #loop generate-node
: generate-if ( node label -- next )
<label> [
- >r >r node-children first2 generate-branch
+ >r >r node-children first2 swap generate-branch
r> r> end-false-branch resolve-label
generate-branch
init-templates
] keep resolve-label iterate-next ;
M: #if generate-node
- [ <label> dup %jump-t ]
+ [ <label> dup %jump-f ]
H{ { +input+ { { f "flag" } } } }
with-template
generate-if ;
@@ -189,13 +190,13 @@ M: #dispatch generate-node
"if-intrinsics" set-word-prop ;
: if>boolean-intrinsic ( quot -- )
- "true" define-label
+ "false" define-label
"end" define-label
- "true" get swap call
- f "if-scratch" get load-literal
- "end" get %jump-label
- "true" resolve-label
+ "false" get swap call
t "if-scratch" get load-literal
+ "end" get %jump-label
+ "false" resolve-label
+ f "if-scratch" get load-literal
"end" resolve-label
"if-scratch" get phantom-push ; inline
diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor
index 627f51acc2..6a1d9ec0f4 100755
--- a/core/generator/registers/registers.factor
+++ b/core/generator/registers/registers.factor
@@ -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 ;
-
<PRIVATE
! Value protocol
@@ -65,9 +58,7 @@ M: float-regs move-spec drop float ;
M: float-regs operand-class* drop float ;
! Temporary register for stack shuffling
-TUPLE: temp-reg reg-class>> ;
-
-: temp-reg T{ temp-reg f int-regs } ;
+SINGLETON: temp-reg
M: temp-reg move-spec drop f ;
@@ -470,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 <=
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index caae16e8ed..6c59d76d07 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -29,6 +29,9 @@ 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 )
diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
index 0ffd953d77..7639d1d499 100644
--- a/core/generic/standard/engines/tuple/tuple.factor
+++ b/core/generic/standard/engines/tuple/tuple.factor
@@ -1,8 +1,11 @@
-IN: generic.standard.engines.tuple
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes.tuple.private hashtables assocs sorting
accessors combinators sequences slots.private math.parser words
effects namespaces generic generic.standard.engines
-classes.algebra math math.private quotations arrays ;
+classes.algebra math math.private kernel.private
+quotations arrays ;
+IN: generic.standard.engines.tuple
TUPLE: echelon-dispatch-engine n methods ;
@@ -27,14 +30,7 @@ TUPLE: tuple-dispatch-engine echelons ;
: <tuple-dispatch-engine> ( methods -- engine )
echelon-sort
- [
- over zero? [
- dup assoc-empty?
- [ drop f ] [ values first ] if
- ] [
- dupd <echelon-dispatch-engine>
- ] if
- ] assoc-map [ nip ] assoc-subset
+ [ dupd <echelon-dispatch-engine> ] assoc-map
\ tuple-dispatch-engine boa ;
: convert-tuple-methods ( assoc -- assoc' )
@@ -48,52 +44,51 @@ M: trivial-tuple-dispatch-engine engine>quot
>alist V{ } clone [ hashcode 1array ] distribute-buckets
[ <trivial-tuple-dispatch-engine> ] map ;
+: word-hashcode% [ 1 slot ] % ;
+
: class-hash-dispatch-quot ( methods -- quot )
- #! 1 slot == word hashcode
[
- [ dup 1 slot ] %
+ \ dup ,
+ word-hashcode%
hash-methods [ engine>quot ] map hash-dispatch-quot %
] [ ] make ;
-: tuple-dispatch-engine-word-name ( engine -- string )
- [
- generic get word-name %
- "/tuple-dispatch-engine/" %
- n>> #
- ] "" make ;
+: engine-word-name ( -- string )
+ generic get word-name "/tuple-dispatch-engine" append ;
-PREDICATE: tuple-dispatch-engine-word < word
+PREDICATE: engine-word < word
"tuple-dispatch-generic" word-prop generic? ;
-M: tuple-dispatch-engine-word stack-effect
+M: engine-word stack-effect
"tuple-dispatch-generic" word-prop
[ extra-values ] [ stack-effect ] bi
dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
-M: tuple-dispatch-engine-word compiled-crossref?
+M: engine-word compiled-crossref?
drop t ;
: remember-engine ( word -- )
generic get "engines" word-prop push ;
-: <tuple-dispatch-engine-word> ( engine -- word )
- tuple-dispatch-engine-word-name f <word>
- [ generic get "tuple-dispatch-generic" set-word-prop ]
- [ remember-engine ]
- [ ]
- tri ;
+: <engine-word> ( -- word )
+ engine-word-name f <word>
+ dup generic get "tuple-dispatch-generic" set-word-prop ;
-: define-tuple-dispatch-engine-word ( engine quot -- word )
- >r <tuple-dispatch-engine-word> dup r> define ;
+: define-engine-word ( quot -- word )
+ >r <engine-word> dup r> define ;
+
+: array-nth% 2 + , [ slot { word } declare ] % ;
+
+: tuple-layout-superclasses ( obj -- array )
+ { tuple } declare
+ 1 slot { tuple-layout } declare
+ 4 slot { array } declare ; inline
: tuple-dispatch-engine-body ( engine -- quot )
- #! 1 slot == tuple-layout
- #! 2 slot == 0 array-nth
- #! 4 slot == layout-superclasses
[
picker %
- [ 1 slot 4 slot ] %
- [ n>> 2 + , [ slot ] % ]
+ [ tuple-layout-superclasses ] %
+ [ n>> array-nth% ]
[
methods>> [
<trivial-tuple-dispatch-engine> engine>quot
@@ -104,25 +99,54 @@ M: tuple-dispatch-engine-word compiled-crossref?
] [ ] make ;
M: echelon-dispatch-engine engine>quot
- dup tuple-dispatch-engine-body
- define-tuple-dispatch-engine-word
- 1quotation ;
+ dup n>> zero? [
+ methods>> dup assoc-empty?
+ [ drop default get ] [ values first engine>quot ] if
+ ] [
+ [
+ picker %
+ [ tuple-layout-superclasses ] %
+ [ n>> array-nth% ]
+ [
+ methods>> [
+ <trivial-tuple-dispatch-engine> engine>quot
+ ] [
+ class-hash-dispatch-quot
+ ] if-small? %
+ ] bi
+ ] [ ] make
+ ] if ;
: >=-case-quot ( alist -- quot )
default get [ drop ] prepend swap
[ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
alist>quot ;
+: tuple-layout-echelon ( obj -- array )
+ { tuple } declare
+ 1 slot { tuple-layout } declare
+ 5 slot ; inline
+
+: unclip-last [ 1 head* ] [ peek ] bi ;
+
M: tuple-dispatch-engine engine>quot
- #! 1 slot == tuple-layout
- #! 5 slot == layout-echelon
[
picker %
- [ 1 slot 5 slot ] %
- echelons>>
+ [ tuple-layout-echelon ] %
[
tuple assumed set
- [ engine>quot dup default set ] assoc-map
+ echelons>> dup empty? [
+ unclip-last
+ [
+ [
+ engine>quot define-engine-word
+ [ remember-engine ] [ 1quotation ] bi
+ dup default set
+ ] assoc-map
+ ]
+ [ first2 engine>quot 2array ] bi*
+ suffix
+ ] unless
] with-scope
>=-case-quot %
] [ ] make ;
diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor
index 8799169445..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
@@ -251,6 +251,14 @@ HOOK: my-tuple-hook my-var ( -- x )
M: sequence my-tuple-hook my-hook ;
+TUPLE: m-t-h-a ;
+
+M: m-t-h-a my-tuple-hook "foo" ;
+
+TUPLE: m-t-h-b < m-t-h-a ;
+
+M: m-t-h-b my-tuple-hook "bar" ;
+
[ f ] [
\ my-tuple-hook [ "engines" word-prop ] keep prefix
[ 1quotation infer ] map all-equal?
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 cf40944d1d..f60748a5ac 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -15,7 +15,7 @@ GENERIC: inline? ( word -- ? )
M: method-body inline?
"method-generic" word-prop inline? ;
-M: tuple-dispatch-engine-word inline?
+M: engine-word inline?
"tuple-dispatch-generic" word-prop inline? ;
M: word inline?
@@ -130,25 +130,27 @@ TUPLE: too-many->r ;
TUPLE: too-many-r> ;
-: check-r> ( -- )
- meta-r get empty?
+: check-r> ( n -- )
+ meta-r get length >
[ \ too-many-r> inference-error ] when ;
-: infer->r ( -- )
- 1 ensure-values
+: infer->r ( n -- )
+ dup ensure-values
#>r
- 1 0 pick node-inputs
- pop-d push-r
- 0 1 pick node-outputs
- node, ;
+ over 0 pick node-inputs
+ over [ drop pop-d ] map reverse [ push-r ] each
+ 0 pick pick node-outputs
+ node,
+ drop ;
-: infer-r> ( -- )
- check-r>
+: infer-r> ( n -- )
+ dup check-r>
#r>
- 0 1 pick node-inputs
- pop-r push-d
- 1 0 pick node-outputs
- node, ;
+ 0 pick pick node-inputs
+ over [ drop pop-r ] map reverse [ push-d ] each
+ over 0 pick node-outputs
+ node,
+ drop ;
: undo-infer ( -- )
recorded get [ f "inferred-effect" set-word-prop ] each ;
@@ -199,18 +201,18 @@ M: object constructor drop f ;
dup infer-uncurry
constructor [
peek-d reify-curry
- infer->r
+ 1 infer->r
peek-d reify-curry
- infer-r>
+ 1 infer-r>
2 1 <effect> swap #call consume/produce
] when* ;
: reify-curries ( n -- )
meta-d get reverse [
dup special? [
- over [ infer->r ] times
+ over infer->r
dup reify-curry
- over [ infer-r> ] times
+ over infer-r>
] when 2drop
] 2each ;
@@ -407,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 )
@@ -417,27 +438,17 @@ TUPLE: recursive-declare-error word ;
: <inlined-block> 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 <inlined-block>
[ 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 ;
@@ -458,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..0c4ff82798 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 ;
+
+[ 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..6d5b708f34 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> 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> 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, <class-constraint> , ;
: literal, <literal-constraint> , ;
: interval, <interval-constraint> , ;
@@ -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 <literal-constraint> assume
- value-literals get set-at ;
+ {
+ [ >r class r> set-value-class* ]
+ [ >r literal-interval r> set-value-interval* ]
+ [ <literal-constraint> 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 <repetition> ] 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 <hashtable> 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-subset 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..bb66a5386c 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 ;
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index 453e2460b0..b68c98d25d 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -54,9 +54,9 @@ IN: inference.known-words
{ swap T{ effect f 2 { 1 0 } } }
} [ define-shuffle ] assoc-each
-\ >r [ infer->r ] "infer" set-word-prop
+\ >r [ 1 infer->r ] "infer" set-word-prop
-\ r> [ infer-r> ] "infer" set-word-prop
+\ r> [ 1 infer-r> ] "infer" set-word-prop
\ declare [
1 ensure-values
@@ -81,8 +81,8 @@ M: curried infer-call
M: composed infer-call
infer-uncurry
- infer->r peek-d infer-call
- terminated? get [ infer-r> peek-d infer-call ] unless ;
+ 1 infer->r peek-d infer-call
+ terminated? get [ 1 infer-r> peek-d infer-call ] unless ;
M: object infer-call
\ literal-expected inference-warning ;
@@ -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 } { } <effect> set-primitive-effect
-\ alien>char-string { c-ptr } { string } <effect> set-primitive-effect
-\ alien>char-string make-flushable
-
-\ string>char-alien { string } { byte-array } <effect> set-primitive-effect
-\ string>char-alien make-flushable
-
-\ alien>u16-string { c-ptr } { string } <effect> set-primitive-effect
-\ alien>u16-string make-flushable
-
-\ string>u16-alien { string } { byte-array } <effect> set-primitive-effect
-\ string>u16-alien make-flushable
-
\ alien-address { alien } { integer } <effect> set-primitive-effect
\ alien-address make-flushable
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 ;
-
<PRIVATE
! UTF-16BE decoding
@@ -124,13 +121,4 @@ M: utf16 <decoder> ( stream utf16 -- decoder )
M: utf16 <encoder> ( stream utf16 -- encoder )
drop bom-le over stream-write utf16le <encoder> ;
-! Native-order UTF-16
-
-: native-utf16 ( -- descriptor )
- little-endian? utf16le utf16be ? ;
-
-M: utf16n <decoder> drop native-utf16 <decoder> ;
-
-M: utf16n <encoder> drop native-utf16 <encoder> ;
-
PRIVATE>
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 ;
+
+: <memory-stream> ( 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/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor
index eebc45511a..fe8e5bddc8 100755
--- a/core/math/integers/integers-tests.factor
+++ b/core/math/integers/integers-tests.factor
@@ -184,3 +184,10 @@ 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
diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor
index 4ca1a8637c..77d60e67f8 100755
--- a/core/math/intervals/intervals.factor
+++ b/core/math/intervals/intervals.factor
@@ -96,6 +96,8 @@ C: <interval> 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..c8a763b5f7 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"
@@ -363,6 +359,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..14cbe68351 100755
--- a/core/math/math.factor
+++ b/core/math/math.factor
@@ -55,26 +55,26 @@ 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
+: 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
: ?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
+: max ( x y -- z ) [ > ] most ; inline
+: min ( x y -- z ) [ < ] most ; inline
: between? ( x y z -- ? )
pick >= [ >= ] [ 2drop f ] if ; inline
: rem ( x y -- z ) tuck mod over + swap mod ; foldable
-: sgn ( x -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable
+: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
: [-] ( x y -- z ) - 0 max ; inline
@@ -121,7 +121,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
<PRIVATE
diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor
index 3237f095bf..9630f9dc70 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
+: compute-value-substitutions ( #call/#merge #return/#values -- assoc )
+ [ out-d>> ] [ in-d>> ] bi* 2array unify-lengths flip
[ = not ] assoc-subset >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..976156db77 100755
--- a/core/optimizer/control/control.factor
+++ b/core/optimizer/control/control.factor
@@ -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..66bffd9767 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
@@ -56,13 +60,13 @@ UNION: #killable
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
@@ -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 <reversed> ?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..bbe1d0a83f
--- /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 <effect> 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-subset
+ [ 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-subset 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/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor
index c9019b029d..c9933d5be2 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
+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.factor b/core/prettyprint/prettyprint.factor
index 525749cfae..981c8dcfd0 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
diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor
index 319e5eab65..803f6e2459 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 ;
diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index bb3dc9337e..0dea0f43d9 100755
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -76,10 +76,7 @@ ARTICLE: "sequences-reshape" "Reshaping sequences"
{ $subsection reversed }
{ $subsection <reversed> }
"Transposing a matrix:"
-{ $subsection flip }
-"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
-{ $subsection column }
-{ $subsection <column> } ;
+{ $subsection flip } ;
ARTICLE: "sequences-appending" "Appending sequences"
{ $subsection append }
@@ -785,23 +782,6 @@ HELP: <slice>
{ <slice> 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 <column> } "." } ;
-
-HELP: <column> ( 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 <column> >array ."
- "{ 1 4 7 }"
- }
-}
-{ $notes
- "In the same sense that " { $link <reversed> } " is a virtual variant of " { $link reverse } ", " { $link <column> } " 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 <repetition> } "." } ;
diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor
index e8db18b3d0..100184798c 100755
--- a/core/sequences/sequences-tests.factor
+++ b/core/sequences/sequences-tests.factor
@@ -224,13 +224,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 <column> >array ] unit-test
-[ ] [ "seq" get 1 <column> [ sq ] change-each ] unit-test
-[ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
-
! erg's random tester found this one
[ SBUF" 12341234" ] [
9 <sbuf> dup "1234" swap push-all dup dup swap push-all
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 252df54391..924d9a05cb 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -215,18 +215,6 @@ M: slice length dup slice-to swap slice-from - ;
INSTANCE: slice virtual-sequence
-! A column of a matrix
-TUPLE: column seq col ;
-
-C: <column> 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 ;
@@ -703,5 +691,5 @@ PRIVATE>
: flip ( matrix -- newmatrix )
dup empty? [
dup [ length ] map infimum
- [ <column> dup like ] with map
+ swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as
] unless ;
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index c2eb411f0a..a2d15d2981 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" } ;
@@ -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" } }
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index eaf5ffea05..566f5471f4 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 <wrapper> ] parse-literal ] define-syntax
diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor
index a2c50346df..3f9ff54ac8 100755
--- a/core/threads/threads-docs.factor
+++ b/core/threads/threads-docs.factor
@@ -26,7 +26,7 @@ ARTICLE: "threads-yield" "Yielding and suspending threads"
{ $subsection resume }
{ $subsection resume-with } ;
-ARTICLE: "thread-state" "Thread-local state"
+ARTICLE: "thread-state" "Thread-local state and variables"
"Threads form a class of objects:"
{ $subsection thread }
"The current thread:"
@@ -36,6 +36,8 @@ ARTICLE: "thread-state" "Thread-local state"
{ $subsection tget }
{ $subsection tset }
{ $subsection tchange }
+"Each thread has its own independent set of thread-local variables and newly-spawned threads begin with an empty set."
+$nl
"Global hashtable of all threads, keyed by " { $link thread-id } ":"
{ $subsection threads }
"Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ;
diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor
index d746404cba..0ac607f0ed 100755
--- a/core/threads/threads-tests.factor
+++ b/core/threads/threads-tests.factor
@@ -1,4 +1,5 @@
-USING: namespaces io tools.test threads kernel ;
+USING: namespaces io tools.test threads kernel
+concurrency.combinators math ;
IN: threads.tests
3 "x" set
@@ -16,3 +17,13 @@ yield
] unit-test
[ f ] [ f get-global ] unit-test
+
+{ { 0 3 6 9 12 15 18 21 24 27 } } [
+ 10 [
+ 0 "i" tset
+ [
+ "i" [ yield 3 + ] tchange
+ ] times yield
+ "i" tget
+ ] parallel-map
+] unit-test
diff --git a/core/threads/threads.factor b/core/threads/threads.factor
index f99191b91f..2f9c3a73de 100755
--- a/core/threads/threads.factor
+++ b/core/threads/threads.factor
@@ -27,7 +27,7 @@ mailbox variables sleep-entry ;
tnamespace set-at ;
: tchange ( key quot -- )
- tnamespace change-at ; inline
+ tnamespace swap change-at ; inline
: threads 41 getenv ;
diff --git a/extra/benchmark/binary-trees/binary-trees.factor b/extra/benchmark/binary-trees/binary-trees.factor
new file mode 100644
index 0000000000..be4620bff6
--- /dev/null
+++ b/extra/benchmark/binary-trees/binary-trees.factor
@@ -0,0 +1,55 @@
+USING: kernel math accessors prettyprint io locals sequences
+math.ranges ;
+IN: benchmark.binary-trees
+
+TUPLE: tree-node item left right ;
+
+C: <tree-node> 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 <tree-node> ;
+
+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 <range> [| 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/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/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 <float-array> dup
+:: u/v ( n -- u v )
+ n 1.0 <float-array> 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 <bit-vector> }
+"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: <bit-vector>
{ $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) ;
+
<PRIVATE
: bit-array>vector ( bit-array length -- bit-vector )
@@ -14,7 +25,8 @@ PRIVATE>
: <bit-vector> ( n -- bit-vector )
<bit-array> 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 <bit-vector> ;
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/builder/cleanup/cleanup.factor b/extra/builder/cleanup/cleanup.factor
index 327b90e01f..e601506fb4 100644
--- a/extra/builder/cleanup/cleanup.factor
+++ b/extra/builder/cleanup/cleanup.factor
@@ -8,6 +8,8 @@ IN: builder.cleanup
SYMBOL: builder-debug
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
: delete-child-factor ( -- )
diff --git a/extra/builder/common/common.factor b/extra/builder/common/common.factor
index e3c207eaaa..474606e451 100644
--- a/extra/builder/common/common.factor
+++ b/extra/builder/common/common.factor
@@ -7,6 +7,10 @@ IN: builder.common
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+SYMBOL: upload-to-factorcode
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
SYMBOL: builds-dir
: builds ( -- path )
@@ -21,15 +25,6 @@ VAR: stamp
: builds/factor ( -- path ) builds "factor" append-path ;
: build-dir ( -- path ) builds stamp> append-path ;
-: create-build-dir ( -- )
- datestamp >stamp
- build-dir make-directory ;
-
-: enter-build-dir ( -- ) build-dir set-current-directory ;
-
-: clone-builds-factor ( -- )
- { "git" "clone" builds/factor } to-strings try-process ;
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: prepare-build-machine ( -- )
@@ -57,8 +52,3 @@ SYMBOL: status
{ status-vm status-boot status-test status-build status-release status }
[ off ]
each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: upload-to-factorcode
-
diff --git a/extra/builder/email/email.factor b/extra/builder/email/email.factor
index eed48cb177..ecde47f8f7 100644
--- a/extra/builder/email/email.factor
+++ b/extra/builder/email/email.factor
@@ -8,6 +8,8 @@ IN: builder.email
SYMBOL: builder-from
SYMBOL: builder-recipients
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: subject-status ( -- str ) status get [ "report" ] [ "error" ] if ;
: subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ;
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 <byte-vector> }
+"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: <byte-vector>
{ $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) ;
+
<PRIVATE
: byte-array>vector ( byte-array length -- byte-vector )
@@ -14,7 +25,8 @@ PRIVATE>
: <byte-vector> ( n -- byte-vector )
<byte-array> 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 <byte-vector> ;
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..c05d4f60eb 100755
--- a/extra/calendar/calendar-tests.factor
+++ b/extra/calendar/calendar-tests.factor
@@ -2,6 +2,10 @@ USING: arrays calendar kernel math sequences tools.test
continuations system ;
IN: calendar.tests
+\ time+ must-infer
+\ time* must-infer
+\ time- must-infer
+
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor
index 8dcb4af7f1..2f93bf8218 100755
--- a/extra/calendar/calendar.factor
+++ b/extra/calendar/calendar.factor
@@ -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 <duration>
+ ] if ;
+
: before ( dt -- -dt )
- [ year>> neg ] keep
- [ month>> neg ] keep
- [ day>> neg ] keep
- [ hour>> neg ] keep
- [ minute>> neg ] keep
- second>> neg
- <duration> ;
+ -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..1ba892bef3 100755
--- a/extra/calendar/format/format-tests.factor
+++ b/extra/calendar/format/format-tests.factor
@@ -1,26 +1,45 @@
-USING: calendar.format calendar kernel tools.test
-io.streams.string ;
+USING: calendar.format calendar kernel math tools.test
+io.streams.string accessors io ;
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
diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor
index 26ed873fd3..7bdaea70b5 100755
--- a/extra/calendar/format/format.factor
+++ b/extra/calendar/format/format.factor
@@ -1,5 +1,6 @@
USING: math math.parser kernel sequences io calendar
-accessors arrays io.streams.string combinators accessors ;
+accessors arrays io.streams.string splitting
+combinators accessors debugger ;
IN: calendar.format
GENERIC: day. ( obj -- )
@@ -58,11 +59,11 @@ M: timestamp year. ( timestamp -- )
[ hour>> write-00 ] [ minute>> write-00 ] 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 ;
+ dup instant <=> sgn {
+ { 0 [ drop "GMT" write ] }
+ { -1 [ "-" write before (write-gmt-offset) ] }
+ { 1 [ "+" write (write-gmt-offset) ] }
+ } case ;
: timestamp>rfc822 ( timestamp -- str )
#! RFC822 timestamp format
@@ -83,20 +84,22 @@ M: timestamp year. ( timestamp -- )
[ minute>> write-00 ] 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 ;
+ dup instant <=> sgn {
+ { 0 [ drop "Z" write ] }
+ { -1 [ CHAR: - write1 before (write-rfc3339-gmt-offset) ] }
+ { 1 [ CHAR: + write1 (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 ;
+ {
+ [ year>> number>string write CHAR: - write1 ]
+ [ month>> write-00 CHAR: - write1 ]
+ [ day>> write-00 CHAR: T write1 ]
+ [ hour>> write-00 CHAR: : write1 ]
+ [ minute>> write-00 CHAR: : write1 ]
+ [ second>> >fixnum write-00 ]
+ [ gmt-offset>> write-rfc3339-gmt-offset ]
+ } cleave ;
: timestamp>rfc3339 ( timestamp -- str )
[ (timestamp>rfc3339) ] with-string-writer ;
@@ -106,14 +109,20 @@ M: timestamp year. ( timestamp -- )
: read-00 2 read string>number ;
+: read-000 3 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 / + *
+: signed-gmt-offset ( dt ch -- dt' )
+ { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
+
+: 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,26 +135,61 @@ 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
<timestamp> ;
: rfc3339>timestamp ( str -- timestamp )
[ (rfc3339>timestamp) ] with-string-reader ;
+ERROR: invalid-rfc822-date ;
+
+: check-rfc822-date ( obj/f -- obj ) [ invalid-rfc822-date ] unless* ;
+
+: read-token ( seps -- token )
+ [ read-until ] keep member? check-rfc822-date drop ;
+
+: read-sp ( -- token ) " " read-token ;
+
+: checked-number ( str -- n )
+ string>number check-rfc822-date ;
+
+: 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-rfc822-date drop
+ read1 CHAR: \s assert=
+ read-sp checked-number >>day
+ read-sp month-abbreviations index check-rfc822-date >>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 ;
+
: (ymdhms>timestamp) ( -- timestamp )
- read-ymd " " expect read-hms 0 <timestamp> ;
+ read-ymd " " expect read-hms instant <timestamp> ;
: ymdhms>timestamp ( str -- timestamp )
[ (ymdhms>timestamp) ] with-string-reader ;
: (hms>timestamp) ( -- timestamp )
- f f f read-hms f <timestamp> ;
+ f f f read-hms instant <timestamp> ;
: hms>timestamp ( str -- timestamp )
[ (hms>timestamp) ] with-string-reader ;
: (ymd>timestamp) ( -- timestamp )
- read-ymd f f f f <timestamp> ;
+ read-ymd f f f instant <timestamp> ;
: ymd>timestamp ( str -- timestamp )
[ (ymd>timestamp) ] with-string-reader ;
diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor
index ca9509c3ec..df3f84d451 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 <void*> 0 <int> over
>r method_getArgumentInfo drop
- r> *char* ;
+ r> *void* ascii alien>string ;
SYMBOL: objc>alien-types
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 ;
: <empty-method-list> ( n -- alien )
@@ -26,7 +27,7 @@ IN: cocoa.subclassing
: <objc-class> ( 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 ;
: <protocol-list> ( 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 <column> } ;
+
+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 <column> } "." } ;
+
+HELP: <column> ( 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 <column> >array ."
+ "{ 1 4 7 }"
+ }
+}
+{ $notes
+ "In the same sense that " { $link <reversed> } " is a virtual variant of " { $link reverse } ", " { $link <column> } " 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 <column> >array ] unit-test
+[ ] [ "seq" get 1 <column> [ sq ] change-each ] unit-test
+[ { 4 25 64 } ] [ "seq" get 1 <column> >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> 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/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" <c-array> [
>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..67a4e59d04 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
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
@@ -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/db/db.factor b/extra/db/db.factor
index baf4e9db5a..82193ed467 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 -- )
@@ -36,17 +36,25 @@ HOOK: db-close db ( handle -- )
] 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 +63,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: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> 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 +80,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 -- )
diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor
index bfe7dab3ce..d270e6f40d 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,28 +64,22 @@ 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 ;
-
: 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 ] }
+ 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
+ utf8 malloc-string dup free-always
] when 0
]
} case 2array
@@ -90,22 +90,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 +111,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 ;
@@ -152,6 +150,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
dup array? [ first ] when
{
{ +native-id+ [ pq-get-number ] }
+ { +random-id+ [ pq-get-number ] }
{ INTEGER [ pq-get-number ] }
{ BIG-INTEGER [ pq-get-number ] }
{ DOUBLE [ pq-get-number ] }
@@ -167,4 +166,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..687146af11 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -5,19 +5,16 @@ 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 ;
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 ;
-: <postgresql-statement> ( statement in out -- postgresql-statement )
- postgresql-statement construct-statement ;
-
M: postgresql-db make-db* ( seq tuple -- db )
>r first4 r>
swap >>db
@@ -42,11 +39,21 @@ 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 <low-level-binding> ;
+
+M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- obj )
+ nip value>> <low-level-binding> ;
+
+M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- obj )
+ nip singleton>> eval-generator <low-level-binding> ;
+
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 +61,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 +82,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 <simple-statement> ( sql in out -- statement )
- <postgresql-statement> ;
+ postgresql-statement construct-statement ;
M: postgresql-db <prepared-statement> ( sql in out -- statement )
- <postgresql-statement> dup prepare-statement ;
+ <simple-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
- <postgresql-statement> ; inline
+M: postgresql-db bind# ( spec obj -- )
+ >r bind-name% f swap type>> r> <literal-bind> 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 +140,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,12 +148,12 @@ 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 )
[
@@ -168,14 +167,14 @@ 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 )
[
@@ -192,107 +191,69 @@ M: postgresql-db <insert-native-statement> ( class -- statement )
remove-id
[ ", " 0% ] [ bind% ] interleave
");" 0%
- ] postgresql-make ;
+ ] query-make ;
M: postgresql-db <insert-nonnative-statement> ( 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+ = [
+ [
+ drop bind-name%
+ f random-id-generator
+ ] [ type>> ] bi <generator-bind> 1,
+ ] [
+ bind%
+ ] if
+ ] interleave
");" 0%
- ] postgresql-make ;
+ ] query-make ;
M: postgresql-db insert-tuple* ( tuple statement -- )
query-modify-tuple ;
-M: postgresql-db <update-tuple-statement> ( 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 <delete-tuple-statement> ( class -- statement )
- [
- "delete from " 0% 0%
- " where " 0%
- find-primary-key
- dup sql-spec-column-name 0% " = " 0% bind%
- ] postgresql-make ;
-
-M: postgresql-db <select-by-slots-statement> ( 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" }
+ { +native-id+ { "integer" "serial primary key" f } }
+ { +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..c9fd9a38a4
--- /dev/null
+++ b/extra/db/queries/queries.factor
@@ -0,0 +1,100 @@
+! 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 ] { "" { } { } } nmake
+ <simple-statement> 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 <update-tuple-statement> ( class -- statement )
+ [
+ "update " 0% 0%
+ " set " 0%
+ dup remove-id
+ [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
+ where-primary-key%
+ ] query-make ;
+
+M: db <delete-tuple-statement> ( specs table -- sql )
+ [
+ "delete from " 0% 0%
+ " where " 0%
+ find-primary-key
+ dup column-name>> 0% " = " 0% bind%
+ ] 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 ;
+
+: where-interval ( spec obj from/to -- )
+ pick column-name>> 0%
+ >r first2 r> interval-comparison 0%
+ bind# ;
+
+: in-parens ( quot -- )
+ "(" 0% call ")" 0% ; inline
+
+M: interval where ( spec obj -- )
+ [
+ [ from>> "from" where-interval " and " 0% ]
+ [ to>> "to" where-interval ] 2bi
+ ] 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 ;
+
+: where-clause ( tuple specs -- )
+ " where " 0% [
+ " and " 0%
+ ] [
+ 2dup slot-name>> swap get-slot-named where
+ ] interleave drop ;
+
+M: db <select-by-slots-statement> ( tuple class -- statement )
+ [
+ "select " 0%
+ over [ ", " 0% ]
+ [ dup column-name>> 0% 2, ] interleave
+
+ " from " 0% 0%
+ dupd
+ [ slot-name>> swap get-slot-named ] with subset
+ dup empty? [ 2drop ] [ where-clause ] if ";" 0%
+ ] 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..4561424a9d 100755
--- a/extra/db/sql/sql.factor
+++ b/extra/db/sql/sql.factor
@@ -27,27 +27,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 +55,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..e5562700c9 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 ;
+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*" <c-object>
[ sqlite3_open sqlite-check-result ] keep *void* ;
@@ -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,6 +92,8 @@ 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 ] }
@@ -98,12 +107,15 @@ IN: db.sqlite.lib
sqlite-bind-blob-by-name
] }
{ +native-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 ] }
+ { +native-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..2407613eca 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,48 @@ 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 ;
+: <sqlite-low-level-binding> ( 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 <sqlite-low-level-binding> ;
+
+M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
+ nip [ key>> ] [ value>> ] [ type>> ] tri
+ <sqlite-low-level-binding> ;
+
+M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
+ nip [ key>> ] [ singleton>> eval-generator ] [ type>> ] tri
+ <sqlite-low-level-binding> ;
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,27 +115,19 @@ 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 <simple-statement> ; 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 <insert-native-statement> ( tuple -- statement )
[
@@ -122,91 +136,62 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
maybe-remove-id
dup [ ", " 0% ] [ column-name>> 0% ] interleave
") values(" 0%
- [ ", " 0% ] [ bind% ] interleave
+ [ ", " 0% ] [
+ dup type>> +random-id+ = [
+ [
+ column-name>> ":" prepend dup 0%
+ random-id-generator
+ ] [ type>> ] bi <generator-bind> 1,
+ ] [
+ bind%
+ ] if
+ ] interleave
");" 0%
- ] sqlite-make ;
+ ] query-make ;
M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
<insert-native-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 <update-tuple-statement> ( 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 <delete-tuple-statement> ( 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> <literal-bind> 1, ;
M: sqlite-db bind% ( spec -- )
dup 1, column-name>> ":" prepend 0% ;
-M: sqlite-db <select-by-slots-statement> ( 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" }
+ { +native-id+ { "integer primary key" "integer primary key" "primary key" } }
+ { +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..32562a4ae8 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 tools.walker 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
@@ -80,9 +80,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 +96,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,13 +106,6 @@ 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 ( -- )
person "PERSON"
{
@@ -192,7 +185,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 ;
@@ -212,12 +204,9 @@ 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+ }
@@ -233,12 +222,84 @@ 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 ;
+
+TUPLE: bignum-test id m n o ;
+: <bignum-test> ( m n o -- obj )
+ bignum-test new
+ swap >>o
+ swap >>n
+ swap >>m ;
+
+: test-bignum
+ bignum-test "BIGNUM_TEST"
+ {
+ { "id" "ID" +native-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 <bignum-test> 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> secret
@@ -246,27 +307,59 @@ C: <secret> 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" <secret> insert-tuple ] unit-test
- [ ] [ T{ secret } select-tuples ] unit-test
- ;
+ [ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test
+ [ ] [ f "kilroy was here3" <secret> 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
+ [ t ] [
+ T{ secret } select-tuples
+ first message>> "kilroy was here" head?
+ ] 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 length 3 =
+ ] unit-test ;
+
+[ native-person-schema test-tuples ] test-sqlite
+[ assigned-person-schema test-tuples ] test-sqlite
+[ 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
+
+[ native-person-schema test-tuples ] test-postgresql
+[ assigned-person-schema test-tuples ] test-postgresql
+[ 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-tuple must-infer
+\ select-tuple must-infer
+\ define-persistent must-infer
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index 311f18daa9..fd4cfb906f 100755
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -1,7 +1,7 @@
! 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 ;
IN: db.tuples
@@ -13,15 +13,26 @@ 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 )
@@ -39,26 +50,55 @@ HOOK: <select-by-slots-statement> 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? [
+ 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? [
@@ -85,17 +125,13 @@ HOOK: insert-tuple* db ( tuple statement -- )
[ bind-tuple ] 2keep insert-tuple* ;
: insert-nonnative ( tuple -- )
-! TODO logic here for unique ids
dup class
db get db-insert-statements [ <insert-nonnative-statement> ] 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 nonnative-id?
+ [ insert-nonnative ] [ insert-native ] if ;
: update-tuple ( tuple -- )
dup class
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index 98bc451a6f..110a8a388a 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -4,16 +4,23 @@ 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 ;
+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 ;
+
+TUPLE: literal-bind key type value ;
+C: <literal-bind> literal-bind
+
+TUPLE: generator-bind key singleton type ;
+C: <generator-bind> generator-bind
+SINGLETON: random-id-generator
+
+TUPLE: low-level-binding value ;
+C: <low-level-binding> low-level-binding
SINGLETON: +native-id+
SINGLETON: +assigned-id+
@@ -24,50 +31,54 @@ UNION: +nonnative-id+ +random-id+ +assigned-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+? ;
+ primary-key>> +native-id+? ;
: nonnative-id? ( spec -- ? )
- sql-spec-primary-key +nonnative-id+? ;
+ primary-key>> +nonnative-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 ;
@@ -78,40 +89,40 @@ TUPLE: no-sql-modifier ;
[ relation? not ] subset ;
: remove-id ( specs -- obj )
- [ sql-spec-primary-key not ] subset ;
+ [ primary-key>> not ] subset ;
! 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 +136,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 ;
@@ -145,6 +156,6 @@ HOOK: bind% db ( spec -- )
: 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/editors/vim/generate-syntax/generate-syntax.factor b/extra/editors/vim/generate-syntax/generate-syntax.factor
index 178a1b3b8b..325a451a0b 100644
--- a/extra/editors/vim/generate-syntax/generate-syntax.factor
+++ b/extra/editors/vim/generate-syntax/generate-syntax.factor
@@ -1,9 +1,10 @@
! Generate a new factor.vim file for syntax highlighting
-USING: http.server.templating.fhtml io.files ;
+USING: http.server.templating http.server.templating.fhtml
+io.files ;
IN: editors.vim.generate-syntax
: generate-vim-syntax ( -- )
- "misc/factor.vim.fgen" resource-path
+ "misc/factor.vim.fgen" resource-path <fhtml>
"misc/factor.vim" resource-path
template-convert ;
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 ;
+ <process> 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/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor
index af4ddd8839..7176486f8e 100755
--- a/extra/farkup/farkup-tests.factor
+++ b/extra/farkup/farkup-tests.factor
@@ -54,10 +54,12 @@ IN: farkup.tests
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
-[ "<span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/>" ]
+[ "<div style='white-space: pre; font-family: monospace; '><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/></div>" ]
[ "[c{int main()}]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
[ "<p><a href=\"lol.com\"></a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
+
+[ ] [ "[{}]" convert-farkup drop ] unit-test
diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor
index f876c9569b..527ba8b4fa 100755
--- a/extra/farkup/farkup.factor
+++ b/extra/farkup/farkup.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io kernel memoize namespaces peg sequences strings
-html.elements xml.entities xmode.code2html splitting
-io.streams.string html peg.parsers html.elements sequences.deep
-unicode.categories ;
+USING: arrays io io.styles kernel memoize namespaces peg
+sequences strings html.elements xml.entities xmode.code2html
+splitting io.streams.string html peg.parsers html.elements
+sequences.deep unicode.categories ;
IN: farkup
<PRIVATE
@@ -55,7 +55,13 @@ MEMO: eq ( -- parser )
: render-code ( string mode -- string' )
>r string-lines r>
- [ [ htmlize-lines ] with-html-stream ] with-string-writer ;
+ [
+ [
+ H{ { wrap-margin f } } [
+ htmlize-lines
+ ] with-nesting
+ ] with-html-stream
+ ] with-string-writer ;
: escape-link ( href text -- href-esc text-esc )
>r escape-quoted-string r> escape-string ;
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 <float-vector> }
+"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: <float-vector>
{ $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) ;
+
<PRIVATE
: float-array>vector ( float-array length -- float-vector )
@@ -14,7 +25,8 @@ PRIVATE>
: <float-vector> ( n -- float-vector )
0.0 <float-array> 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 <float-vector> ;
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..7621af6899 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
] 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? ] subset length
+ \ , <repetition> %
+ ]
+ [ deep-fry % ] bi
+ ] [ namespaces:, ] if
+ ] each
+ ] [ ] make deep-fry ;
+
: '[ \ ] parse-until fry over push-all ; parsing
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
[ <byte-array> ] [ <uint> ] 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
<int> 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 )
<int> 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..10474c09f7 100755
--- a/extra/hardware-info/windows/windows.factor
+++ b/extra/hardware-info/windows/windows.factor
@@ -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 [ <u16-string-object> ] 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/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index 4e6bfe4888..15e3b8be1d 100755
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -145,9 +145,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 +163,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
diff --git a/extra/help/help.factor b/extra/help/help.factor
index aa2704a799..e0b2709932 100755
--- a/extra/help/help.factor
+++ b/extra/help/help.factor
@@ -38,7 +38,7 @@ 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 <column> ;
+ [ dup article-title ] { } map>assoc sort-values keys ;
: all-errors ( -- seq )
all-words [ error? ] subset sort-articles ;
diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor
index 754afb1ea7..41e29fc712 100644
--- a/extra/html/elements/elements.factor
+++ b/extra/html/elements/elements.factor
@@ -161,6 +161,6 @@ SYMBOL: html
"id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
- "media"
+ "media" "title"
] [ define-attribute-word ] each
] with-compilation-unit
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..cc356ca8e3 100755
--- a/extra/http/client/client.factor
+++ b/extra/http/client/client.factor
@@ -3,9 +3,17 @@
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 ;
+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
<PRIVATE
@@ -29,22 +37,29 @@ DEFER: http-request
: relative-redirect ( path -- request )
request get swap store-path ;
+SYMBOL: redirects
+
+: absolute-url? ( url -- ? )
+ [ "http://" head? ] [ "https://" head? ] bi or ;
+
: do-redirect ( response -- response stream )
dup response-code 300 399 between? [
stdio get dispose
- header>> "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>> <inet> ;
-
: 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 ;
+
: <get-request> ( url -- request )
<request> request-with-url "GET" >>method ;
-: http-get-stream ( url -- response stream )
- <get-request> http-request ;
+: string-or-contents ( stream/string -- string )
+ dup string? [ contents ] unless ;
+
+: http-get-stream ( url -- response stream/string )
+ <get-request> 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 <file-writer> stream-copy ] with-disposal ;
+ swap http-get-stream check-response
+ dup string? [
+ latin1 [ write ] with-file-writer
+ ] [
+ [ swap latin1 <file-writer> 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 )
- <post-request> http-request contents ;
+ <post-request> http-request do-chunked-encoding string-or-contents ;
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index d1ffce721d..3a50630335 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -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
@@ -143,6 +146,9 @@ io.encodings.ascii ;
<dispatcher>
"extra/http/test" resource-path <static> >>default
"nested" add-responder
+ <action>
+ [ "redirect-loop" f <permanent-redirect> ] >>display
+ "redirect-loop" add-responder
main-responder set
[ 1237 httpd ] "HTTPD test" spawn drop
@@ -159,11 +165,14 @@ io.encodings.ascii ;
"localhost" 1237 <inet> ascii <client> [
"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
diff --git a/extra/http/http.factor b/extra/http/http.factor
index e792802b5a..3e81fccd24 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 )
@@ -175,13 +191,17 @@ post-data
post-data-type
cookies ;
+: set-header ( request/response value key -- request/response )
+ pick header>> set-at ;
+
: <request>
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 +240,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 +315,15 @@ SYMBOL: max-post-request
"application/x-www-form-urlencoded" >>post-data-type
] if ;
+: request-addr ( request -- addr )
+ [ host>> ] [ port>> ] bi <inet> ;
+
+: request-host ( request -- string )
+ [ host>> ] [ drop ":" ] [ port>> number>string ] tri 3append ;
+
: 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 +356,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 +370,11 @@ body ;
: <response>
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 +388,7 @@ body ;
>>code ;
: read-response-message
- readln >>message ;
+ read-crlf >>message ;
: read-response-header
read-header >>header
@@ -394,13 +417,18 @@ body ;
[ unparse-cookies "set-cookie" pick set-at ] when*
write-header ;
+GENERIC: write-response-body* ( body -- )
+
+M: f write-response-body* drop ;
+
+M: string write-response-body* write ;
+
+M: callable write-response-body* call ;
+
+M: object write-response-body* stdio get stream-copy ;
+
: write-response-body ( response -- response )
- dup body>> {
- { [ dup not ] [ drop ] }
- { [ dup string? ] [ write ] }
- { [ dup callable? ] [ call ] }
- [ stdio get stream-copy ]
- } cond ;
+ dup body>> write-response-body* ;
M: response write-response ( respose -- )
write-response-version
diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor
index ebf8e8770b..90e632d7f5 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 ;
[
"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,7 +22,8 @@ blah
;
[ 25 ] [
- action-request-test-1 [ read-request ] with-string-reader
+ action-request-test-1 lf>crlf
+ [ read-request ] with-string-reader
request set
"/blah"
"action-1" get call-responder
@@ -40,7 +43,8 @@ xxx=4
;
[ "/blahXXXX" ] [
- action-request-test-2 [ read-request ] with-string-reader
+ action-request-test-2 lf>crlf
+ [ read-request ] with-string-reader
request set
"/blah"
"action-2" get call-responder
diff --git a/extra/http/server/auth/login/boilerplate.xml b/extra/http/server/auth/login/boilerplate.xml
new file mode 100644
index 0000000000..edc8c329df
--- /dev/null
+++ b/extra/http/server/auth/login/boilerplate.xml
@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
diff --git a/extra/http/server/auth/login/edit-profile.fhtml b/extra/http/server/auth/login/edit-profile.fhtml
deleted file mode 100755
index 7d94ca1791..0000000000
--- a/extra/http/server/auth/login/edit-profile.fhtml
+++ /dev/null
@@ -1,77 +0,0 @@
-<% USING: http.server.components http.server.auth.login
-http.server namespaces kernel combinators ; %>
-<html>
-<body>
-<h1>Edit profile</h1>
-
-<form method="POST" action="edit-profile">
-<% hidden-form-field %>
-
-<table>
-
-<tr>
-<td>User name:</td>
-<td><% "username" component render-view %></td>
-</tr>
-
-<tr>
-<td>Real name:</td>
-<td><% "realname" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>Specifying a real name is optional.</td>
-</tr>
-
-<tr>
-<td>Current password:</td>
-<td><% "password" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>If you don't want to change your current password, leave this field blank.</td>
-</tr>
-
-<tr>
-<td>New password:</td>
-<td><% "new-password" component render-edit %></td>
-</tr>
-
-<tr>
-<td>Verify:</td>
-<td><% "verify-password" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>If you are changing your password, enter it twice to ensure it is correct.</td>
-</tr>
-
-<tr>
-<td>E-mail:</td>
-<td><% "email" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
-</tr>
-
-</table>
-
-<p><input type="submit" value="Update" />
-
-<% {
- { [ login-failed? get ] [ "invalid password" render-error ] }
- { [ password-mismatch? get ] [ "passwords do not match" render-error ] }
- { [ t ] [ ] }
-} cond %>
-
-</p>
-
-</form>
-
-</body>
-</html>
diff --git a/extra/http/server/auth/login/edit-profile.xml b/extra/http/server/auth/login/edit-profile.xml
new file mode 100644
index 0000000000..86a4e86551
--- /dev/null
+++ b/extra/http/server/auth/login/edit-profile.xml
@@ -0,0 +1,77 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit Profile</t:title>
+
+ <t:form action="edit-profile">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:view component="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:edit component="realname" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying a real name is optional.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Current password:</th>
+ <td><t:edit component="password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>If you don't want to change your current password, leave this field blank.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">New password:</th>
+ <td><t:edit component="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:edit component="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>If you are changing your password, enter it twice to ensure it is correct.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:edit component="email" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+ </tr>
+
+ </table>
+
+ <p>
+ <input type="submit" value="Update" />
+
+ <t:if var="http.server.auth.login:login-failed?">
+ <t:error>invalid password</t:error>
+ </t:if>
+
+ <t:if var="http.server.auth.login:password-mismatch?">
+ <t:error>passwords do not match</t:error>
+ </t:if>
+ </p>
+
+ </t:form>
+
+</t:chloe>
diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor
index 4f04a1ff9b..7593f217f7 100755
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@@ -15,7 +15,9 @@ http.server.actions
http.server.components
http.server.forms
http.server.sessions
-http.server.templating.fhtml
+http.server.boilerplate
+http.server.templating
+http.server.templating.chloe
http.server.validators ;
IN: http.server.auth.login
QUALIFIED: smtp
@@ -40,11 +42,15 @@ M: user-saver dispose
: save-user-after ( user -- )
<user-saver> add-always-destructor ;
+: login-template ( name -- template )
+ "resource:extra/http/server/auth/login/" swap ".xml"
+ 3append <chloe> ;
+
! ! ! Login
: <login-form>
"login" <form>
- "resource:extra/http/server/auth/login/login.fhtml" >>edit-template
+ "login" login-template >>edit-template
"username" <username>
t >>required
add-field
@@ -62,10 +68,7 @@ M: user-saver dispose
<action>
[ blank-values ] >>init
- [
- "text/html" <content>
- [ form edit-form ] >>body
- ] >>display
+ [ form edit-form ] >>display
[
blank-values
@@ -86,7 +89,7 @@ M: user-saver dispose
: <register-form> ( -- form )
"register" <form>
- "resource:extra/http/server/auth/login/register.fhtml" >>edit-template
+ "register" login-template >>edit-template
"username" <username>
t >>required
add-field
@@ -114,10 +117,7 @@ SYMBOL: user-exists?
<action>
[ blank-values ] >>init
- [
- "text/html" <content>
- [ form edit-form ] >>body
- ] >>display
+ [ form edit-form ] >>display
[
blank-values
@@ -147,7 +147,7 @@ SYMBOL: user-exists?
: <edit-profile-form> ( -- form )
"edit-profile" <form>
- "resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template
+ "edit-profile" login-template >>edit-template
"username" <username> add-field
"realname" <string> add-field
"password" <password> add-field
@@ -168,10 +168,7 @@ SYMBOL: previous-page
dup email>> "email" set-value
] >>init
- [
- "text/html" <content>
- [ form edit-form ] >>body
- ] >>display
+ [ form edit-form ] >>display
[
blank-values
@@ -242,7 +239,7 @@ SYMBOL: lost-password-from
: <recover-form-1> ( -- form )
"register" <form>
- "resource:extra/http/server/auth/login/recover-1.fhtml" >>edit-template
+ "recover-1" login-template >>edit-template
"username" <username>
t >>required
add-field
@@ -256,10 +253,7 @@ SYMBOL: lost-password-from
<action>
[ blank-values ] >>init
- [
- "text/html" <content>
- [ form edit-form ] >>body
- ] >>display
+ [ form edit-form ] >>display
[
blank-values
@@ -271,13 +265,13 @@ SYMBOL: lost-password-from
send-password-email
] when*
- "resource:extra/http/server/auth/login/recover-2.fhtml" serve-template
+ "recover-2" login-template serve-template
] >>submit
] ;
: <recover-form-3>
"new-password" <form>
- "resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template
+ "recover-3" login-template >>edit-template
"username" <username>
hidden >>renderer
t >>required
@@ -308,10 +302,7 @@ SYMBOL: lost-password-from
] H{ } make-assoc values set
] >>init
- [
- "text/html" <content>
- [ <recover-form-3> edit-form ] >>body
- ] >>display
+ [ <recover-form-3> edit-form ] >>display
[
blank-values
@@ -326,8 +317,7 @@ SYMBOL: lost-password-from
"new-password" value >>password
users update-user
- "resource:extra/http/server/auth/login/recover-4.fhtml"
- serve-template
+ "recover-4" login-template serve-template
] [
<400>
] if*
@@ -367,24 +357,32 @@ M: login call-responder ( path responder -- response )
dup login set
call-next-method ;
+: <login-boilerplate> ( responder -- responder' )
+ <boilerplate>
+ "boilerplate" login-template >>template ;
+
: <login> ( responder -- auth )
login new-dispatcher
- swap <protected> >>default
- <login-action> "login" add-responder
- <logout-action> "logout" add-responder
+ swap >>default
+ <login-action> <login-boilerplate> "login" add-responder
+ <logout-action> <login-boilerplate> "logout" add-responder
no-users >>users ;
! ! ! Configuration
: allow-edit-profile ( login -- login )
- <edit-profile-action> <protected> "edit-profile" add-responder ;
+ <edit-profile-action> <protected> <login-boilerplate>
+ "edit-profile" add-responder ;
: allow-registration ( login -- login )
- <register-action> "register" add-responder ;
+ <register-action> <login-boilerplate>
+ "register" add-responder ;
: allow-password-recovery ( login -- login )
- <recover-action-1> "recover-password" add-responder
- <recover-action-3> "new-password" add-responder ;
+ <recover-action-1> <login-boilerplate>
+ "recover-password" add-responder
+ <recover-action-3> <login-boilerplate>
+ "new-password" add-responder ;
: allow-edit-profile? ( -- ? )
login get responders>> "edit-profile" swap key? ;
diff --git a/extra/http/server/auth/login/login.fhtml b/extra/http/server/auth/login/login.fhtml
deleted file mode 100755
index 07201719e5..0000000000
--- a/extra/http/server/auth/login/login.fhtml
+++ /dev/null
@@ -1,46 +0,0 @@
-<% USING: http.server.auth.login http.server.components http.server
-kernel namespaces ; %>
-<html>
-<body>
-<h1>Login required</h1>
-
-<form method="POST" action="login">
-
-<% hidden-form-field %>
-
-<table>
-
-<tr>
-<td>User name:</td>
-<td><% "username" component render-edit %></td>
-</tr>
-
-<tr>
-<td>Password:</td>
-<td><% "password" component render-edit %></td>
-</tr>
-
-</table>
-
-<p><input type="submit" value="Log in" />
-<%
-login-failed? get
-[ "Invalid username or password" render-error ] when
-%>
-</p>
-
-</form>
-
-<p>
-<% allow-registration? [ %>
- <a href="<% "register" f write-link %>">Register</a>
-<% ] when %>
-<% allow-password-recovery? [ %>
- <a href="<% "recover-password" f write-link %>">
- Recover Password
- </a>
-<% ] when %>
-</p>
-
-</body>
-</html>
diff --git a/extra/http/server/auth/login/login.xml b/extra/http/server/auth/login/login.xml
new file mode 100644
index 0000000000..2f16c09d8d
--- /dev/null
+++ b/extra/http/server/auth/login/login.xml
@@ -0,0 +1,44 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Login</t:title>
+
+ <t:form action="login">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:edit component="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:edit component="password" /></td>
+ </tr>
+
+ </table>
+
+ <p>
+
+ <input type="submit" value="Log in" />
+
+ <t:if var="http.server.auth.login:login-failed?">
+ <t:error>invalid username or password</t:error>
+ </t:if>
+ </p>
+
+ </t:form>
+
+ <p>
+ <t:if code="http.server.auth.login:login-failed?">
+ <t:a href="register">Register</t:a>
+ </t:if>
+ |
+ <t:if code="http.server.auth.login:allow-password-recovery?">
+ <t:a href="recover-password">Recover Password</t:a>
+ </t:if>
+ </p>
+
+</t:chloe>
diff --git a/extra/http/server/auth/login/recover-1.fhtml b/extra/http/server/auth/login/recover-1.fhtml
deleted file mode 100755
index 8ec01f22e9..0000000000
--- a/extra/http/server/auth/login/recover-1.fhtml
+++ /dev/null
@@ -1,41 +0,0 @@
-<% USING: http.server.components http.server ; %>
-<html>
-<body>
-<h1>Recover lost password: step 1 of 4</h1>
-
-<p>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.</p>
-
-<form method="POST" action="recover-password">
-
-<% hidden-form-field %>
-
-<table>
-
-<tr>
-<td>User name:</td>
-<td><% "username" component render-edit %></td>
-</tr>
-
-<tr>
-<td>E-mail:</td>
-<td><% "email" component render-edit %></td>
-</tr>
-
-<tr>
-<td>Captcha:</td>
-<td><% "captcha" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
-</tr>
-
-</table>
-
-<input type="submit" value="Recover password" />
-
-</form>
-
-</body>
-</html>
diff --git a/extra/http/server/auth/login/recover-1.xml b/extra/http/server/auth/login/recover-1.xml
new file mode 100644
index 0000000000..dd3a60f1d1
--- /dev/null
+++ b/extra/http/server/auth/login/recover-1.xml
@@ -0,0 +1,39 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 1 of 4</t:title>
+
+ <p>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.</p>
+
+ <t:form action="recover-password">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:edit component="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:edit component="email" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:edit component="captcha" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
+ </tr>
+
+ </table>
+
+ <input type="submit" value="Recover password" />
+
+ </t:form>
+
+</t:chloe>
diff --git a/extra/http/server/auth/login/recover-2.fhtml b/extra/http/server/auth/login/recover-2.fhtml
deleted file mode 100755
index 9b13734273..0000000000
--- a/extra/http/server/auth/login/recover-2.fhtml
+++ /dev/null
@@ -1,9 +0,0 @@
-<% USING: http.server.components ; %>
-<html>
-<body>
-<h1>Recover lost password: step 2 of 4</h1>
-
-<p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
-
-</body>
-</html>
diff --git a/extra/http/server/auth/login/recover-2.xml b/extra/http/server/auth/login/recover-2.xml
new file mode 100644
index 0000000000..c7819bd21b
--- /dev/null
+++ b/extra/http/server/auth/login/recover-2.xml
@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 2 of 4</t:title>
+
+ <p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
+
+</t:chloe>
diff --git a/extra/http/server/auth/login/recover-3.fhtml b/extra/http/server/auth/login/recover-3.fhtml
deleted file mode 100755
index ca4823baab..0000000000
--- a/extra/http/server/auth/login/recover-3.fhtml
+++ /dev/null
@@ -1,46 +0,0 @@
-<% USING: http.server.components http.server.auth.login http.server
-namespaces kernel combinators ; %>
-<html>
-<body>
-<h1>Recover lost password: step 3 of 4</h1>
-
-<p>Choose a new password for your account.</p>
-
-<form method="POST" action="new-password">
-
-<% hidden-form-field %>
-
-<table>
-
-<% "username" component render-edit %>
-<% "ticket" component render-edit %>
-
-<tr>
-<td>Password:</td>
-<td><% "new-password" component render-edit %></td>
-</tr>
-
-<tr>
-<td>Verify password:</td>
-<td><% "verify-password" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>Enter your password twice to ensure it is correct.</td>
-</tr>
-
-</table>
-
-<p><input type="submit" value="Set password" />
-
-<% password-mismatch? get [
- "passwords do not match" render-error
-] when %>
-
-</p>
-
-</form>
-
-</body>
-</html>
diff --git a/extra/http/server/auth/login/recover-3.xml b/extra/http/server/auth/login/recover-3.xml
new file mode 100644
index 0000000000..115c2cea21
--- /dev/null
+++ b/extra/http/server/auth/login/recover-3.xml
@@ -0,0 +1,43 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 3 of 4</t:title>
+
+ <p>Choose a new password for your account.</p>
+
+ <t:form action="new-password">
+
+ <table>
+
+ <t:edit component="username" />
+ <t:edit component="ticket" />
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:edit component="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify password:</th>
+ <td><t:edit component="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
+ </tr>
+
+ </table>
+
+ <p>
+ <input type="submit" value="Set password" />
+
+ <t:if var="http.server.auth.login:password-mismatch?">
+ <t:error>passwords do not match</t:error>
+ </t:if>
+ </p>
+
+ </t:form>
+
+</t:chloe>
diff --git a/extra/http/server/auth/login/recover-4.fhtml b/extra/http/server/auth/login/recover-4.fhtml
deleted file mode 100755
index 239d71d293..0000000000
--- a/extra/http/server/auth/login/recover-4.fhtml
+++ /dev/null
@@ -1,10 +0,0 @@
-<% USING: http.server ; %>
-<html>
-<body>
-<h1>Recover lost password: step 4 of 4</h1>
-
-<p>Your password has been reset.
-You may now <a href="<% "login" f write-link %>">log in</a>.</p>
-
-</body>
-</html>
diff --git a/extra/http/server/auth/login/recover-4.xml b/extra/http/server/auth/login/recover-4.xml
new file mode 100755
index 0000000000..3c10869fbd
--- /dev/null
+++ b/extra/http/server/auth/login/recover-4.xml
@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 4 of 4</t:title>
+
+ <p>Your password has been reset. You may now <t:a href="login">log in</t:a>.</p>
+
+</t:chloe>
diff --git a/extra/http/server/auth/login/register.fhtml b/extra/http/server/auth/login/register.fhtml
deleted file mode 100755
index 9106497def..0000000000
--- a/extra/http/server/auth/login/register.fhtml
+++ /dev/null
@@ -1,77 +0,0 @@
-<% USING: http.server.components http.server.auth.login
-http.server namespaces kernel combinators ; %>
-<html>
-<body>
-<h1>New user registration</h1>
-
-<form method="POST" action="register">
-<% hidden-form-field %>
-
-<table>
-
-<tr>
-<td>User name:</td>
-<td><% "username" component render-edit %></td>
-</tr>
-
-<tr>
-<td>Real name:</td>
-<td><% "realname" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>Specifying a real name is optional.</td>
-</tr>
-
-<tr>
-<td>Password:</td>
-<td><% "new-password" component render-edit %></td>
-</tr>
-
-<tr>
-<td>Verify:</td>
-<td><% "verify-password" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>Enter your password twice to ensure it is correct.</td>
-</tr>
-
-<tr>
-<td>E-mail:</td>
-<td><% "email" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
-</tr>
-
-<tr>
-<td>Captcha:</td>
-<td><% "captcha" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
-</tr>
-
-</table>
-
-<p><input type="submit" value="Register" />
-
-<% {
- { [ password-mismatch? get ] [ "passwords do not match" render-error ] }
- { [ user-exists? get ] [ "username taken" render-error ] }
- { [ t ] [ ] }
-} cond %>
-
-</p>
-
-</form>
-
-</body>
-</html>
diff --git a/extra/http/server/auth/login/register.xml b/extra/http/server/auth/login/register.xml
new file mode 100644
index 0000000000..1bacf71801
--- /dev/null
+++ b/extra/http/server/auth/login/register.xml
@@ -0,0 +1,79 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>New User Registration</t:title>
+
+ <t:form action="register">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:edit component="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:edit component="realname" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying a real name is optional.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:edit component="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:edit component="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:edit component="email" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:edit component="captcha" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
+ </tr>
+
+ </table>
+
+ <p>
+
+ <input type="submit" value="Register" />
+
+ <t:if var="http.server.auth.login:user-exists?">
+ <t:error>username taken</t:error>
+ </t:if>
+
+ <t:if var="http.server.auth.login:password-mismatch?">
+ <t:error>passwords do not match</t:error>
+ </t:if>
+
+ </p>
+
+ </t:form>
+
+</t:chloe>
diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor
new file mode 100644
index 0000000000..eabcefeb7f
--- /dev/null
+++ b/extra/http/server/boilerplate/boilerplate.factor
@@ -0,0 +1,75 @@
+! 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 arrays
+html.elements
+http
+http.server
+http.server.templating ;
+IN: http.server.boilerplate
+
+TUPLE: boilerplate responder template ;
+
+: <boilerplate> f boilerplate boa ;
+
+SYMBOL: title
+
+: set-title ( string -- )
+ title get >box ;
+
+: write-title ( -- )
+ title get value>> write ;
+
+SYMBOL: style
+
+: add-style ( string -- )
+ "\n" style get push-all
+ style get push-all ;
+
+: 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>> [
+ <link "alternate" =rel "application/atom+xml" =type
+ [ first =title ] [ second =href ] bi
+ link/>
+ ] when* ;
+
+SYMBOL: nested-template?
+
+SYMBOL: next-template
+
+: call-next-template ( -- )
+ next-template get write ;
+
+M: f call-template* drop call-next-template ;
+
+: with-boilerplate ( body template -- )
+ [
+ title get [ <box> title set ] unless
+ atom-feed get [ <box> atom-feed set ] unless
+ style get [ SBUF" " clone style set ] unless
+
+ [
+ [
+ nested-template? on
+ write-response-body*
+ ] with-string-writer
+ next-template set
+ ]
+ [ call-template ]
+ bi*
+ ] with-scope ; inline
+
+M: boilerplate call-responder
+ tuck responder>> call-responder
+ dup "content-type" header "text/html" = [
+ clone swap template>>
+ [ [ with-boilerplate ] 2curry ] curry change-body
+ ] [ nip ] if ;
diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor
index f1c43fe8ae..ff87bb71fb 100755
--- a/extra/http/server/components/components-tests.factor
+++ b/extra/http/server/components/components-tests.factor
@@ -1,11 +1,10 @@
IN: http.server.components.tests
USING: http.server.components http.server.forms
http.server.validators namespaces tools.test kernel accessors
-tuple-syntax mirrors http.server.actions
+tuple-syntax mirrors
+http http.server.actions http.server.templating.fhtml
io.streams.string io.streams.null ;
-\ render-edit must-infer
-
validation-failed? off
[ 3 ] [ "3" "n" <number> validate ] unit-test
@@ -49,8 +48,8 @@ TUPLE: test-tuple text number more-text ;
: <test-form> ( -- form )
"test" <form>
- "resource:extra/http/server/components/test/form.fhtml" >>view-template
- "resource:extra/http/server/components/test/form.fhtml" >>edit-template
+ "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>view-template
+ "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>edit-template
"text" <string>
t >>required
add-field
@@ -64,9 +63,9 @@ TUPLE: test-tuple text number more-text ;
"hi" >>default
add-field ;
-[ ] [ <test-tuple> <mirror> values set <test-form> view-form ] unit-test
+[ ] [ <test-tuple> <mirror> values set <test-form> view-form write-response-body drop ] unit-test
-[ ] [ <test-tuple> <mirror> values set <test-form> edit-form ] unit-test
+[ ] [ <test-tuple> <mirror> values set <test-form> edit-form write-response-body drop ] unit-test
[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [
<test-tuple> from-tuple
@@ -130,3 +129,5 @@ TUPLE: test-tuple text number more-text ;
[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test
[ ] [ "password" <password> "p" set ] unit-test
+
+[ ] [ "pub-date" <date> "d" set ] unit-test
diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor
index 1e5e33c4a0..331231dfb3 100755
--- a/extra/http/server/components/components.factor
+++ b/extra/http/server/components/components.factor
@@ -1,15 +1,19 @@
! 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
+GENERIC: render-summary* ( value renderer -- )
GENERIC: render-view* ( value renderer -- )
GENERIC: render-edit* ( value id renderer -- )
+M: object render-summary* render-view* ;
+
TUPLE: field type ;
C: <field> field
@@ -56,9 +60,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* ;
<PRIVATE
@@ -144,6 +153,17 @@ TUPLE: email < string ;
M: email validate*
call-next-method dup empty? [ v-email ] unless ;
+! URL fields
+TUPLE: url < string ;
+
+: <url> ( 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 ;
@@ -203,22 +223,116 @@ M: captcha validate*
drop v-captcha ;
! Text areas
-TUPLE: textarea-renderer ;
+TUPLE: text-renderer rows cols ;
-: textarea-renderer T{ textarea-renderer } ;
+: new-text-renderer ( class -- renderer )
+ new
+ 60 >>cols
+ 20 >>rows ;
-M: textarea-renderer render-view*
+: <text-renderer> ( -- renderer )
+ text-renderer new-text-renderer ;
+
+M: text-renderer render-view*
drop write ;
-M: textarea-renderer render-edit*
- drop <textarea [ =id ] [ =name ] bi textarea> write </textarea> ;
+M: text-renderer render-edit*
+ <textarea
+ [ rows>> [ number>string =rows ] when* ]
+ [ cols>> [ number>string =cols ] when* ] bi
+ [ =id ]
+ [ =name ] bi
+ textarea>
+ write
+ </textarea> ;
TUPLE: text < string ;
: new-text ( id class -- component )
new-string
f >>one-line
- textarea-renderer >>renderer ;
+ <text-renderer> >>renderer ;
: <text> ( id -- component )
text new-text ;
+
+! HTML text component
+TUPLE: html-text-renderer < text-renderer ;
+
+: <html-text-renderer> ( -- renderer )
+ html-text-renderer new-text-renderer ;
+
+M: html-text-renderer render-view*
+ drop write ;
+
+TUPLE: html-text < text ;
+
+: <html-text> ( id -- component )
+ html-text new-text
+ <html-text-renderer> >>renderer ;
+
+! Date component
+TUPLE: date < string ;
+
+: <date> ( id -- component )
+ date new-string ;
+
+M: date component-string
+ drop timestamp>string ;
+
+! Link components
+
+GENERIC: link-title ( obj -- string )
+GENERIC: link-href ( obj -- url )
+
+SINGLETON: link-renderer
+
+M: link-renderer render-view*
+ drop <a dup link-href =href a> link-title write </a> ;
+
+TUPLE: link < string ;
+
+: <link> ( id -- component )
+ link new-string
+ link-renderer >>renderer ;
+
+! List components
+SYMBOL: +plain+
+SYMBOL: +ordered+
+SYMBOL: +unordered+
+
+TUPLE: list-renderer component type ;
+
+C: <list-renderer> list-renderer
+
+: render-plain-list ( seq component quot -- )
+ '[ , component>> renderer>> @ ] each ; inline
+
+: render-li-list ( seq component quot -- )
+ '[ <li> @ </li> ] render-plain-list ; inline
+
+: render-ordered-list ( seq quot component -- )
+ <ol> render-li-list </ol> ; inline
+
+: render-unordered-list ( seq quot component -- )
+ <ul> render-li-list </ul> ; inline
+
+: render-list ( value renderer quot -- )
+ over type>> {
+ { +plain+ [ render-plain-list ] }
+ { +ordered+ [ render-ordered-list ] }
+ { +unordered+ [ render-unordered-list ] }
+ } case ; inline
+
+M: list-renderer render-view*
+ [ render-view* ] render-list ;
+
+M: list-renderer render-summary*
+ [ render-summary* ] render-list ;
+
+TUPLE: list < component ;
+
+: <list> ( id component type -- list )
+ <list-renderer> list swap new-component ;
+
+M: list component-string drop ;
diff --git a/extra/http/server/components/farkup/farkup.factor b/extra/http/server/components/farkup/farkup.factor
index 65e159513d..a8d320f82f 100755
--- a/extra/http/server/components/farkup/farkup.factor
+++ b/extra/http/server/components/farkup/farkup.factor
@@ -4,13 +4,14 @@ USING: splitting kernel io sequences farkup accessors
http.server.components ;
IN: http.server.components.farkup
-TUPLE: farkup-renderer < textarea-renderer ;
+TUPLE: farkup-renderer < text-renderer ;
-: farkup-renderer T{ farkup-renderer } ;
+: <farkup-renderer> ( -- renderer )
+ farkup-renderer new-text-renderer ;
M: farkup-renderer render-view*
drop string-lines "\n" join convert-farkup write ;
: <farkup> ( id -- component )
<text>
- farkup-renderer >>renderer ;
+ <farkup-renderer> >>renderer ;
diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor
index eb8ff943c7..65de881adb 100755
--- a/extra/http/server/crud/crud.factor
+++ b/extra/http/server/crud/crud.factor
@@ -15,49 +15,33 @@ IN: http.server.crud
[ "id" get ctor call select-tuple from-tuple ] >>init
- [
- "text/html" <content>
- [ form view-form ] >>body
- ] >>display ;
+ [ form view-form ] >>display ;
: <id-redirect> ( id next -- response )
swap number>string "id" associate <permanent-redirect> ;
-:: <create-action> ( form ctor next -- action )
- <action>
- [ f ctor call from-tuple form set-defaults ] >>init
-
- [
- "text/html" <content>
- [ form edit-form ] >>body
- ] >>display
-
- [
- f ctor call from-tuple
-
- form validate-form
-
- values-tuple insert-tuple
-
- "id" value next <id-redirect>
- ] >>submit ;
-
:: <edit-action> ( form ctor next -- action )
<action>
- { { "id" [ v-number ] } } >>get-params
- [ "id" get ctor call select-tuple from-tuple ] >>init
+ { { "id" [ [ v-number ] v-optional ] } } >>get-params
[
- "text/html" <content>
- [ form edit-form ] >>body
- ] >>display
+ "id" get ctor call
+
+ "id" get
+ [ select-tuple from-tuple ]
+ [ from-tuple form set-defaults ]
+ if
+ ] >>init
+
+ [ form edit-form ] >>display
[
f ctor call from-tuple
form validate-form
- values-tuple update-tuple
+ values-tuple
+ "id" value [ update-tuple ] [ insert-tuple ] if
"id" value next <id-redirect>
] >>submit ;
@@ -71,3 +55,13 @@ IN: http.server.crud
next f <permanent-redirect>
] >>submit ;
+
+:: <list-action> ( form ctor -- action )
+ <action>
+ [
+ blank-values
+
+ f ctor call select-tuples "list" set-value
+
+ form view-form
+ ] >>display ;
diff --git a/extra/http/server/forms/forms.factor b/extra/http/server/forms/forms.factor
index cf8fd4ca8c..60f3da25b6 100644
--- a/extra/http/server/forms/forms.factor
+++ b/extra/http/server/forms/forms.factor
@@ -1,22 +1,31 @@
-USING: kernel accessors assocs namespaces io.files fry
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors assocs namespaces io.files sequences fry
+http.server
http.server.actions
http.server.components
http.server.validators
-http.server.templating.fhtml ;
+http.server.templating ;
IN: http.server.forms
-TUPLE: form < component view-template edit-template components ;
+TUPLE: form < component
+view-template edit-template summary-template
+components ;
M: form init V{ } clone >>components ;
: <form> ( id -- form )
- form f new-component ;
+ form f new-component
+ dup >>renderer ;
: add-field ( form component -- form )
dup id>> pick components>> set-at ;
+: set-components ( form -- )
+ components>> components set ;
+
: with-form ( form quot -- )
- >r components>> components r> with-variable ; inline
+ [ [ set-components ] [ call ] bi* ] with-scope ; inline
: set-defaults ( form -- )
[
@@ -27,11 +36,16 @@ M: form init V{ } clone >>components ;
] assoc-each
] with-form ;
-: view-form ( form -- )
- dup view-template>> '[ , run-template ] with-form ;
+: <form-response> ( form template -- response )
+ [ components>> components set ]
+ [ "text/html" <content> swap >>body ]
+ bi* ;
-: edit-form ( form -- )
- dup edit-template>> '[ , run-template ] with-form ;
+: view-form ( form -- response )
+ dup view-template>> <form-response> ;
+
+: edit-form ( form -- response )
+ dup edit-template>> <form-response> ;
: validate-param ( id component -- )
[ [ params get at ] [ validate ] bi* ]
@@ -46,3 +60,22 @@ M: form init V{ } clone >>components ;
: validate-form ( form -- )
(validate-form) [ validation-failed ] when ;
+
+: render-form ( value form template -- )
+ [
+ [ from-tuple ]
+ [ set-components ]
+ [ call-template ]
+ tri*
+ ] with-scope ;
+
+M: form component-string drop ;
+
+M: form render-summary*
+ dup summary-template>> render-form ;
+
+M: form render-view*
+ dup view-template>> render-form ;
+
+M: form render-edit*
+ nip dup edit-template>> render-form ;
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index db03645a24..d3bd6c6bbe 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -160,23 +160,30 @@ drop
SYMBOL: development-mode
+: http-error. ( error -- )
+ "Internal server error" [
+ development-mode get [
+ [ print-error nl :c ] with-html-stream
+ ] [
+ 500 "Internal server error"
+ trivial-response-body
+ ] if
+ ] simple-page ;
+
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
- swap '[
- , "Internal server error" [
- development-mode get [
- [ print-error nl :c ] with-html-stream
- ] [
- 500 "Internal server error"
- trivial-response-body
- ] if
- ] simple-page
- ] >>body ;
+ swap '[ , http-error. ] >>body ;
: do-response ( response -- )
dup write-response
request get method>> "HEAD" =
- [ drop ] [ write-response-body ] if ;
+ [ drop ] [
+ '[
+ , write-response-body
+ ] [
+ http-error.
+ ] recover
+ ] if ;
LOG: httpd-hit NOTICE
diff --git a/extra/http/server/templating/chloe/chloe-tests.factor b/extra/http/server/templating/chloe/chloe-tests.factor
new file mode 100644
index 0000000000..f517af4a12
--- /dev/null
+++ b/extra/http/server/templating/chloe/chloe-tests.factor
@@ -0,0 +1,97 @@
+USING: http.server.templating http.server.templating.chloe
+http.server.components http.server.boilerplate tools.test
+io.streams.string kernel sequences ascii boxes namespaces xml
+splitting ;
+IN: http.server.templating.chloe.tests
+
+[ "foo" ]
+[ "<a href=\"foo\">blah</a>" string>xml "href" required-attr ]
+unit-test
+
+[ "<a name=\"foo\">blah</a>" string>xml "href" required-attr ]
+[ "href attribute is required" = ]
+must-fail-with
+
+[ f ] [ f parse-query-attr ] unit-test
+
+[ f ] [ "" parse-query-attr ] unit-test
+
+[ H{ { "a" "b" } } ] [
+ blank-values
+ "b" "a" set-value
+ "a" parse-query-attr
+] unit-test
+
+[ H{ { "a" "b" } { "c" "d" } } ] [
+ blank-values
+ "b" "a" set-value
+ "d" "c" set-value
+ "a,c" parse-query-attr
+] unit-test
+
+: run-template
+ with-string-writer [ "\r\n\t" member? not ] subset
+ "?>" split1 nip ; inline
+
+: test-template ( name -- template )
+ "resource:extra/http/server/templating/chloe/test/"
+ swap
+ ".xml" 3append <chloe> ;
+
+[ "Hello world" ] [
+ [
+ "test1" test-template call-template
+ ] run-template
+] unit-test
+
+[ "Blah blah" "Hello world" ] [
+ [
+ <box> title set
+ [
+ "test2" test-template call-template
+ ] run-template
+ title get box>
+ ] with-scope
+] unit-test
+
+[ "<html><head><title>Hello world</title></head><body>Blah blah</body></html>" ] [
+ [
+ [
+ "test2" test-template call-template
+ ] "test3" test-template with-boilerplate
+ ] run-template
+] unit-test
+
+: test4-aux? t ;
+
+[ "True" ] [
+ [
+ "test4" test-template call-template
+ ] run-template
+] unit-test
+
+: test5-aux? f ;
+
+[ "" ] [
+ [
+ "test5" test-template call-template
+ ] run-template
+] unit-test
+
+SYMBOL: test6-aux?
+
+[ "True" ] [
+ [
+ test6-aux? on
+ "test6" test-template call-template
+ ] run-template
+] unit-test
+
+SYMBOL: test7-aux?
+
+[ "" ] [
+ [
+ test7-aux? off
+ "test7" test-template call-template
+ ] run-template
+] unit-test
diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/http/server/templating/chloe/chloe.factor
new file mode 100644
index 0000000000..685988dfaf
--- /dev/null
+++ b/extra/http/server/templating/chloe/chloe.factor
@@ -0,0 +1,196 @@
+USING: accessors kernel sequences combinators kernel namespaces
+classes.tuple assocs splitting words arrays
+io io.files io.encodings.utf8 html.elements unicode.case
+tuple-syntax xml xml.data xml.writer xml.utilities
+http.server
+http.server.auth
+http.server.components
+http.server.sessions
+http.server.templating
+http.server.boilerplate ;
+IN: http.server.templating.chloe
+
+! Chloe is Ed's favorite web designer
+
+TUPLE: chloe path ;
+
+C: <chloe> chloe
+
+DEFER: process-template
+
+: chloe-ns TUPLE{ name url: "http://factorcode.org/chloe/1.0" } ;
+
+: chloe-tag? ( tag -- ? )
+ {
+ { [ dup tag? not ] [ f ] }
+ { [ dup chloe-ns names-match? not ] [ f ] }
+ [ t ]
+ } cond nip ;
+
+SYMBOL: tags
+
+: required-attr ( tag name -- value )
+ dup rot at*
+ [ nip ] [ drop " attribute is required" append throw ] if ;
+
+: optional-attr ( tag name -- value )
+ swap at ;
+
+: write-title-tag ( tag -- )
+ drop
+ "head" tags get member? "title" tags get member? not and
+ [ <title> write-title </title> ] [ write-title ] if ;
+
+: style-tag ( tag -- )
+ dup "include" optional-attr dup [
+ swap children>string empty? [
+ "style tag cannot have both an include attribute and a body" throw
+ ] unless
+ utf8 file-contents
+ ] [
+ drop children>string
+ ] if add-style ;
+
+: write-style-tag ( tag -- )
+ drop <style> write-style </style> ;
+
+: atom-tag ( tag -- )
+ [ "title" required-attr ]
+ [ "href" required-attr ]
+ bi set-atom-feed ;
+
+: write-atom-tag ( tag -- )
+ drop
+ "head" tags get member? [
+ write-atom-feed
+ ] [
+ atom-feed get value>> second write
+ ] if ;
+
+: component-attr ( tag -- name )
+ "component" required-attr ;
+
+: view-tag ( tag -- )
+ component-attr component render-view ;
+
+: edit-tag ( tag -- )
+ component-attr component render-edit ;
+
+: summary-tag ( tag -- )
+ component-attr component render-summary ;
+
+: parse-query-attr ( string -- assoc )
+ dup empty?
+ [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
+
+: a-start-tag ( tag -- )
+ <a
+ dup "value" optional-attr [ value f ] [
+ [ "href" required-attr ]
+ [ "query" optional-attr parse-query-attr ]
+ bi
+ ] ?if link>string =href
+ a> ;
+
+: process-tag-children ( tag -- )
+ [ process-template ] each ;
+
+: a-tag ( tag -- )
+ [ a-start-tag ]
+ [ process-tag-children ]
+ [ drop </a> ]
+ tri ;
+
+: form-start-tag ( tag -- )
+ <form
+ "POST" =method
+ tag-attrs print-attrs
+ form>
+ hidden-form-field ;
+
+: form-tag ( tag -- )
+ [ form-start-tag ]
+ [ process-tag-children ]
+ [ drop </form> ]
+ tri ;
+
+: attr>word ( value -- word/f )
+ dup ":" split1 swap lookup
+ [ ] [ "No such word: " swap append throw ] ?if ;
+
+: attr>var ( value -- word/f )
+ attr>word dup symbol? [
+ "Must be a symbol: " swap append throw
+ ] unless ;
+
+: if-satisfied? ( tag -- ? )
+ {
+ [ "code" optional-attr [ attr>word execute ] [ t ] if* ]
+ [ "var" optional-attr [ attr>var get ] [ t ] if* ]
+ [ "svar" optional-attr [ attr>var sget ] [ t ] if* ]
+ [ "uvar" optional-attr [ attr>var uget ] [ t ] if* ]
+ } cleave 4array [ ] all? ;
+
+: if-tag ( tag -- )
+ dup if-satisfied? [ process-tag-children ] [ drop ] if ;
+
+: error-tag ( tag -- )
+ children>string render-error ;
+
+: process-chloe-tag ( tag -- )
+ dup name-tag {
+ { "chloe" [ [ process-template ] each ] }
+ { "title" [ children>string set-title ] }
+ { "write-title" [ write-title-tag ] }
+ { "style" [ style-tag ] }
+ { "write-style" [ write-style-tag ] }
+ { "atom" [ atom-tag ] }
+ { "write-atom" [ write-atom-tag ] }
+ { "view" [ view-tag ] }
+ { "edit" [ edit-tag ] }
+ { "summary" [ summary-tag ] }
+ { "a" [ a-tag ] }
+ { "form" [ form-tag ] }
+ { "error" [ error-tag ] }
+ { "if" [ if-tag ] }
+ { "comment" [ drop ] }
+ { "call-next-template" [ drop call-next-template ] }
+ [ "Unknown chloe tag: " swap append throw ]
+ } case ;
+
+: process-tag ( tag -- )
+ {
+ [ name-tag >lower tags get push ]
+ [ write-start-tag ]
+ [ process-tag-children ]
+ [ write-end-tag ]
+ [ drop tags get pop* ]
+ } cleave ;
+
+: process-template ( xml -- )
+ {
+ { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
+ { [ dup [ tag? ] is? ] [ process-tag ] }
+ { [ t ] [ write-item ] }
+ } cond ;
+
+: process-chloe ( xml -- )
+ [
+ V{ } clone tags set
+
+ nested-template? get [
+ process-template
+ ] [
+ {
+ [ xml-prolog write-prolog ]
+ [ xml-before write-chunk ]
+ [ process-template ]
+ [ xml-after write-chunk ]
+ } cleave
+ ] if
+ ] with-scope ;
+
+M: chloe call-template*
+ path>> utf8 <file-reader> read-xml process-chloe ;
+
+INSTANCE: chloe template
diff --git a/extra/http/server/templating/chloe/test/test1.xml b/extra/http/server/templating/chloe/test/test1.xml
new file mode 100644
index 0000000000..daccd57b17
--- /dev/null
+++ b/extra/http/server/templating/chloe/test/test1.xml
@@ -0,0 +1,5 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ Hello world
+</t:chloe>
diff --git a/extra/http/server/templating/chloe/test/test2.xml b/extra/http/server/templating/chloe/test/test2.xml
new file mode 100644
index 0000000000..05b9dde54f
--- /dev/null
+++ b/extra/http/server/templating/chloe/test/test2.xml
@@ -0,0 +1,6 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:title>Hello world</t:title>
+ Blah blah
+</t:chloe>
diff --git a/extra/http/server/templating/chloe/test/test3-aux.xml b/extra/http/server/templating/chloe/test/test3-aux.xml
new file mode 100644
index 0000000000..99f61afe33
--- /dev/null
+++ b/extra/http/server/templating/chloe/test/test3-aux.xml
@@ -0,0 +1,5 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:title>Hello world</t:title>
+</t:chloe>
diff --git a/extra/http/server/templating/chloe/test/test3.xml b/extra/http/server/templating/chloe/test/test3.xml
new file mode 100644
index 0000000000..845dd356c9
--- /dev/null
+++ b/extra/http/server/templating/chloe/test/test3.xml
@@ -0,0 +1,12 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <html>
+ <head>
+ <t:write-title />
+ </head>
+ <body>
+ <t:call-next-template />
+ </body>
+ </html>
+</t:chloe>
diff --git a/extra/http/server/templating/chloe/test/test4.xml b/extra/http/server/templating/chloe/test/test4.xml
new file mode 100644
index 0000000000..0381bcc27a
--- /dev/null
+++ b/extra/http/server/templating/chloe/test/test4.xml
@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if code="http.server.templating.chloe.tests:test4-aux?">
+ True
+ </t:if>
+
+</t:chloe>
diff --git a/extra/http/server/templating/chloe/test/test5.xml b/extra/http/server/templating/chloe/test/test5.xml
new file mode 100644
index 0000000000..d74a5e5368
--- /dev/null
+++ b/extra/http/server/templating/chloe/test/test5.xml
@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if code="http.server.templating.chloe.tests:test5-aux?">
+ True
+ </t:if>
+
+</t:chloe>
diff --git a/extra/http/server/templating/chloe/test/test6.xml b/extra/http/server/templating/chloe/test/test6.xml
new file mode 100644
index 0000000000..5b6a71cf6b
--- /dev/null
+++ b/extra/http/server/templating/chloe/test/test6.xml
@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if var="http.server.templating.chloe.tests:test6-aux?">
+ True
+ </t:if>
+
+</t:chloe>
diff --git a/extra/http/server/templating/chloe/test/test7.xml b/extra/http/server/templating/chloe/test/test7.xml
new file mode 100644
index 0000000000..4381b5cec4
--- /dev/null
+++ b/extra/http/server/templating/chloe/test/test7.xml
@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if var="http.server.templating.chloe.tests:test7-aux?">
+ True
+ </t:if>
+
+</t:chloe>
diff --git a/extra/http/server/templating/fhtml/fhtml-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor
index 9d8a6f4617..42bec43570 100755
--- a/extra/http/server/templating/fhtml/fhtml-tests.factor
+++ b/extra/http/server/templating/fhtml/fhtml-tests.factor
@@ -1,13 +1,13 @@
USING: io io.files io.streams.string io.encodings.utf8
-http.server.templating.fhtml kernel tools.test sequences
-parser ;
+http.server.templating http.server.templating.fhtml kernel
+tools.test sequences parser ;
IN: http.server.templating.fhtml.tests
: test-template ( path -- ? )
"resource:extra/http/server/templating/fhtml/test/"
prepend
[
- ".fhtml" append [ run-template ] with-string-writer
+ ".fhtml" append <fhtml> [ call-template ] with-string-writer
] keep
".html" append utf8 file-contents = ;
diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor
index 4a3bf38e23..2cc053a0ca 100755
--- a/extra/http/server/templating/fhtml/fhtml.factor
+++ b/extra/http/server/templating/fhtml/fhtml.factor
@@ -1,12 +1,12 @@
! Copyright (C) 2005 Alex Chapman
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: continuations sequences kernel parser namespaces io
-io.files io.streams.string html html.elements source-files
-debugger combinators math quotations generic strings splitting
-accessors http.server.static http.server assocs
-io.encodings.utf8 fry accessors ;
-
+USING: continuations sequences kernel namespaces debugger
+combinators math quotations generic strings splitting
+accessors assocs fry
+parser io io.files io.streams.string io.encodings.utf8 source-files
+html html.elements
+http.server.static http.server http.server.templating ;
IN: http.server.templating.fhtml
: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;
@@ -72,9 +72,13 @@ DEFER: <% delimiter
: html-error. ( error -- )
<pre> error. </pre> ;
-: run-template ( filename -- )
+TUPLE: fhtml path ;
+
+C: <fhtml> fhtml
+
+M: fhtml call-template* ( filename -- )
'[
- , [
+ , path>> [
"quiet" on
parser-notes off
templating-vocab use+
@@ -85,16 +89,10 @@ DEFER: <% delimiter
] with-file-vocabs
] assert-depth ;
-: template-convert ( infile outfile -- )
- utf8 [ run-template ] with-file-writer ;
-
-! responder integration
-: serve-template ( name -- response )
- "text/html" <content>
- swap '[ , run-template ] >>body ;
-
! file responder integration
: enable-fhtml ( responder -- responder )
- [ serve-template ]
+ [ <fhtml> serve-template ]
"application/x-factor-server-page"
pick special>> set-at ;
+
+INSTANCE: fhtml template
diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor
new file mode 100644
index 0000000000..610ec78fed
--- /dev/null
+++ b/extra/http/server/templating/templating.factor
@@ -0,0 +1,28 @@
+USING: accessors kernel fry io io.encodings.utf8 io.files
+http http.server debugger prettyprint continuations ;
+IN: http.server.templating
+
+MIXIN: template
+
+GENERIC: call-template* ( template -- )
+
+ERROR: template-error template error ;
+
+M: template-error error.
+ "Error while processing template " write
+ [ template>> pprint ":" print nl ]
+ [ error>> error. ]
+ bi ;
+
+: call-template ( template -- )
+ [ call-template* ] [ template-error ] recover ;
+
+M: template write-response-body* call-template ;
+
+: template-convert ( template output -- )
+ utf8 [ call-template ] with-file-writer ;
+
+! responder integration
+: serve-template ( template -- response )
+ "text/html" <content>
+ swap '[ , call-template ] >>body ;
diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor
index 82827ac450..5e845705ab 100755
--- a/extra/http/server/validators/validators-tests.factor
+++ b/extra/http/server/validators/validators-tests.factor
@@ -21,3 +21,9 @@ accessors ;
[ "slava@factorcodeorg" v-email ]
[ "invalid e-mail" = ] must-fail-with
+
+[ "http://www.factorcode.org" ]
+[ "http://www.factorcode.org" v-url ] unit-test
+
+[ "http:/www.factorcode.org" v-url ]
+[ "invalid URL" = ] must-fail-with
diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor
index 5be064c5ce..7415787c79 100755
--- a/extra/http/server/validators/validators.factor
+++ b/extra/http/server/validators/validators.factor
@@ -11,8 +11,7 @@ TUPLE: validation-error value reason ;
C: <validation-error> validation-error
: with-validator ( value quot -- result )
- [ validation-failed? on <validation-error> ] recover ;
- inline
+ [ validation-failed? on <validation-error> ] recover ; inline
: v-default ( str def -- str )
over empty? spin ? ;
@@ -20,6 +19,9 @@ C: <validation-error> validation-error
: v-required ( str -- str )
dup empty? [ "required" throw ] when ;
+: v-optional ( str quot -- str )
+ over empty? [ 2drop f ] [ call ] if ; inline
+
: v-min-length ( str n -- str )
over length over < [
[ "must be at least " % # " characters" % ] "" make
@@ -63,7 +65,12 @@ C: <validation-error> validation-error
: v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html
"e-mail"
- R/ [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}/i
+ R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
+ v-regexp ;
+
+: v-url ( str -- str )
+ "URL"
+ R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?'
v-regexp ;
: v-captcha ( str -- str )
diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor
index 4446b82f20..dadb627fc0 100755
--- a/extra/io/launcher/launcher-docs.factor
+++ b/extra/io/launcher/launcher-docs.factor
@@ -113,6 +113,8 @@ HELP: try-process
{ $values { "desc" "a launch descriptor" } }
{ $description "Launches a process and waits for it to complete. If it exits with a non-zero status code, throws a " { $link process-failed } " error." } ;
+{ run-process try-process run-detached } related-words
+
HELP: kill-process
{ $values { "process" process } }
{ $description "Kills a running process. Does nothing if the process has already exited." } ;
@@ -171,6 +173,7 @@ ARTICLE: "io.launcher.launch" "Launching processes"
"Launching processes:"
{ $subsection run-process }
{ $subsection try-process }
+{ $subsection run-detached }
"Redirecting standard input and output to a pipe:"
{ $subsection <process-stream> }
{ $subsection with-process-stream } ;
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index 9b480d0cc2..6ee8660528 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -127,10 +127,7 @@ HOOK: run-process* io-backend ( process -- handle )
run-detached
dup detached>> [ dup wait-for-process drop ] unless ;
-TUPLE: process-failed code ;
-
-: process-failed ( code -- * )
- \ process-failed boa throw ;
+ERROR: process-failed code ;
: try-process ( desc -- )
run-process wait-for-process dup zero?
diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor
index 6407108a61..77d539259e 100644
--- a/extra/io/monitors/monitors-tests.factor
+++ b/extra/io/monitors/monitors-tests.factor
@@ -33,7 +33,6 @@ os { winnt linux macosx } member? [
[ ] [ "m" get dispose ] unit-test
] with-monitors
-
[
[ "monitor-test" temp-file delete-tree ] ignore-errors
@@ -88,4 +87,7 @@ os { winnt linux macosx } member? [
[ ] [ "m" get dispose ] unit-test
] with-monitors
+
+ ! Out-of-scope disposal should not fail
+ [ "" resource-path t <monitor> ] with-monitors dispose
] when
diff --git a/extra/io/monitors/recursive/recursive.factor b/extra/io/monitors/recursive/recursive.factor
index 1b18015513..04d491edbe 100644
--- a/extra/io/monitors/recursive/recursive.factor
+++ b/extra/io/monitors/recursive/recursive.factor
@@ -1,15 +1,16 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences assocs arrays continuations combinators kernel
-threads concurrency.messaging concurrency.mailboxes
-concurrency.promises
-io.files io.monitors ;
+threads concurrency.messaging concurrency.mailboxes concurrency.promises
+io.files io.monitors debugger ;
IN: io.monitors.recursive
! Simulate recursive monitors on platforms that don't have them
TUPLE: recursive-monitor < monitor children thread ready ;
+: notify? ( -- ? ) monitor tget ready>> promise-fulfilled? ;
+
DEFER: add-child-monitor
: qualify-path ( path -- path' )
@@ -17,25 +18,22 @@ DEFER: add-child-monitor
: add-child-monitors ( path -- )
#! We yield since this directory scan might take a while.
- [
- directory* [ first add-child-monitor yield ] each
- ] curry ignore-errors ;
+ directory* [ first add-child-monitor ] each yield ;
: add-child-monitor ( path -- )
+ notify? [ dup { +add-file+ } monitor tget queue-change ] when
qualify-path dup link-info type>> +directory+ eq? [
[ add-child-monitors ]
[
- [ f my-mailbox (monitor) ] keep
- monitor tget children>> set-at
+ [
+ [ f my-mailbox (monitor) ] keep
+ monitor tget children>> set-at
+ ] curry ignore-errors
] bi
] [ drop ] if ;
-USE: io
-USE: prettyprint
-
: remove-child-monitor ( monitor -- )
- monitor tget children>> delete-at*
- [ dispose ] [ drop ] if ;
+ monitor tget children>> delete-at* [ dispose ] [ drop ] if ;
M: recursive-monitor dispose
dup queue>> closed>> [
diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor
index 498430fdbc..2a376e18c2 100755
--- a/extra/io/sockets/impl/impl.factor
+++ b/extra/io/sockets/impl/impl.factor
@@ -1,8 +1,9 @@
-! Copyright (C) 2007 Doug Coleman, Slava Pestov
+! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays io.backend io.binary io.sockets
-kernel math math.parser sequences splitting system
-alien.c-types combinators namespaces alien parser ;
+io.encodings.ascii kernel math math.parser sequences splitting
+system alien.c-types alien.strings alien combinators namespaces
+parser ;
IN: io.sockets.impl
<< {
@@ -130,4 +131,4 @@ M: object resolve-host ( host serv passive? -- seq )
M: object host-name ( -- name )
256 <byte-array> dup dup length gethostname
zero? [ "gethostname failed" throw ] unless
- alien>char-string ;
+ ascii alien>string ;
diff --git a/extra/io/unix/linux/monitors/monitors.factor b/extra/io/unix/linux/monitors/monitors.factor
index 58c1f0110c..cd17dfbbce 100644
--- a/extra/io/unix/linux/monitors/monitors.factor
+++ b/extra/io/unix/linux/monitors/monitors.factor
@@ -2,21 +2,24 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.backend io.monitors io.monitors.recursive
io.files io.buffers io.monitors io.nonblocking io.timeouts
-io.unix.backend io.unix.select unix.linux.inotify assocs
-namespaces threads continuations init math math.bitfields sets
-alien.c-types alien vocabs.loader accessors system hashtables ;
+io.unix.backend io.unix.select io.encodings.utf8
+unix.linux.inotify assocs namespaces threads continuations init
+math math.bitfields sets alien alien.strings alien.c-types
+vocabs.loader accessors system hashtables ;
IN: io.unix.linux.monitors
-TUPLE: linux-monitor < monitor wd ;
-
-: <linux-monitor> ( wd path mailbox -- monitor )
- linux-monitor new-monitor
- swap >>wd ;
-
SYMBOL: watches
SYMBOL: inotify
+TUPLE: linux-monitor < monitor wd inotify watches ;
+
+: <linux-monitor> ( wd path mailbox -- monitor )
+ linux-monitor new-monitor
+ inotify get >>inotify
+ watches get >>watches
+ swap >>wd ;
+
: wd>monitor ( wd -- monitor ) watches get at ;
: <inotify> ( -- port/f )
@@ -52,8 +55,13 @@ M: linux (monitor) ( path recursive? mailbox -- monitor )
] if ;
M: linux-monitor dispose ( monitor -- )
- [ wd>> watches get delete-at ]
- [ wd>> inotify-fd swap inotify_rm_watch io-error ] bi ;
+ dup inotify>> closed>> [ drop ] [
+ [ [ wd>> ] [ watches>> ] bi delete-at ]
+ [
+ [ inotify>> handle>> ] [ wd>> ] bi
+ inotify_rm_watch io-error
+ ] bi
+ ] if ;
: ignore-flags? ( mask -- ? )
{
@@ -79,7 +87,7 @@ M: linux-monitor dispose ( monitor -- )
dup inotify-event-mask ignore-flags? [
drop f f
] [
- [ inotify-event-name alien>char-string ]
+ [ inotify-event-name utf8 alien>string ]
[ inotify-event-mask parse-action ] bi
] if ;
diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor
index cecc70fb08..b60cb5760e 100755
--- a/extra/io/unix/sockets/sockets.factor
+++ b/extra/io/unix/sockets/sockets.factor
@@ -1,13 +1,15 @@
! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings generic kernel math
+namespaces threads sequences byte-arrays io.nonblocking
+io.binary io.unix.backend io.streams.duplex io.sockets.impl
+io.backend io.files io.files.private io.encodings.utf8
+math.parser continuations libc combinators system accessors
+qualified unix ;
+
+EXCLUDE: io => read write close ;
+EXCLUDE: io.sockets => accept ;
-! We need to fiddle with the exact search order here, since
-! unix::accept shadows streams::accept.
-USING: alien alien.c-types generic io kernel math namespaces
-io.nonblocking parser threads unix sequences
-byte-arrays io.sockets io.binary io.unix.backend
-io.streams.duplex io.sockets.impl math.parser continuations libc
-combinators io.backend io.files io.files.private system accessors ;
IN: io.unix.sockets
: pending-init-error ( port -- )
@@ -36,7 +38,7 @@ TUPLE: connect-task < output-task ;
connect-task <io-task> ;
M: connect-task do-io-task
- io-task-port dup port-handle f 0 write
+ port>> dup handle>> f 0 write
0 < [ defer-error ] [ drop t ] if ;
: wait-to-connect ( port -- )
@@ -56,8 +58,6 @@ M: unix ((client)) ( addrspec -- client-in client-out )
] if ;
! Server sockets - TCP and Unix domain
-USE: unix
-
: init-server-socket ( fd -- )
SOL_SOCKET SO_REUSEADDR sockopt ;
@@ -83,8 +83,6 @@ M: accept-task do-io-task
: wait-to-accept ( server -- )
[ <accept-task> add-io-task ] with-port-continuation drop ;
-USE: io.sockets
-
: server-fd ( addrspec type -- fd )
>r dup protocol-family r> socket-fd
dup init-server-socket
@@ -187,12 +185,12 @@ M: local protocol-family drop PF_UNIX ;
M: local sockaddr-type drop "sockaddr-un" c-type ;
M: local make-sockaddr
- local-path cwd prepend-path
+ path>> (normalize-path)
dup length 1 + max-un-path > [ "Path too long" throw ] when
"sockaddr-un" <c-object>
AF_UNIX over set-sockaddr-un-family
- dup sockaddr-un-path rot string>char-alien dup length memcpy ;
+ dup sockaddr-un-path rot utf8 string>alien dup length memcpy ;
M: local parse-sockaddr
drop
- sockaddr-un-path alien>char-string <local> ;
+ sockaddr-un-path utf8 alien>string <local> ;
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index eec473e840..c9f17147d3 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -1,15 +1,15 @@
USING: continuations destructors io.buffers io.files io.backend
io.timeouts io.nonblocking io.windows io.windows.nt.backend
kernel libc math threads windows windows.kernel32 system
-alien.c-types alien.arrays sequences combinators combinators.lib
-sequences.lib ascii splitting alien strings assocs namespaces
-io.files.private accessors ;
+alien.c-types alien.arrays alien.strings sequences combinators
+combinators.lib sequences.lib ascii splitting alien strings
+assocs namespaces io.files.private accessors ;
IN: io.windows.nt.files
M: winnt cwd
MAX_UNICODE_PATH dup "ushort" <c-array>
[ GetCurrentDirectory win32-error=0/f ] keep
- alien>u16-string ;
+ utf16n alien>string ;
M: winnt cd
SetCurrentDirectory win32-error=0/f ;
diff --git a/extra/locals/backend/backend-tests.factor b/extra/locals/backend/backend-tests.factor
new file mode 100644
index 0000000000..41caa87fae
--- /dev/null
+++ b/extra/locals/backend/backend-tests.factor
@@ -0,0 +1,38 @@
+IN: locals.backend.tests
+USING: tools.test locals.backend kernel arrays ;
+
+[ 3 ] [ 3 >r 1 get-local r> drop ] unit-test
+
+[ 4 ] [ 3 4 >r >r 2 get-local 2 drop-locals ] unit-test
+
+: get-local-test-1 3 >r 1 get-local r> drop ;
+
+{ 0 1 } [ get-local-test-1 ] must-infer-as
+
+[ 3 ] [ get-local-test-1 ] unit-test
+
+: get-local-test-2 3 4 >r >r 2 get-local 2 drop-locals ;
+
+{ 0 1 } [ get-local-test-2 ] must-infer-as
+
+[ 4 ] [ get-local-test-2 ] unit-test
+
+: get-local-test-3 3 4 >r >r 2 get-local r> r> 2array ;
+
+{ 0 2 } [ get-local-test-3 ] must-infer-as
+
+[ 4 { 3 4 } ] [ get-local-test-3 ] unit-test
+
+: get-local-test-4 3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ;
+
+{ 0 2 } [ get-local-test-4 ] must-infer-as
+
+[ 4 { 3 4 } ] [ get-local-test-4 ] unit-test
+
+[ 1 2 ] [ 1 2 2 load-locals r> r> ] unit-test
+
+: load-locals-test-1 1 2 2 load-locals r> r> ;
+
+{ 0 2 } [ load-locals-test-1 ] must-infer-as
+
+[ 1 2 ] [ load-locals-test-1 ] unit-test
diff --git a/extra/locals/backend/backend.factor b/extra/locals/backend/backend.factor
new file mode 100644
index 0000000000..10bed8b5df
--- /dev/null
+++ b/extra/locals/backend/backend.factor
@@ -0,0 +1,42 @@
+USING: math kernel slots.private inference.known-words
+inference.backend sequences effects words ;
+IN: locals.backend
+
+: load-locals ( n -- )
+ dup zero? [ drop ] [ swap >r 1- load-locals ] if ;
+
+: get-local ( n -- value )
+ dup zero? [ drop dup ] [ r> swap 1- get-local swap >r ] if ;
+
+: local-value 2 slot ; inline
+
+: set-local-value 2 set-slot ; inline
+
+: drop-locals ( n -- )
+ dup zero? [ drop ] [ r> drop 1- drop-locals ] if ;
+
+\ load-locals [
+ pop-literal nip
+ [ dup reverse <effect> infer-shuffle ]
+ [ infer->r ]
+ bi
+] "infer" set-word-prop
+
+\ get-local [
+ pop-literal nip
+ [ infer-r> ]
+ [ dup 0 prefix <effect> infer-shuffle ]
+ [ infer->r ]
+ tri
+] "infer" set-word-prop
+
+\ drop-locals [
+ pop-literal nip
+ [ infer-r> ]
+ [ { } <effect> infer-shuffle ] bi
+] "infer" set-word-prop
+
+<<
+{ load-locals get-local drop-locals }
+[ t "no-compile" set-word-prop ] each
+>>
diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor
index 4ee9b48bb7..c13be40c8f 100755
--- a/extra/locals/locals-tests.factor
+++ b/extra/locals/locals-tests.factor
@@ -82,6 +82,8 @@ IN: locals.tests
0 write-test-1 "q" set
+{ 1 1 } "q" get must-infer-as
+
[ 1 ] [ 1 "q" get call ] unit-test
[ 2 ] [ 1 "q" get call ] unit-test
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index 2b0c61cc89..be73f1db88 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -4,7 +4,8 @@ USING: kernel namespaces sequences sequences.private assocs math
inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables prettyprint.sections sets
-sequences.private effects generic compiler.units accessors ;
+sequences.private effects generic compiler.units accessors
+locals.backend ;
IN: locals
! Inspired by
@@ -56,95 +57,80 @@ TUPLE: quote local ;
C: <quote> quote
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! read-local
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: local-index ( obj args -- n )
[ dup quote? [ quote-local ] when eq? ] with find drop ;
-: read-local ( obj args -- quot )
- local-index 1+
- dup [ r> ] <repetition> concat [ dup ] append
- swap [ swap >r ] <repetition> concat append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! localize
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: read-local-quot ( obj args -- quot )
+ local-index 1+ [ get-local ] curry ;
: localize-writer ( obj args -- quot )
- >r "local-reader" word-prop r> read-local [ 0 swap set-array-nth ] append ;
+ >r "local-reader" word-prop r>
+ read-local-quot [ set-local-value ] append ;
: localize ( obj args -- quot )
{
- { [ over local? ] [ read-local ] }
- { [ over quote? ] [ >r quote-local r> read-local ] }
- { [ over local-word? ] [ read-local [ call ] append ] }
- { [ over local-reader? ] [ read-local [ 0 swap array-nth ] append ] }
+ { [ over local? ] [ read-local-quot ] }
+ { [ over quote? ] [ >r quote-local r> read-local-quot ] }
+ { [ over local-word? ] [ read-local-quot [ call ] append ] }
+ { [ over local-reader? ] [ read-local-quot [ local-value ] append ] }
{ [ over local-writer? ] [ localize-writer ] }
{ [ over \ lambda eq? ] [ 2drop [ ] ] }
{ [ t ] [ drop 1quotation ] }
} cond ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! point-free
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
UNION: special local quote local-word local-reader local-writer ;
-: load-local ( arg -- quot )
- local-reader? [ 1array >r ] [ >r ] ? ;
+: load-locals-quot ( args -- quot )
+ dup [ local-reader? ] contains? [
+ <reversed> [
+ local-reader? [ 1array >r ] [ >r ] ?
+ ] map concat
+ ] [
+ length [ load-locals ] curry >quotation
+ ] if ;
-: load-locals ( quot args -- quot )
- nip <reversed> [ load-local ] map concat ;
-
-: drop-locals ( args -- args quot )
- dup length [ r> drop ] <repetition> concat ;
+: drop-locals-quot ( args -- quot )
+ length [ drop-locals ] curry ;
: point-free-body ( quot args -- newquot )
>r 1 head-slice* r> [ localize ] curry map concat ;
: point-free-end ( quot args -- newquot )
over peek special?
- [ drop-locals >r >r peek r> localize r> append ]
- [ drop-locals nip swap peek suffix ]
+ [ dup drop-locals-quot >r >r peek r> localize r> append ]
+ [ dup drop-locals-quot nip swap peek suffix ]
if ;
: (point-free) ( quot args -- newquot )
- [ load-locals ] [ point-free-body ] [ point-free-end ]
+ [ nip load-locals-quot ]
+ [ point-free-body ]
+ [ point-free-end ]
2tri 3append >quotation ;
: point-free ( quot args -- newquot )
over empty? [ drop ] [ (point-free) ] if ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! free-vars
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
UNION: lexical local local-reader local-writer local-word ;
-GENERIC: free-vars ( form -- vars )
+GENERIC: free-vars* ( form -- )
-: add-if-free ( vars object -- vars )
+: free-vars ( form -- vars )
+ [ free-vars* ] { } make prune ;
+
+: add-if-free ( object -- )
{
- { [ dup local-writer? ] [ "local-reader" word-prop suffix ] }
- { [ dup lexical? ] [ suffix ] }
- { [ dup quote? ] [ quote-local suffix ] }
- { [ t ] [ free-vars append ] }
+ { [ dup local-writer? ] [ "local-reader" word-prop , ] }
+ { [ dup lexical? ] [ , ] }
+ { [ dup quote? ] [ local>> , ] }
+ { [ t ] [ free-vars* ] }
} cond ;
-M: object free-vars drop { } ;
+M: object free-vars* drop ;
-M: quotation free-vars { } [ add-if-free ] reduce ;
+M: quotation free-vars* [ add-if-free ] each ;
-M: lambda free-vars
- dup vars>> swap body>> free-vars diff ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! lambda-rewrite
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+M: lambda free-vars*
+ [ vars>> ] [ body>> ] bi free-vars diff % ;
GENERIC: lambda-rewrite* ( obj -- )
@@ -172,8 +158,8 @@ M: lambda block-vars vars>> ;
M: lambda block-body body>> ;
M: lambda local-rewrite*
- dup vars>> swap body>>
- [ local-rewrite* \ call , ] [ ] make <lambda> , ;
+ [ vars>> ] [ body>> ] bi
+ [ [ local-rewrite* ] each ] [ ] make <lambda> , ;
M: block lambda-rewrite*
#! Turn free variables into bound variables, curry them
@@ -188,8 +174,6 @@ M: object lambda-rewrite* , ;
M: object local-rewrite* , ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: make-local ( name -- word )
"!" ?tail [
<local-reader>
diff --git a/extra/math/fft/fft.factor b/extra/math/fft/fft.factor
index 625be534ce..4d4068158e 100644
--- a/extra/math/fft/fft.factor
+++ b/extra/math/fft/fft.factor
@@ -1,7 +1,7 @@
! Fast Fourier Transform, copyright (C) 2007 Hans Schmid
! http://dressguardmeister.blogspot.com/2007/01/fft.html
USING: arrays sequences math math.vectors math.constants
-math.functions kernel splitting ;
+math.functions kernel splitting columns ;
IN: math.fft
: n^v ( n v -- w ) [ ^ ] with map ;
diff --git a/extra/math/functions/functions-docs.factor b/extra/math/functions/functions-docs.factor
index f0819fb03e..35471653dc 100755
--- a/extra/math/functions/functions-docs.factor
+++ b/extra/math/functions/functions-docs.factor
@@ -7,6 +7,9 @@ ARTICLE: "integer-functions" "Integer functions"
{ $subsection gcd }
{ $subsection log2 }
{ $subsection next-power-of-2 }
+"Modular exponentiation:"
+{ $subsection ^mod }
+{ $subsection mod-inv }
"Tests:"
{ $subsection power-of-2? }
{ $subsection even? }
@@ -33,7 +36,9 @@ ARTICLE: "arithmetic-functions" "Arithmetic functions"
{ $subsection ceiling }
{ $subsection floor }
{ $subsection truncate }
-{ $subsection round } ;
+{ $subsection round }
+"Inexact comparison:"
+{ $subsection ~ } ;
ARTICLE: "power-functions" "Powers and logarithms"
"Squares:"
@@ -107,10 +112,6 @@ HELP: >rect
{ $values { "z" number } { "x" real } { "y" real } }
{ $description "Extracts the real and imaginary components of a complex number." } ;
-HELP: power-of-2?
-{ $values { "n" integer } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
-
HELP: align
{ $values { "m" integer } { "w" "a power of 2" } { "n" "an integer multiple of " { $snippet "w" } } }
{ $description "Outputs the least multiple of " { $snippet "w" } " greater than " { $snippet "m" } "." }
diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor
index 6773678dab..8c71eb545b 100755
--- a/extra/math/functions/functions-tests.factor
+++ b/extra/math/functions/functions-tests.factor
@@ -81,9 +81,6 @@ IN: math.functions.tests
[ 1/8 ] [ 2 -3 ^ ] unit-test
[ t ] [ 1 100 shift 2 100 ^ = ] unit-test
-[ t ] [ 256 power-of-2? ] unit-test
-[ f ] [ 123 power-of-2? ] unit-test
-
[ 1 ] [ 7/8 ceiling ] unit-test
[ 2 ] [ 3/2 ceiling ] unit-test
[ 0 ] [ -7/8 ceiling ] unit-test
diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor
index b3cfba8650..632939ff71 100755
--- a/extra/math/functions/functions.factor
+++ b/extra/math/functions/functions.factor
@@ -102,9 +102,6 @@ M: real absq sq ;
[ ~abs ]
} cond ;
-: power-of-2? ( n -- ? )
- dup 0 < [ drop f ] [ dup 1- bitand zero? ] if ; foldable
-
: >rect ( z -- x y ) dup real-part swap imaginary-part ; inline
: conjugate ( z -- z* ) >rect neg rect> ; inline
diff --git a/extra/math/haar/haar.factor b/extra/math/haar/haar.factor
index 91d9fd8ece..9254fd0ce7 100644
--- a/extra/math/haar/haar.factor
+++ b/extra/math/haar/haar.factor
@@ -1,5 +1,5 @@
! Haar wavelet transform -- http://dmr.ath.cx/gfx/haar/
-USING: sequences math kernel splitting ;
+USING: sequences math kernel splitting columns ;
IN: math.haar
: averages ( seq -- seq )
diff --git a/extra/math/ranges/ranges.factor b/extra/math/ranges/ranges.factor
index 81b7f63427..cc7d0758e5 100755
--- a/extra/math/ranges/ranges.factor
+++ b/extra/math/ranges/ranges.factor
@@ -1,4 +1,5 @@
-USING: kernel layouts math namespaces sequences sequences.private ;
+USING: kernel layouts math namespaces sequences
+sequences.private accessors ;
IN: math.ranges
TUPLE: range from length step ;
@@ -9,10 +10,10 @@ TUPLE: range from length step ;
range boa ;
M: range length ( seq -- n )
- range-length ;
+ length>> ;
M: range nth-unsafe ( n range -- obj )
- [ range-step * ] keep range-from + ;
+ [ step>> * ] keep from>> + ;
INSTANCE: range immutable-sequence
@@ -37,10 +38,10 @@ INSTANCE: range immutable-sequence
: [0,b) ( b -- range ) 0 swap [a,b) ;
: range-increasing? ( range -- ? )
- range-step 0 > ;
+ step>> 0 > ;
: range-decreasing? ( range -- ? )
- range-step 0 < ;
+ step>> 0 < ;
: first-or-peek ( seq head? -- elt )
[ first ] [ peek ] if ;
@@ -52,7 +53,7 @@ INSTANCE: range immutable-sequence
dup range-decreasing? first-or-peek ;
: clamp-to-range ( n range -- n )
- tuck range-min max swap range-max min ;
+ [ range-min max ] [ range-max min ] bi ;
: sequence-index-range ( seq -- range )
length [0,b) ;
diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor
index 6a191f0e07..3e5f66eb6f 100644
--- a/extra/newfx/newfx.factor
+++ b/extra/newfx/newfx.factor
@@ -155,6 +155,23 @@ METHOD: as-mutate { object object assoc } set-at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: prefix-on ( elt seq -- seq ) swap prefix ;
+: suffix-on ( elt seq -- seq ) swap suffix ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 1st 0 at ;
+: 2nd 1 at ;
+: 3rd 2 at ;
+: 4th 3 at ;
+: 5th 4 at ;
+: 6th 5 at ;
+: 7th 6 at ;
+: 8th 7 at ;
+: 9th 8 at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
! A note about the 'mutate' qualifier. Other words also technically mutate
! their primary object. However, the 'mutate' qualifier is supposed to
! indicate that this is the main objective of the word, as a side effect.
\ No newline at end of file
diff --git a/extra/odbc/odbc.factor b/extra/odbc/odbc.factor
index 59f5095aad..0bcd639bc1 100644
--- a/extra/odbc/odbc.factor
+++ b/extra/odbc/odbc.factor
@@ -1,10 +1,11 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel alien alien.syntax combinators alien.c-types
- strings sequences namespaces words math threads ;
+USING: kernel alien alien.strings alien.syntax combinators
+alien.c-types strings sequences namespaces words math threads
+io.encodings.ascii ;
IN: odbc
-"odbc" "odbc32.dll" "stdcall" add-library
+<< "odbc" "odbc32.dll" "stdcall" add-library >>
LIBRARY: odbc
@@ -150,7 +151,7 @@ FUNCTION: SQLRETURN SQLGetData ( SQLHSTMT statementHandle, SQLUSMALLINT columnNu
SQL-HANDLE-STMT swap alloc-handle ;
: temp-string ( length -- byte-array length )
- [ CHAR: \space <string> string>char-alien ] keep ;
+ [ CHAR: \space <string> ascii string>alien ] keep ;
: odbc-init ( -- env )
alloc-env-handle
@@ -192,7 +193,7 @@ C: <column> column
: odbc-describe-column ( statement n -- column )
dup >r
- 1024 CHAR: \space <string> string>char-alien dup >r
+ 1024 CHAR: \space <string> ascii string>alien dup >r
1024
0 <short>
0 <short> dup >r
@@ -204,7 +205,7 @@ C: <column> column
r> *short
r> *uint
r> *short convert-sql-type
- r> alien>char-string
+ r> ascii alien>string
r> <column>
] [
r> drop r> drop r> drop r> drop r> drop r> drop
@@ -213,12 +214,12 @@ C: <column> column
: dereference-type-pointer ( byte-array column -- object )
column-type {
- { SQL-CHAR [ alien>char-string ] }
- { SQL-VARCHAR [ alien>char-string ] }
- { SQL-LONGVARCHAR [ alien>char-string ] }
- { SQL-WCHAR [ alien>char-string ] }
- { SQL-WCHARVAR [ alien>char-string ] }
- { SQL-WLONGCHARVAR [ alien>char-string ] }
+ { SQL-CHAR [ ascii alien>string ] }
+ { SQL-VARCHAR [ ascii alien>string ] }
+ { SQL-LONGVARCHAR [ ascii alien>string ] }
+ { SQL-WCHAR [ ascii alien>string ] }
+ { SQL-WCHARVAR [ ascii alien>string ] }
+ { SQL-WLONGCHARVAR [ ascii alien>string ] }
{ SQL-SMALLINT [ *short ] }
{ SQL-INTEGER [ *long ] }
{ SQL-REAL [ *float ] }
@@ -236,7 +237,7 @@ C: <field> field
: odbc-get-field ( statement column -- field )
dup column? [ dupd odbc-describe-column ] unless dup >r column-number
SQL-C-DEFAULT
- 8192 CHAR: \space <string> string>char-alien dup >r
+ 8192 CHAR: \space <string> ascii string>alien dup >r
8192
f SQLGetData succeeded? [
r> r> [ dereference-type-pointer ] keep <field>
diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor
index e352eabc10..c05e180c11 100755
--- a/extra/opengl/shaders/shaders.factor
+++ b/extra/opengl/shaders/shaders.factor
@@ -1,14 +1,12 @@
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
-assocs alien libc opengl math sequences combinators
-combinators.lib macros arrays ;
+assocs alien alien.strings libc opengl math sequences combinators
+combinators.lib macros arrays io.encodings.ascii ;
IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- )
- swap string>char-alien malloc-byte-array [
- <void*> swap call
- ] keep free ; inline
+ swap ascii malloc-string [ <void*> swap call ] keep free ; inline
: <gl-shader> ( source kind -- shader )
glCreateShader dup rot
@@ -47,7 +45,7 @@ IN: opengl.shaders
: gl-shader-info-log ( shader -- log )
dup gl-shader-info-log-length dup [
[ 0 <int> swap glGetShaderInfoLog ] keep
- alien>char-string
+ ascii alien>string
] with-malloc ;
: check-gl-shader ( shader -- shader )
@@ -82,7 +80,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
: gl-program-info-log ( program -- log )
dup gl-program-info-log-length dup [
[ 0 <int> swap glGetProgramInfoLog ] keep
- alien>char-string
+ ascii alien>string
] with-malloc ;
: check-gl-program ( program -- program )
diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor
index c85c0ee218..5825ca7270 100755
--- a/extra/openssl/openssl-tests.factor
+++ b/extra/openssl/openssl-tests.factor
@@ -1,6 +1,7 @@
-USING: alien alien.c-types assocs bit-arrays hashtables io io.files
-io.sockets kernel mirrors openssl.libcrypto openssl.libssl
-namespaces math math.parser openssl prettyprint sequences tools.test ;
+USING: alien alien.c-types alien.strings assocs bit-arrays
+hashtables io io.files io.encodings.ascii io.sockets kernel
+mirrors openssl.libcrypto openssl.libssl namespaces math
+math.parser openssl prettyprint sequences tools.test ;
! =========================================================
! Some crypto functions (still to be turned into words)
@@ -31,7 +32,7 @@ namespaces math math.parser openssl prettyprint sequences tools.test ;
! TODO: debug 'Memory protection fault at address 6c'
! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd
-[ ] [ get-ctx "password" string>char-alien set-default-passwd-userdata ] unit-test
+[ ] [ get-ctx "password" ascii string>alien set-default-passwd-userdata ] unit-test
! Enter PEM pass phrase: password
[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path
diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor
index bfa7f32594..9b23774598 100755
--- a/extra/openssl/openssl.factor
+++ b/extra/openssl/openssl.factor
@@ -3,8 +3,9 @@
!
! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
-USING: alien alien.c-types assocs kernel libc namespaces
-openssl.libcrypto openssl.libssl sequences ;
+USING: alien alien.c-types alien.strings assocs kernel libc
+namespaces openssl.libcrypto openssl.libssl sequences
+io.encodings.ascii ;
IN: openssl
@@ -21,7 +22,7 @@ SYMBOL: rsa
: password-cb ( -- alien )
"int" { "char*" "int" "int" "void*" } "cdecl"
- [ 3drop "password" string>char-alien 1023 memcpy
+ [ 3drop "password" ascii string>alien 1023 memcpy
"password" length ] alien-callback ;
! =========================================================
diff --git a/extra/oracle/oracle.factor b/extra/oracle/oracle.factor
index 44b746f8ce..8ef169810a 100644
--- a/extra/oracle/oracle.factor
+++ b/extra/oracle/oracle.factor
@@ -4,8 +4,9 @@
! Adapted from oci.h and ociap.h
! Tested with Oracle version - 10.1.0.3 Instant Client
-USING: alien alien.c-types combinators kernel math namespaces oracle.liboci
-prettyprint sequences ;
+USING: alien alien.c-types alien.strings combinators kernel math
+namespaces oracle.liboci prettyprint sequences
+io.encodings.ascii ;
IN: oracle
@@ -31,7 +32,7 @@ C: <connection> connection
: get-oci-error ( object -- * )
1 f "uint*" <c-object> dup >r 512 "uchar" <c-array> dup >r
512 OCI_HTYPE_ERROR OCIErrorGet r> r> *uint drop
- alien>char-string throw ;
+ ascii alien>string throw ;
: check-result ( result -- )
{
@@ -101,9 +102,9 @@ C: <connection> connection
: oci-log-on ( -- )
env get err get svc get
- con get connection-username dup length swap malloc-char-string swap
- con get connection-password dup length swap malloc-char-string swap
- con get connection-db dup length swap malloc-char-string swap
+ con get connection-username dup length swap ascii malloc-string swap
+ con get connection-password dup length swap ascii malloc-string swap
+ con get connection-db dup length swap ascii malloc-string swap
OCILogon check-result ;
! =========================================================
@@ -118,11 +119,11 @@ C: <connection> connection
svc get OCI_HTYPE_SVCCTX srv get 0 OCI_ATTR_SERVER err get OCIAttrSet check-result ;
: set-username-attribute ( -- )
- ses get OCI_HTYPE_SESSION con get connection-username dup length swap malloc-char-string swap
+ ses get OCI_HTYPE_SESSION con get connection-username dup length swap ascii malloc-string swap
OCI_ATTR_USERNAME err get OCIAttrSet check-result ;
: set-password-attribute ( -- )
- ses get OCI_HTYPE_SESSION con get connection-password dup length swap malloc-char-string swap
+ ses get OCI_HTYPE_SESSION con get connection-password dup length swap ascii malloc-string swap
OCI_ATTR_PASSWORD err get OCIAttrSet check-result ;
: set-attributes ( -- )
@@ -150,7 +151,7 @@ C: <connection> connection
check-result *void* stm set ;
: prepare-statement ( statement -- )
- >r stm get err get r> dup length swap malloc-char-string swap
+ >r stm get err get r> dup length swap ascii malloc-string swap
OCI_NTV_SYNTAX OCI_DEFAULT OCIStmtPrepare check-result ;
: calculate-size ( type -- size )
@@ -222,7 +223,7 @@ C: <connection> connection
: server-version ( -- )
srv get err get 512 "uchar" malloc-array dup >r 512 OCI_HTYPE_SERVER
- OCIServerVersion check-result r> alien>char-string . ;
+ OCIServerVersion check-result r> ascii alien>string . ;
! =========================================================
! Public routines
@@ -236,13 +237,13 @@ C: <connection> connection
: fetch-each ( object -- object )
fetch-statement [
- buf get alien>char-string res get swap suffix res set
+ buf get ascii alien>string res get swap suffix res set
fetch-each
] [ ] if ;
: run-query ( object -- object )
execute-statement [
- buf get alien>char-string res get swap suffix res set
+ buf get ascii alien>string res get swap suffix res set
fetch-each
] [ ] if ;
diff --git a/extra/project-euler/076/076.factor b/extra/project-euler/076/076.factor
new file mode 100644
index 0000000000..b09a2742c3
--- /dev/null
+++ b/extra/project-euler/076/076.factor
@@ -0,0 +1,53 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators kernel math sequences math.ranges locals ;
+IN: project-euler.076
+
+! http://projecteuler.net/index.php?section=problems&id=76
+
+! DESCRIPTION
+! -----------
+
+! How many different ways can one hundred be written as a
+! sum of at least two positive integers?
+
+! SOLUTION
+! --------
+
+! This solution uses dynamic programming and the following
+! recurence relation:
+
+! ways(0,_) = 1
+! ways(_,0) = 0
+! ways(n,i) = ways(n-i,i) + ways(n,i-1)
+
+<PRIVATE
+
+: init ( n -- table )
+ [1,b] [ 0 2array 0 ] H{ } map>assoc
+ 1 { 0 0 } pick set-at ;
+
+: use ( n i -- n i )
+ [ - dup ] keep min ; inline
+
+: ways ( n i table -- )
+ over zero? [
+ 3drop
+ ] [
+ [ [ 1- 2array ] dip at ]
+ [ [ use 2array ] dip at + ]
+ [ [ 2array ] dip set-at ] 3tri
+ ] if ;
+
+:: each-subproblem ( n quot -- )
+ n [1,b] [ dup [1,b] quot with each ] each ; inline
+
+PRIVATE>
+
+: (euler076) ( n -- m )
+ dup init
+ [ [ ways ] curry each-subproblem ]
+ [ [ dup 2array ] dip at 1- ] 2bi ;
+
+: euler076 ( -- m )
+ 100 (euler076) ;
diff --git a/extra/project-euler/116/116.factor b/extra/project-euler/116/116.factor
new file mode 100644
index 0000000000..d48cdf175c
--- /dev/null
+++ b/extra/project-euler/116/116.factor
@@ -0,0 +1,55 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.ranges sequences sequences.lib ;
+
+IN: project-euler.116
+
+! http://projecteuler.net/index.php?section=problems&id=116
+
+! DESCRIPTION
+! -----------
+
+! A row of five black square tiles is to have a number of its tiles replaced
+! with coloured oblong tiles chosen from red (length two), green (length
+! three), or blue (length four).
+
+! If red tiles are chosen there are exactly seven ways this can be done.
+! If green tiles are chosen there are three ways.
+! And if blue tiles are chosen there are two ways.
+
+! Assuming that colours cannot be mixed there are 7 + 3 + 2 = 12 ways of
+! replacing the black tiles in a row measuring five units in length.
+
+! How many different ways can the black tiles in a row measuring fifty units in
+! length be replaced if colours cannot be mixed and at least one coloured tile
+! must be used?
+
+! SOLUTION
+! --------
+
+! This solution uses a simple dynamic programming approach using the
+! following recurence relation
+
+! ways(n,_) = 0 | n < 0
+! ways(0,_) = 1
+! ways(n,i) = ways(n-i,i) + ways(n-1,i)
+! solution(n) = ways(n,1) - 1 + ways(n,2) - 1 + ways(n,3) - 1
+
+<PRIVATE
+
+: nth* ( n seq -- elt/0 )
+ [ length swap - 1- ] keep ?nth 0 or ;
+
+: next ( colortile seq -- )
+ [ nth* ] [ peek + ] [ push ] tri ;
+
+: ways ( length colortile -- permutations )
+ V{ 1 } clone [ [ next ] 2curry times ] keep peek 1- ;
+
+PRIVATE>
+
+: (euler116) ( length -- permutations )
+ 3 [1,b] [ ways ] with sigma ;
+
+: euler116 ( -- permutations )
+ 50 (euler116) ;
diff --git a/extra/project-euler/117/117.factor b/extra/project-euler/117/117.factor
new file mode 100644
index 0000000000..5056560a85
--- /dev/null
+++ b/extra/project-euler/117/117.factor
@@ -0,0 +1,42 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math splitting sequences ;
+
+IN: project-euler.117
+
+! http://projecteuler.net/index.php?section=problems&id=117
+
+! DESCRIPTION
+! -----------
+
+! Using a combination of black square tiles and oblong tiles chosen
+! from: red tiles measuring two units, green tiles measuring three
+! units, and blue tiles measuring four units, it is possible to tile a
+! row measuring five units in length in exactly fifteen different ways.
+
+! How many ways can a row measuring fifty units in length be tiled?
+
+! SOLUTION
+! --------
+
+! This solution uses a simple dynamic programming approach using the
+! following recurence relation
+
+! ways(i) = 1 | i <= 0
+! ways(i) = ways(i-4) + ways(i-3) + ways(i-2) + ways(i-1)
+
+<PRIVATE
+
+: short ( seq n -- seq n )
+ over length min ;
+
+: next ( seq -- )
+ [ 4 short tail* sum ] keep push ;
+
+PRIVATE>
+
+: (euler117) ( n -- m )
+ V{ 1 } clone tuck [ next ] curry times peek ;
+
+: euler117 ( -- m )
+ 50 (euler117) ;
diff --git a/extra/project-euler/148/148.factor b/extra/project-euler/148/148.factor
new file mode 100644
index 0000000000..daad89a40c
--- /dev/null
+++ b/extra/project-euler/148/148.factor
@@ -0,0 +1,24 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions sequences sequences.lib ;
+
+IN: project-euler.148
+
+<PRIVATE
+
+: sum-1toN ( n -- sum )
+ dup 1+ * 2/ ; inline
+
+: >base7 ( x -- y )
+ [ dup 0 > ] [ 7 /mod ] [ ] unfold nip ;
+
+: (use-digit) ( prev x index -- next )
+ [ [ 1+ * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ;
+
+PRIVATE>
+
+: (euler148) ( x -- y )
+ >base7 0 [ (use-digit) ] reduce-index ;
+
+: euler148 ( -- y )
+ 10 9 ^ (euler148) ;
diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor
new file mode 100644
index 0000000000..c96c1ebc73
--- /dev/null
+++ b/extra/project-euler/150/150.factor
@@ -0,0 +1,52 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences sequences.private locals hints ;
+IN: project-euler.150
+
+<PRIVATE
+
+! sequence helper functions
+
+: partial-sums ( seq -- sums )
+ 0 [ + ] accumulate swap suffix ; inline
+
+: (partial-sum-infimum) ( inf sum elt -- inf sum )
+ + [ min ] keep ; inline
+
+: partial-sum-infimum ( seq -- seq )
+ 0 0 rot [ (partial-sum-infimum) ] each drop ; inline
+
+: generate ( n quot -- seq )
+ [ drop ] swap compose map ; inline
+
+: map-infimum ( seq quot -- min )
+ [ min ] compose 0 swap reduce ; inline
+
+
+! triangle generator functions
+
+: next ( t -- new-t s )
+ 615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
+
+: sums-triangle ( -- seq )
+ 0 1000 [ 1+ [ next ] generate partial-sums ] map nip ;
+
+PRIVATE>
+
+:: (euler150) ( m -- n )
+ [let | table [ sums-triangle ] |
+ m [| x |
+ x 1+ [| y |
+ m x - [| z |
+ x z + table nth-unsafe
+ [ y z + 1+ swap nth-unsafe ]
+ [ y swap nth-unsafe ] bi -
+ ] map partial-sum-infimum
+ ] map-infimum
+ ] map-infimum
+ ] ;
+
+HINTS: (euler150) fixnum ;
+
+: euler150 ( -- n )
+ 1000 (euler150) ;
diff --git a/extra/project-euler/164/164.factor b/extra/project-euler/164/164.factor
new file mode 100644
index 0000000000..bf1f5dcf9b
--- /dev/null
+++ b/extra/project-euler/164/164.factor
@@ -0,0 +1,33 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs kernel math math.ranges sequences ;
+
+IN: project-euler.164
+
+! http://projecteuler.net/index.php?section=problems&id=164
+
+! DESCRIPTION
+! -----------
+
+! How many 20 digit numbers n (without any leading zero) exist such
+! that no three consecutive digits of n have a sum greater than 9?
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: next-keys ( key -- keys )
+ [ peek ] [ 10 swap sum - ] bi [ 2array ] with map ;
+
+: next-table ( assoc -- assoc )
+ H{ } clone swap
+ [ swap next-keys [ pick at+ ] with each ] assoc-each ;
+
+: init-table ( -- assoc )
+ 9 [1,b] [ 1array 1 ] H{ } map>assoc ;
+
+PRIVATE>
+
+: euler164 ( -- n )
+ init-table 19 [ next-table ] times values sum ;
diff --git a/extra/project-euler/190/190.factor b/extra/project-euler/190/190.factor
new file mode 100644
index 0000000000..6fc15c9f30
--- /dev/null
+++ b/extra/project-euler/190/190.factor
@@ -0,0 +1,48 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences sequences.lib math math.functions math.ranges locals ;
+IN: project-euler.190
+
+! PROBLEM
+! -------
+
+! http://projecteuler.net/index.php?section=problems&id=190
+
+! Let Sm = (x1, x2, ... , xm) be the m-tuple of positive real numbers
+! with x1 + x2 + ... + xm = m for which Pm = x1 * x22 * ... * xmm is
+! maximised.
+
+! For example, it can be verified that [P10] = 4112 ([ ] is the integer
+! part function).
+
+! Find Σ[Pm] for 2 ≤ m ≤ 15.
+
+! SOLUTION
+! --------
+
+! Pm = x1 * x2^2 * x3^3 * ... * xm^m
+! fm = x1 + x2 + x3 + ... + xm - m = 0
+! Gm === Pm - L * fm
+! dG/dx_i = 0 = i * Pm / xi - L
+! xi = i * Pm / L
+
+! Sum(i=1 to m) xi = m
+! Sum(i=1 to m) i * Pm / L = m
+! Pm / L * Sum(i=1 to m) i = m
+! Pm / L * m*(m+1)/2 = m
+! Pm / L = 2 / (m+1)
+
+! xi = i * (2 / (m+1)) = 2*i/(m+1)
+
+<PRIVATE
+
+: PI ( seq quot -- n )
+ [ * ] compose 1 swap reduce ; inline
+
+PRIVATE>
+
+:: P_m ( m -- P_m )
+ m [1,b] [| i | 2 i * m 1+ / i ^ ] PI ;
+
+: euler190 ( -- n )
+ 2 15 [a,b] [ P_m truncate ] sigma ;
diff --git a/extra/random/blum-blum-shub/blum-blum-shub-tests.factor b/extra/random/blum-blum-shub/blum-blum-shub-tests.factor
index a92f256eeb..c882dd2b4d 100644
--- a/extra/random/blum-blum-shub/blum-blum-shub-tests.factor
+++ b/extra/random/blum-blum-shub/blum-blum-shub-tests.factor
@@ -1,27 +1,29 @@
USING: kernel math tools.test namespaces random
-random.blum-blum-shub ;
+random.blum-blum-shub alien.c-types sequences splitting ;
IN: blum-blum-shub.tests
[ 887708070 ] [
- T{ blum-blum-shub f 590695557939 811977232793 } random-32*
+ T{ blum-blum-shub f 590695557939 811977232793 } clone random-32*
] unit-test
[ 887708070 ] [
- T{ blum-blum-shub f 590695557939 811977232793 } [
+ T{ blum-blum-shub f 590695557939 811977232793 } clone [
32 random-bits
+ little-endian? [ <uint> reverse *uint ] unless
] with-random
] unit-test
[ 5726770047455156646 ] [
- T{ blum-blum-shub f 590695557939 811977232793 } [
+ T{ blum-blum-shub f 590695557939 811977232793 } clone [
64 random-bits
+ little-endian? [ <ulonglong> 4 group [ reverse ] map concat *ulonglong ] unless
] with-random
] unit-test
[ 3716213681 ]
[
- 100 T{ blum-blum-shub f 200352954495 846054538649 } tuck [
+ 100 T{ blum-blum-shub f 200352954495 846054538649 } clone tuck [
random-32* drop
] curry times
random-32*
diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor
index db8fe540e5..e60990075c 100755
--- a/extra/random/blum-blum-shub/blum-blum-shub.factor
+++ b/extra/random/blum-blum-shub/blum-blum-shub.factor
@@ -12,17 +12,16 @@ TUPLE: blum-blum-shub x n ;
: generate-bbs-primes ( numbits -- p q )
[ [ random-prime ] curry [ 4 mod 3 = ] generate ] dup bi ;
+: next-bbs-bit ( bbs -- bit )
+ [ [ x>> 2 ] [ n>> ] bi ^mod dup ] keep (>>x) 1 bitand ;
+
+PRIVATE>
+
: <blum-blum-shub> ( numbits -- blum-blum-shub )
generate-bbs-primes *
[ find-relative-prime ] keep
blum-blum-shub boa ;
-: next-bbs-bit ( bbs -- bit )
- [ [ x>> 2 ] [ n>> ] bi ^mod ] keep
- over >>x drop 1 bitand ;
-
-PRIVATE>
-
M: blum-blum-shub random-32* ( bbs -- r )
0 32 rot
[ next-bbs-bit swap 1 shift bitor ] curry times ;
diff --git a/extra/regexp/regexp-tests.factor b/extra/regexp/regexp-tests.factor
index 5a6b0bdfac..e9433c6c64 100755
--- a/extra/regexp/regexp-tests.factor
+++ b/extra/regexp/regexp-tests.factor
@@ -226,3 +226,10 @@ IN: regexp-tests
[ t ] [ "s@f" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
[ f ] [ "a" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
[ t ] [ ".o" "\\.[a-z]" f <regexp> matches? ] unit-test
+
+! Bug in parsing word
+[ t ] [
+ "a"
+ R' a'
+ matches?
+] unit-test
diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor
index 6b344ad140..d517db09fe 100755
--- a/extra/regexp/regexp.factor
+++ b/extra/regexp/regexp.factor
@@ -290,10 +290,11 @@ TUPLE: regexp source parser ignore-case? ;
} case ;
: parse-regexp ( accum end -- accum )
- lexer get dup skip-blank [
- [ index* dup 1+ swap ] 2keep swapd subseq swap
- ] change-lexer-column
- lexer get (parse-token) parse-options <regexp> parsed ;
+ lexer get dup skip-blank
+ [ [ index* dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
+ lexer get dup still-parsing-line?
+ [ (parse-token) parse-options ] [ drop f ] if
+ <regexp> parsed ;
: R! CHAR: ! parse-regexp ; parsing
: R" CHAR: " parse-regexp ; parsing
diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor
index 77364d73e7..252defe99b 100755
--- a/extra/rss/rss-tests.factor
+++ b/extra/rss/rss-tests.factor
@@ -1,10 +1,11 @@
-USING: rss io kernel io.files tools.test io.encodings.utf8 ;
+USING: rss io kernel io.files tools.test io.encodings.utf8
+calendar ;
IN: rss.tests
: load-news-file ( filename -- feed )
#! Load an news syndication file and process it, returning
#! it as an feed tuple.
- utf8 <file-reader> read-feed ;
+ utf8 file-contents read-feed ;
[ T{
feed
@@ -35,7 +36,7 @@ IN: rss.tests
"http://example.org/2005/04/02/atom"
"\n <div xmlns=\"http://www.w3.org/1999/xhtml\">\n <p><i>[Update: The Atom draft is finished.]</i></p>\n </div>\n "
- "2003-12-13T08:29:29-04:00"
+ T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } }
}
}
} ] [ "extra/rss/atom.xml" resource-path load-news-file ] unit-test
diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor
index 99360e5509..5fc688967a 100644
--- a/extra/rss/rss.factor
+++ b/extra/rss/rss.factor
@@ -4,10 +4,8 @@ IN: rss
USING: xml.utilities kernel assocs xml.generator
strings sequences xml.data xml.writer
io.streams.string combinators xml xml.entities io.files io
- http.client namespaces xml.generator hashtables ;
-
-: ?children>string ( tag/f -- string/f )
- [ children>string ] [ f ] if* ;
+ http.client namespaces xml.generator hashtables
+ calendar.format accessors continuations ;
: any-tag-named ( tag names -- tag-inside )
f -rot [ tag-named nip dup ] with find 2drop ;
@@ -25,7 +23,7 @@ C: <entry> entry
[ "link" tag-named children>string ] keep
[ "description" tag-named children>string ] keep
f "date" "http://purl.org/dc/elements/1.1/" <name>
- tag-named ?children>string
+ tag-named dup [ children>string rfc822>timestamp ] when
<entry> ;
: rss1.0 ( xml -- feed )
@@ -41,7 +39,7 @@ C: <entry> entry
[ "link" tag-named ] keep
[ "guid" tag-named dupd ? children>string ] keep
[ "description" tag-named children>string ] keep
- "pubDate" tag-named children>string <entry> ;
+ "pubDate" tag-named children>string rfc822>timestamp <entry> ;
: rss2.0 ( xml -- feed )
"channel" tag-named
@@ -59,7 +57,7 @@ C: <entry> entry
[ children>string ] if
] keep
{ "published" "updated" "issued" "modified" } any-tag-named
- children>string <entry> ;
+ children>string rfc3339>timestamp <entry> ;
: atom1.0 ( xml -- feed )
[ "title" tag-named children>string ] keep
@@ -73,16 +71,12 @@ C: <entry> entry
{ "feed" [ atom1.0 ] }
} case ;
-: read-feed ( stream -- feed )
- [ read-xml ] with-html-entities xml>feed ;
+: read-feed ( string -- feed )
+ [ string>xml xml>feed ] with-html-entities ;
: download-feed ( url -- feed )
#! Retrieve an news syndication file, return as a feed tuple.
- http-get-stream rot success? [
- nip read-feed
- ] [
- 2drop "Error retrieving newsfeed file" throw
- ] if ;
+ http-get read-feed ;
! Atom generation
: simple-tag, ( content name -- )
@@ -95,7 +89,7 @@ C: <entry> entry
"entry" [
dup entry-title "title" { { "type" "html" } } simple-tag*,
"link" over entry-link "href" associate contained*,
- dup entry-pub-date "published" simple-tag,
+ dup entry-pub-date timestamp>rfc3339 "published" simple-tag,
entry-description [ "content" { { "type" "html" } } simple-tag*, ] when*
] tag, ;
diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor
index dad1dd3919..51bd94d61c 100755
--- a/extra/semantic-db/semantic-db.factor
+++ b/extra/semantic-db/semantic-db.factor
@@ -96,8 +96,6 @@ arc "arc"
node create-table arc create-table
create-bootstrap-nodes create-bootstrap-arcs ;
-: param ( value key type -- param ) swapd 3array ;
-
! db utilities
: results ( bindings sql -- array )
f f <simple-statement> [ do-bound-query ] with-disposal ;
@@ -111,6 +109,9 @@ arc "arc"
: node-results ( results -- nodes )
[ node-result ] map ;
+: param ( value key type -- param )
+ swapd <sqlite-low-level-binding> ;
+
: subjects-with-cor ( content object relation -- sql-results )
[ id>> ] bi@
[
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 15983329d6..b186ee7777 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -35,6 +35,10 @@ MACRO: firstn ( n -- )
#! quot: ( elt index -- obj )
prepare-index 2map ; inline
+: reduce-index ( seq identity quot -- )
+ #! quot: ( prev elt index -- next )
+ swapd each-index ; inline
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: each-percent ( seq quot -- )
@@ -48,7 +52,7 @@ MACRO: firstn ( n -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: sigma ( seq quot -- n )
- [ rot slip + ] curry 0 swap reduce ; inline
+ [ + ] compose 0 swap reduce ; inline
: count ( seq quot -- n )
[ 1 0 ? ] compose sigma ; inline
@@ -197,9 +201,6 @@ USE: continuations
>r >r 0 max r> r>
[ length tuck min >r min r> ] keep subseq ;
-: ?head* ( seq n -- seq/f ) (head) ?subseq ;
-: ?tail* ( seq n -- seq/f ) (tail) ?subseq ;
-
: accumulator ( quot -- quot vec )
V{ } clone [ [ push ] curry compose ] keep ; inline
diff --git a/extra/shell/parser/parser.factor b/extra/shell/parser/parser.factor
new file mode 100644
index 0000000000..46548bb34f
--- /dev/null
+++ b/extra/shell/parser/parser.factor
@@ -0,0 +1,94 @@
+
+USING: kernel arrays strings sequences sequences.deep accessors peg peg.ebnf
+ newfx ;
+
+IN: shell.parser
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: basic-expr command stdin stdout background ;
+TUPLE: pipeline-expr commands stdin stdout background ;
+TUPLE: single-quoted-expr expr ;
+TUPLE: double-quoted-expr expr ;
+TUPLE: back-quoted-expr expr ;
+TUPLE: glob-expr expr ;
+TUPLE: variable-expr expr ;
+TUPLE: factor-expr expr ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ast>basic-expr ( ast -- obj ) first4 basic-expr boa ;
+
+: ast>pipeline-expr ( ast -- obj )
+ pipeline-expr new
+ over [ 1st ] [ 4th [ 1st ] map ] [ 5th ] tri suffix prefix-on >>commands
+ over 2nd >>stdin
+ over 5th >>stdout
+ swap 6th >>background ;
+
+: ast>single-quoted-expr ( ast -- obj )
+ 2nd >string single-quoted-expr boa ;
+
+: ast>double-quoted-expr ( ast -- obj )
+ 2nd >string double-quoted-expr boa ;
+
+: ast>back-quoted-expr ( ast -- obj )
+ 2nd >string back-quoted-expr boa ;
+
+: ast>glob-expr ( ast -- obj ) flatten concat glob-expr boa ;
+
+: ast>variable-expr ( ast -- obj ) 2nd variable-expr boa ;
+
+: ast>factor-expr ( ast -- obj ) 2nd >string factor-expr boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+EBNF: expr
+
+space = " "
+
+tab = "\t"
+
+white = (space | tab)
+
+_ = (white)* => [[ drop ignore ]]
+
+sq = "'"
+dq = '"'
+bq = "`"
+
+single-quoted = sq (!(sq) .)* sq => [[ ast>single-quoted-expr ]]
+double-quoted = dq (!(dq) .)* dq => [[ ast>double-quoted-expr ]]
+back-quoted = bq (!(bq) .)* bq => [[ ast>back-quoted-expr ]]
+
+factor = "$(" (!(")") .)* ")" => [[ ast>factor-expr ]]
+
+variable = "$" other => [[ ast>variable-expr ]]
+
+glob-char = ("*" | "?")
+
+non-glob-char = !(glob-char | white) .
+
+glob-beginning-string = (non-glob-char)* => [[ >string ]]
+
+glob-rest-string = (non-glob-char)+ => [[ >string ]]
+
+glob = glob-beginning-string glob-char (glob-rest-string | glob-char)* => [[ ast>glob-expr ]]
+
+other = (!(white | "&" | ">" | ">>" | "<" | "|") .)+ => [[ >string ]]
+
+element = (single-quoted | double-quoted | back-quoted | factor | variable | glob | other)
+
+command = (element _)+
+
+to-file = ">" _ other => [[ second ]]
+in-file = "<" _ other => [[ second ]]
+ap-file = ">>" _ other => [[ second ]]
+
+basic = _ command _ (in-file)? _ (to-file | ap-file)? _ ("&")? => [[ ast>basic-expr ]]
+
+pipeline = _ command _ (in-file)? _ "|" _ (command _ "|" _)* command _ (to-file | ap-file)? _ ("&")? => [[ ast>pipeline-expr ]]
+
+submission = (pipeline | basic)
+
+;EBNF
\ No newline at end of file
diff --git a/extra/shell/shell.factor b/extra/shell/shell.factor
new file mode 100644
index 0000000000..7f30104e21
--- /dev/null
+++ b/extra/shell/shell.factor
@@ -0,0 +1,143 @@
+
+USING: kernel parser words continuations namespaces debugger
+ sequences combinators splitting prettyprint
+ system io io.files io.launcher io.encodings.utf8 sequences.deep
+ accessors multi-methods newfx shell.parser ;
+
+IN: shell
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cd ( args -- )
+ dup empty?
+ [ drop home set-current-directory ]
+ [ first set-current-directory ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pwd ( args -- )
+ drop
+ current-directory get
+ print ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: swords ( -- seq ) { "cd" "pwd" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: expand ( expr -- expr )
+
+METHOD: expand { single-quoted-expr } expr>> ;
+
+METHOD: expand { double-quoted-expr } expr>> ;
+
+METHOD: expand { variable-expr } expr>> os-env ;
+
+METHOD: expand { glob-expr }
+ expr>>
+ dup "*" =
+ [ drop current-directory get directory [ first ] map ]
+ [ ]
+ if ;
+
+METHOD: expand { factor-expr } expr>> eval unparse ;
+
+DEFER: expansion
+
+METHOD: expand { back-quoted-expr }
+ expr>>
+ expr
+ ast>>
+ command>>
+ expansion
+ utf8 <process-stream>
+ contents
+ " \n" split
+ "" remove ;
+
+METHOD: expand { object } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: expansion ( command -- command ) [ expand ] map flatten ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-sword ( basic-expr -- )
+ command>> expansion unclip "shell" lookup execute ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-foreground ( process -- )
+ [ try-process ] [ print-error drop ] recover ;
+
+: run-background ( process -- ) run-detached drop ;
+
+: run-basic-expr ( basic-expr -- )
+ <process>
+ over command>> expansion >>command
+ over stdin>> >>stdin
+ over stdout>> >>stdout
+ swap background>>
+ [ run-background ]
+ [ run-foreground ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: basic-chant ( basic-expr -- )
+ dup command>> first swords member-of?
+ [ run-sword ]
+ [ run-basic-expr ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pipeline-chant ( pipeline-chant -- )
+ drop "ix: pipelines not supported" print ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chant ( obj -- )
+ dup basic-expr?
+ [ basic-chant ]
+ [ pipeline-chant ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: prompt ( -- )
+ current-directory get write
+ " $ " write
+ flush ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: shell
+
+: handle ( input -- )
+ {
+ { [ dup f = ] [ drop ] }
+ { [ dup "exit" = ] [ drop ] }
+ { [ dup "" = ] [ drop shell ] }
+ { [ dup expr ] [ expr ast>> chant shell ] }
+ { [ t ] [ drop "ix: ignoring input" print shell ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: shell ( -- )
+ prompt
+ readln
+ handle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ix ( -- ) shell ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: ix
\ No newline at end of file
diff --git a/extra/sudoku/sudoku.factor b/extra/sudoku/sudoku.factor
index b0ba85c97f..1cb82253b1 100644
--- a/extra/sudoku/sudoku.factor
+++ b/extra/sudoku/sudoku.factor
@@ -1,6 +1,6 @@
! Based on http://www.ffconsultancy.com/ocaml/sudoku/index.html
USING: sequences namespaces kernel math math.parser io
-io.styles combinators ;
+io.styles combinators columns ;
IN: sudoku
SYMBOL: solutions
diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor
index b838654248..d4fbf1de78 100755
--- a/extra/tools/deploy/backend/backend.factor
+++ b/extra/tools/deploy/backend/backend.factor
@@ -8,6 +8,15 @@ debugger io.streams.c io.streams.duplex io.files io.backend
quotations io.launcher words.private tools.deploy.config
bootstrap.image io.encodings.utf8 accessors ;
IN: tools.deploy.backend
+
+: copy-vm ( executable bundle-name extension -- vm )
+ [ prepend-path ] dip append vm over copy-file ;
+
+: copy-fonts ( name dir -- )
+ append-path "fonts/" resource-path swap copy-tree-into ;
+
+: image-name ( vocab bundle-name -- str )
+ prepend-path ".image" append ;
: (copy-lines) ( stream -- )
dup stream-readln dup
diff --git a/extra/tools/deploy/deploy-docs.factor b/extra/tools/deploy/deploy-docs.factor
index b225236249..eccb3982c7 100755
--- a/extra/tools/deploy/deploy-docs.factor
+++ b/extra/tools/deploy/deploy-docs.factor
@@ -7,7 +7,12 @@ ARTICLE: "tools.deploy" "Application deployment"
$nl
"For example, we can deploy the " { $vocab-link "hello-world" } " demo which comes with Factor:"
{ $code "\"hello-ui\" deploy" }
-"On Mac OS X, this yields a program named " { $snippet "Hello world.app" } ". On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } ". In both cases, running the program displays a window with a message."
+{ $list
+ { "On Mac OS X, this yields a program named " { $snippet "Hello world.app" } "." }
+ { "On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } "." }
+ { "On Unix-like systems (Linux, BSD, Solaris, etc), it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui" } "." }
+}
+"In all cases, running the program displays a window with a message."
$nl
"The deployment tool works by bootstrapping a fresh image, loading the vocabulary into this image, then applying various heuristics to strip the image down to minimal size."
$nl
diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor
index 893b43844a..e57cc1f04b 100755
--- a/extra/tools/deploy/deploy.factor
+++ b/extra/tools/deploy/deploy.factor
@@ -1,9 +1,13 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.deploy.backend system vocabs.loader kernel ;
+USING: tools.deploy.backend system vocabs.loader kernel
+combinators ;
IN: tools.deploy
: deploy ( vocab -- ) deploy* ;
-os macosx? [ "tools.deploy.macosx" require ] when
-os winnt? [ "tools.deploy.windows" require ] when
+{
+ { [ os macosx? ] [ "tools.deploy.macosx" ] }
+ { [ os winnt? ] [ "tools.deploy.windows" ] }
+ { [ os unix? ] [ "tools.deploy.unix" ] }
+} cond require
\ No newline at end of file
diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor
index 3121866d94..d38b40db4b 100755
--- a/extra/tools/deploy/macosx/macosx.factor
+++ b/extra/tools/deploy/macosx/macosx.factor
@@ -14,13 +14,6 @@ IN: tools.deploy.macosx
bundle-dir over append-path -rot
"Contents" prepend-path append-path copy-tree ;
-: copy-vm ( executable bundle-name -- vm )
- "Contents/MacOS/" append-path prepend-path vm over copy-file ;
-
-: copy-fonts ( name -- )
- "fonts/" resource-path
- swap "Contents/Resources/" append-path copy-tree-into ;
-
: app-plist ( executable bundle-name -- assoc )
[
"6.0" "CFBundleInfoDictionaryVersion" set
@@ -38,10 +31,14 @@ IN: tools.deploy.macosx
write-plist ;
: create-app-dir ( vocab bundle-name -- vm )
- dup "Frameworks" copy-bundle-dir
- dup "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir
- dup copy-fonts
- 2dup create-app-plist copy-vm ;
+ [
+ nip
+ [ "Frameworks" copy-bundle-dir ]
+ [ "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir ]
+ [ "Contents/Resources/" copy-fonts ] tri
+ ]
+ [ create-app-plist ]
+ [ "Contents/MacOS/" append-path "" copy-vm ] 2tri ;
: deploy.app-image ( vocab bundle-name -- str )
[ % "/Contents/Resources/" % % ".image" % ] "" make ;
@@ -50,9 +47,8 @@ IN: tools.deploy.macosx
deploy-name get ".app" append ;
: show-in-finder ( path -- )
- NSWorkspace
- -> sharedWorkspace
- over <NSString> rot parent-directory <NSString>
+ [ NSWorkspace -> sharedWorkspace ]
+ [ normalize-path [ <NSString> ] [ parent-directory <NSString> ] bi ] bi*
-> selectFile:inFileViewerRootedAtPath: drop ;
M: macosx deploy* ( vocab -- )
@@ -63,6 +59,6 @@ M: macosx deploy* ( vocab -- )
[ bundle-name create-app-dir ] keep
[ bundle-name deploy.app-image ] keep
namespace make-deploy-image
- bundle-name normalize-path show-in-finder
+ bundle-name show-in-finder
] bind
] with-directory ;
diff --git a/extra/tools/deploy/unix/authors.txt b/extra/tools/deploy/unix/authors.txt
new file mode 100644
index 0000000000..4b7af4aac0
--- /dev/null
+++ b/extra/tools/deploy/unix/authors.txt
@@ -0,0 +1 @@
+James Cash
diff --git a/extra/tools/deploy/unix/summary.txt b/extra/tools/deploy/unix/summary.txt
new file mode 100644
index 0000000000..7cd80c5e35
--- /dev/null
+++ b/extra/tools/deploy/unix/summary.txt
@@ -0,0 +1 @@
+Deploying minimal stand-alone binaries on *nix-like systems
diff --git a/extra/tools/deploy/unix/tags.txt b/extra/tools/deploy/unix/tags.txt
new file mode 100644
index 0000000000..ef1aab0d0e
--- /dev/null
+++ b/extra/tools/deploy/unix/tags.txt
@@ -0,0 +1 @@
+tools
diff --git a/extra/tools/deploy/unix/unix.factor b/extra/tools/deploy/unix/unix.factor
new file mode 100644
index 0000000000..6f5a0304a2
--- /dev/null
+++ b/extra/tools/deploy/unix/unix.factor
@@ -0,0 +1,23 @@
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.files io.backend kernel namespaces sequences
+system tools.deploy.backend tools.deploy.config assocs
+hashtables prettyprint ;
+IN: tools.deploy.unix
+
+: create-app-dir ( vocab bundle-name -- vm )
+ dup "" copy-fonts
+ "" copy-vm ;
+
+: bundle-name ( -- str )
+ deploy-name get ;
+
+M: unix deploy* ( vocab -- )
+ "." resource-path [
+ dup deploy-config [
+ [ bundle-name create-app-dir ] keep
+ [ bundle-name image-name ] keep
+ namespace make-deploy-image
+ bundle-name normalize-path [ "Binary deployed to " % % "." % ] "" make print
+ ] bind
+ ] with-directory ;
\ No newline at end of file
diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor
index 68b106663c..5af3062e39 100755
--- a/extra/tools/deploy/windows/windows.factor
+++ b/extra/tools/deploy/windows/windows.factor
@@ -5,25 +5,14 @@ tools.deploy.backend tools.deploy.config assocs hashtables
prettyprint windows.shell32 windows.user32 ;
IN: tools.deploy.windows
-: copy-vm ( executable bundle-name -- vm )
- prepend-path ".exe" append
- vm over copy-file ;
-
-: copy-fonts ( bundle-name -- )
- "fonts/" resource-path swap copy-tree-into ;
-
: copy-dlls ( bundle-name -- )
- { "freetype6.dll" "zlib1.dll" "factor.dll" }
- [ resource-path ] map
+ { "resource:freetype6.dll" "resource:zlib1.dll" "resource:factor.dll" }
swap copy-files-into ;
: create-exe-dir ( vocab bundle-name -- vm )
dup copy-dlls
- dup copy-fonts
- copy-vm ;
-
-: image-name ( vocab bundle-name -- str )
- prepend-path ".image" append ;
+ dup "" copy-fonts
+ ".exe" copy-vm ;
M: winnt deploy*
"." resource-path [
@@ -31,6 +20,6 @@ M: winnt deploy*
[ deploy-name get create-exe-dir ] keep
[ deploy-name get image-name ] keep
[ namespace make-deploy-image ] keep
- (normalize-path) open-in-explorer
+ open-in-explorer
] bind
] with-directory ;
diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor
index 8a5ab42767..6bf3c53768 100755
--- a/extra/tools/walker/walker.factor
+++ b/extra/tools/walker/walker.factor
@@ -138,7 +138,6 @@ SYMBOL: +stopped+
>n ndrop >c c>
continue continue-with
stop yield suspend sleep (spawn)
- suspend
} [
dup [ execute break ] curry
"step-into" set-word-prop
diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor
index ab0c301525..83890788e3 100755
--- a/extra/ui/cocoa/views/views.factor
+++ b/extra/ui/cocoa/views/views.factor
@@ -126,6 +126,13 @@ CLASS: {
{ +name+ "FactorView" }
{ +protocols+ { "NSTextInput" } }
}
+
+! Rendering
+! Rendering
+{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
+ [ 3drop window relayout-1 ]
+}
+
! Events
{ "acceptsFirstMouse:" "bool" { "id" "SEL" "id" }
[ 3drop 1 ]
diff --git a/extra/ui/commands/commands.factor b/extra/ui/commands/commands.factor
index 90eb6254cd..c7db687dc3 100755
--- a/extra/ui/commands/commands.factor
+++ b/extra/ui/commands/commands.factor
@@ -66,7 +66,7 @@ M: word command-description ( word -- str )
H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
: define-command ( word hash -- )
- default-flags swap assoc-union >r word-props r> update ;
+ [ word-props ] [ default-flags swap assoc-union ] bi* update ;
: command-quot ( target command -- quot )
dup 1quotation swap +nullary+ word-prop
diff --git a/extra/ui/gadgets/grids/grids.factor b/extra/ui/gadgets/grids/grids.factor
index 342c360c83..9951256249 100644
--- a/extra/ui/gadgets/grids/grids.factor
+++ b/extra/ui/gadgets/grids/grids.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces sequences words io
-io.streams.string math.vectors ui.gadgets ;
+io.streams.string math.vectors ui.gadgets columns ;
IN: ui.gadgets.grids
TUPLE: grid children gap fill? ;
diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/extra/ui/gadgets/scrollers/scrollers.factor
index 396a494ef3..ce2bf40db8 100755
--- a/extra/ui/gadgets/scrollers/scrollers.factor
+++ b/extra/ui/gadgets/scrollers/scrollers.factor
@@ -1,10 +1,9 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.gadgets
-ui.gadgets.viewports ui.gadgets.frames ui.gadgets.grids
-ui.gadgets.theme ui.gadgets.sliders ui.gestures kernel math
-namespaces sequences models combinators math.vectors
-classes.tuple ;
+USING: accessors arrays ui.gadgets ui.gadgets.viewports
+ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
+ui.gadgets.sliders ui.gestures kernel math namespaces sequences
+models combinators math.vectors classes.tuple ;
IN: ui.gadgets.scrollers
TUPLE: scroller viewport x y follows ;
@@ -133,3 +132,13 @@ M: scroller focusable-child*
M: scroller model-changed
nip f swap set-scroller-follows ;
+
+TUPLE: limited-scroller dim ;
+
+: <limited-scroller> ( gadget -- scroller )
+ <scroller>
+ limited-scroller new
+ [ set-gadget-delegate ] keep ;
+
+M: limited-scroller pref-dim*
+ dim>> ;
diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor
index 8ee64b58be..b63e7f9d2e 100755
--- a/extra/ui/gadgets/worlds/worlds.factor
+++ b/extra/ui/gadgets/worlds/worlds.factor
@@ -48,9 +48,6 @@ M: world request-focus-on ( child gadget -- )
M: world hashcode* drop world hashcode* ;
-M: world pref-dim*
- delegate pref-dim* [ >fixnum ] map { 1024 768 } vmin ;
-
M: world layout*
dup delegate layout*
dup world-glass [
diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor
index f68a70c2bd..ed0f38b743 100755
--- a/extra/ui/gestures/gestures.factor
+++ b/extra/ui/gestures/gestures.factor
@@ -3,7 +3,7 @@
USING: arrays assocs kernel math models namespaces
sequences words strings system hashtables math.parser
math.vectors classes.tuple classes ui.gadgets boxes
-calendar alarms symbols combinators sets ;
+calendar alarms symbols combinators sets columns ;
IN: ui.gestures
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor
index 6c2a5e317d..d96270075f 100755
--- a/extra/ui/tools/listener/listener.factor
+++ b/extra/ui/tools/listener/listener.factor
@@ -24,19 +24,10 @@ TUPLE: listener-gadget input output stack ;
: <listener-input> ( listener -- gadget )
listener-gadget-output <pane-stream> <interactor> ;
-TUPLE: input-scroller ;
-
-: <input-scroller> ( interactor -- scroller )
- <scroller>
- input-scroller new
- [ set-gadget-delegate ] keep ;
-
-M: input-scroller pref-dim*
- drop { 0 100 } ;
-
: listener-input, ( -- )
g <listener-input> g-> set-listener-gadget-input
- <input-scroller> "Input" <labelled-gadget> f track, ;
+ <limited-scroller> { 0 100 } >>dim
+ "Input" <labelled-gadget> f track, ;
: welcome. ( -- )
"If this is your first time with Factor, please read the " print
@@ -111,7 +102,7 @@ M: method-body word-completion-string
USE: generic.standard.engines.tuple
-M: tuple-dispatch-engine-word word-completion-string
+M: engine-word word-completion-string
"engine-generic" word-prop word-completion-string ;
: use-if-necessary ( word seq -- )
diff --git a/extra/ui/tools/walker/walker-docs.factor b/extra/ui/tools/walker/walker-docs.factor
index 54caf8be12..fb0ce0adf2 100755
--- a/extra/ui/tools/walker/walker-docs.factor
+++ b/extra/ui/tools/walker/walker-docs.factor
@@ -1,10 +1,41 @@
IN: ui.tools.walker
USING: help.markup help.syntax ui.commands ui.operations
-tools.walker ;
+ui.render tools.walker sequences ;
+
+ARTICLE: "ui-walker-step" "Stepping through code"
+"If the current position points to a word, the various stepping commands behave as follows:"
+{ $list
+ { { $link com-step } " executes the word and moves the current position one word further." }
+ { { $link com-into } " enters the word's definition, unless it is a primitive, in which case it behaves like " { $link com-step } "." }
+ { { $link com-out } " executes until the end of the current quotation." }
+}
+"If the current position points to a literal, the various stepping commands behave as follows:"
+{ $list
+ { { $link com-step } " pushes the literal on the data stack." }
+ { { $link com-into } " pushes the literal. If it is a quotation, a breakpoint is inserted at the beginning of the quotation, and if it is an array of quotations, a breakpoint is inserted at the beginning of each quotation element." }
+ { { $link com-out } " executes until the end of the current quotation." }
+}
+"The behavior of the " { $link com-into } " command is useful when debugging code using combinators. Instead of stepping into the definition of a combinator, which may be quite complex, you can set a breakpoint on the quotation and continue. For example, suppose the following quotation is being walked:"
+{ $code "{ 10 20 30 } [ 3 + . ] each" }
+"If the current position is on the quotation and " { $link com-into } " is invoked, the following quotation is pushed on the stack:"
+{ $code "[ break 3 + . ]" }
+"Invoking " { $link com-continue } " will continue execution until the breakpoint is hit, which in this case happens immediately. The stack can then be inspected to verify that the first element of the array, 10, was pushed. Invoking " { $link com-continue } " proceeds until the breakpoint is hit on the second iteration, at which time the top of the stack will contain the value 20. Invoking " { $link com-continue } " a third time will proceed on to the final iteration where 30 is at the top of the stack. Invoking " { $link com-continue } " again will end the walk of this code snippet, since no more iterations remain the quotation will never be called again and the breakpoint will not be hit."
+$nl
+"The " { $link com-back } " command travels backwards through time, and restore stacks. This does not undo side effects (modifying array entries, writing to files, formatting the hard drive, etc) and therefore can only be used reliably on referentially transparent code." ;
+
+ARTICLE: "breakpoints" "Setting breakpoints"
+"In addition to invoking the walker explicitly through the UI, it is possible to set breakpoints on words. See " { $link "tools.annotations" } "."
+$nl
+"Breakpoints can be inserted directly into code:"
+{ $subsection break }
+"Note that because the walker calls various core library and UI words while rendering its own user interface, setting a breakpoint on a word such as " { $link append } " or " { $link draw-gadget } " will hang the UI." ;
ARTICLE: "ui-walker" "UI walker"
"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "."
$nl
-"The walker can travel backwards through time, and restore stacks. This does not undo side effects and therefore can only be used reliably on referentially transparent code."
-{ $command-map walker-gadget "toolbar" }
-"Walkers are instances of " { $link walker-gadget } "." ;
+"Walkers are instances of " { $link walker-gadget } "."
+{ $subsection "ui-walker-step" }
+{ $subsection "breakpoints" }
+{ $command-map walker-gadget "toolbar" } ;
+
+ABOUT: "ui-walker"
diff --git a/extra/ui/tools/workspace/workspace.factor b/extra/ui/tools/workspace/workspace.factor
index d79fa92f54..5a334ab56b 100755
--- a/extra/ui/tools/workspace/workspace.factor
+++ b/extra/ui/tools/workspace/workspace.factor
@@ -5,7 +5,7 @@ sequences ui ui.backend ui.tools.debugger ui.gadgets
ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
-ui.commands ui.gestures assocs arrays namespaces ;
+ui.commands ui.gestures assocs arrays namespaces accessors ;
IN: ui.tools.workspace
TUPLE: workspace book listener popup ;
@@ -49,7 +49,10 @@ M: gadget tool-scroller drop f ;
get-workspace find-tool nip ;
: help-window ( topic -- )
- [ <pane> [ [ help ] with-pane ] keep <scroller> ] keep
+ [
+ <pane> [ [ help ] with-pane ] keep
+ <limited-scroller> { 550 700 } >>dim
+ ] keep
article-title open-window ;
: hide-popup ( workspace -- )
diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor
index 6229fc9a65..e3e1fc5124 100755
--- a/extra/ui/windows/windows.factor
+++ b/extra/ui/windows/windows.factor
@@ -1,13 +1,14 @@
! Copyright (C) 2005, 2006 Doug Coleman.
+! Portions copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays assocs ui ui.gadgets
-ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel
-math math.vectors namespaces prettyprint sequences strings
-vectors words windows.kernel32 windows.gdi32 windows.user32
-windows.opengl32 windows.messages windows.types windows.nt
-windows threads libc combinators continuations command-line
-shuffle opengl ui.render unicode.case ascii math.bitfields
-locals symbols accessors ;
+USING: alien alien.c-types alien.strings arrays assocs ui
+ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
+ui.gestures io kernel math math.vectors namespaces prettyprint
+sequences strings vectors words windows.kernel32 windows.gdi32
+windows.user32 windows.opengl32 windows.messages windows.types
+windows.nt windows threads libc combinators continuations
+command-line shuffle opengl ui.render unicode.case ascii
+math.bitfields locals symbols accessors ;
IN: ui.windows
SINGLETON: windows-ui-backend
@@ -36,14 +37,14 @@ SINGLETON: windows-ui-backend
CF_UNICODETEXT GetClipboardData dup win32-error=0/f
dup GlobalLock dup win32-error=0/f
GlobalUnlock win32-error=0/f
- alien>u16-string
+ utf16n alien>string
] if
] with-clipboard
crlf>lf ;
: copy ( str -- )
lf>crlf [
- string>u16-alien
+ utf16n string>alien
EmptyClipboard win32-error=0/f
GMEM_MOVEABLE over length 1+ GlobalAlloc
dup win32-error=0/f
@@ -409,7 +410,7 @@ SYMBOL: trace-messages?
0 over set-WNDCLASSEX-cbClsExtra
0 over set-WNDCLASSEX-cbWndExtra
f GetModuleHandle over set-WNDCLASSEX-hInstance
- f GetModuleHandle "fraptor" string>u16-alien LoadIcon
+ f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
over set-WNDCLASSEX-hIcon
f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
@@ -447,7 +448,7 @@ SYMBOL: trace-messages?
: init-win32-ui ( -- )
V{ } clone nc-buttons set-global
"MSG" malloc-object msg-obj set-global
- "Factor-window" malloc-u16-string class-name-ptr set-global
+ "Factor-window" utf16n malloc-string class-name-ptr set-global
register-wndclassex drop
GetDoubleClickTime double-click-timeout set-global ;
@@ -492,7 +493,7 @@ M: windows-ui-backend raise-window* ( world -- )
M: windows-ui-backend set-title ( string world -- )
world-handle
dup win-title [ free ] when*
- >r malloc-u16-string r>
+ >r utf16n malloc-string r>
2dup set-win-title
win-hWnd WM_SETTEXT 0 roll alien-address SendMessage drop ;
diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor
index c044271853..606a45eba5 100755
--- a/extra/ui/x11/x11.factor
+++ b/extra/ui/x11/x11.factor
@@ -1,11 +1,12 @@
! Copyright (C) 2005, 2007 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays ui ui.gadgets ui.gestures
-ui.backend ui.clipboards ui.gadgets.worlds assocs kernel math
-namespaces opengl sequences strings x11.xlib x11.events x11.xim
-x11.glx x11.clipboard x11.constants x11.windows io.encodings.string
+ui.backend ui.clipboards ui.gadgets.worlds ui.render assocs
+kernel math namespaces opengl sequences strings x11.xlib
+x11.events x11.xim x11.glx x11.clipboard x11.constants
+x11.windows io.encodings.string io.encodings.ascii
io.encodings.utf8 combinators debugger command-line qualified
-ui.render math.vectors classes.tuple opengl.gl threads ;
+math.vectors classes.tuple opengl.gl threads ;
QUALIFIED: system
IN: ui.x11
@@ -137,8 +138,8 @@ M: world selection-notify-event
} cond ;
: encode-clipboard ( string type -- bytes )
- XSelectionRequestEvent-target XA_UTF8_STRING =
- [ utf8 encode ] [ string>char-alien ] if ;
+ XSelectionRequestEvent-target
+ XA_UTF8_STRING = utf8 ascii ? encode ;
: set-selection-prop ( evt -- )
dpy get swap
diff --git a/extra/unix/linux/ifreq/ifreq.factor b/extra/unix/linux/ifreq/ifreq.factor
index 31adc5c237..d688153bd0 100755
--- a/extra/unix/linux/ifreq/ifreq.factor
+++ b/extra/unix/linux/ifreq/ifreq.factor
@@ -10,7 +10,7 @@ IN: unix.linux.ifreq
: set-if-addr ( name addr -- )
"struct-ifreq" <c-object>
- rot string>char-alien over set-struct-ifreq-ifr-ifrn
+ rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFADDR rot ioctl drop ;
@@ -19,7 +19,7 @@ IN: unix.linux.ifreq
: set-if-flags ( name flags -- )
"struct-ifreq" <c-object>
- rot string>char-alien over set-struct-ifreq-ifr-ifrn
+ rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap <short> over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFFLAGS rot ioctl drop ;
@@ -28,7 +28,7 @@ IN: unix.linux.ifreq
: set-if-dst-addr ( name addr -- )
"struct-ifreq" <c-object>
- rot string>char-alien over set-struct-ifreq-ifr-ifrn
+ rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFDSTADDR rot ioctl drop ;
@@ -37,7 +37,7 @@ IN: unix.linux.ifreq
: set-if-brd-addr ( name addr -- )
"struct-ifreq" <c-object>
- rot string>char-alien over set-struct-ifreq-ifr-ifrn
+ rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFBRDADDR rot ioctl drop ;
@@ -46,7 +46,7 @@ IN: unix.linux.ifreq
: set-if-netmask ( name addr -- )
"struct-ifreq" <c-object>
- rot string>char-alien over set-struct-ifreq-ifr-ifrn
+ rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFNETMASK rot ioctl drop ;
@@ -55,7 +55,7 @@ IN: unix.linux.ifreq
: set-if-metric ( name metric -- )
"struct-ifreq" <c-object>
- rot string>char-alien over set-struct-ifreq-ifr-ifrn
+ rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap <int> over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFMETRIC rot ioctl drop ;
\ No newline at end of file
diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor
index ba02f15c7a..0abefe14f1 100755
--- a/extra/unix/process/process.factor
+++ b/extra/unix/process/process.factor
@@ -1,7 +1,6 @@
-USING: kernel alien.c-types sequences math unix
-vectors kernel namespaces continuations
-threads assocs vectors io.unix.backend ;
-
+USING: kernel alien.c-types alien.strings sequences math unix
+vectors kernel namespaces continuations threads assocs vectors
+io.unix.backend io.encodings.utf8 ;
IN: unix.process
! Low-level Unix process launching utilities. These are used
@@ -9,16 +8,16 @@ IN: unix.process
! io.launcher instead.
: >argv ( seq -- alien )
- [ malloc-char-string ] map f suffix >c-void*-array ;
+ [ utf8 malloc-string ] map f suffix >c-void*-array ;
: exec ( pathname argv -- int )
- [ malloc-char-string ] [ >argv ] bi* execv ;
+ [ utf8 malloc-string ] [ >argv ] bi* execv ;
: exec-with-path ( filename argv -- int )
- [ malloc-char-string ] [ >argv ] bi* execvp ;
+ [ utf8 malloc-string ] [ >argv ] bi* execvp ;
: exec-with-env ( filename argv envp -- int )
- [ malloc-char-string ] [ >argv ] [ >argv ] tri* execve ;
+ [ utf8 malloc-string ] [ >argv ] [ >argv ] tri* execve ;
: exec-args ( seq -- int )
[ first ] [ ] bi exec ;
diff --git a/extra/update/update.factor b/extra/update/update.factor
new file mode 100644
index 0000000000..9b10ea746f
--- /dev/null
+++ b/extra/update/update.factor
@@ -0,0 +1,63 @@
+
+USING: kernel system sequences io.files io.launcher bootstrap.image
+ http.client
+ builder.util builder.release.branch ;
+
+IN: update
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-command ( cmd -- ) to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-pull-clean ( -- )
+ image parent-directory
+ [
+ { "git" "pull" "git://factorcode.org/git/factor.git" branch-name }
+ run-command
+ ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remote-clean-image ( -- url )
+ "http://factorcode.org/images/clean/" my-boot-image-name append ;
+
+: download-clean-image ( -- ) remote-clean-image download ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-clean ( -- ) { gnu-make "clean" } run-command ;
+: make ( -- ) { gnu-make } run-command ;
+: boot ( -- ) { "./factor" { "-i=" my-boot-image-name } } run-command ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rebuild ( -- )
+ image parent-directory
+ [
+ download-clean-image
+ make-clean
+ make
+ boot
+ ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: update ( -- )
+ image parent-directory
+ [
+ git-id
+ git-pull-clean
+ git-id
+ = not
+ [ rebuild ]
+ when
+ ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: update
\ No newline at end of file
diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor
new file mode 100644
index 0000000000..3483d4321e
--- /dev/null
+++ b/extra/webapps/factor-website/factor-website.factor
@@ -0,0 +1,38 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences io.files io.sockets
+db.sqlite smtp namespaces db
+http.server.db
+http.server.sessions
+http.server.auth.login
+http.server.auth.providers.db
+http.server.sessions.storage.db
+http.server.boilerplate
+http.server.templating.chloe ;
+IN: webapps.factor-website
+
+: factor-template ( path -- template )
+ "resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
+
+: test-db "todo.db" resource-path sqlite-db ;
+
+: <factor-boilerplate> ( responder -- responder' )
+ <login>
+ users-in-db >>users
+ allow-registration
+ allow-password-recovery
+ allow-edit-profile
+ <boilerplate>
+ "page" factor-template >>template
+ <url-sessions>
+ sessions-in-db >>sessions
+ test-db <db-persistence> ;
+
+: init-factor-website ( -- )
+ "factorcode.org" 25 <inet> smtp-server set-global
+ "todo@factorcode.org" lost-password-from set-global
+
+ test-db [
+ init-sessions-table
+ init-users-table
+ ] with-db ;
diff --git a/extra/webapps/factor-website/page.xml b/extra/webapps/factor-website/page.xml
new file mode 100644
index 0000000000..d929042320
--- /dev/null
+++ b/extra/webapps/factor-website/page.xml
@@ -0,0 +1,61 @@
+<?xml version='1.0' ?>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+
+ <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <head>
+ <t:write-title />
+
+ <t:style>
+ body, button {
+ font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+ color:#444;
+ }
+
+ .link-button {
+ padding: 0px;
+ background: none;
+ border: none;
+ }
+
+ a, .link {
+ color: #222;
+ border-bottom:1px dotted #666;
+ text-decoration:none;
+ }
+
+ a:hover, .link:hover {
+ border-bottom:1px solid #66a;
+ }
+
+ .error { color: #a00; }
+
+ .field-label {
+ text-align: right;
+ }
+
+ .inline {
+ display: inline;
+ }
+
+ .navbar {
+ background-color: #eee;
+ padding: 5px;
+ border: 1px solid #ccc;
+ }
+ </t:style>
+
+ <t:write-style />
+ </head>
+
+ <body>
+ <t:call-next-template />
+ </body>
+
+ </t:chloe>
+
+</html>
diff --git a/extra/webapps/planet/admin.xml b/extra/webapps/planet/admin.xml
new file mode 100644
index 0000000000..1a18cad94b
--- /dev/null
+++ b/extra/webapps/planet/admin.xml
@@ -0,0 +1,13 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Planet Factor Administration</t:title>
+
+ <t:summary component="blogroll" />
+
+ <p>
+ <t:a href="edit-blog">Add Blog</t:a> | <t:a href="update">Update</t:a>
+ </p>
+
+</t:chloe>
diff --git a/extra/webapps/planet/authors.txt b/extra/webapps/planet/authors.txt
new file mode 100755
index 0000000000..1901f27a24
--- /dev/null
+++ b/extra/webapps/planet/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/extra/webapps/planet/blog-admin-link.xml b/extra/webapps/planet/blog-admin-link.xml
new file mode 100644
index 0000000000..712db4ba0d
--- /dev/null
+++ b/extra/webapps/planet/blog-admin-link.xml
@@ -0,0 +1,7 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:a href="view-blog" query="id"><t:view component="name" /></t:a>
+
+</t:chloe>
diff --git a/extra/webapps/planet/edit-blog.xml b/extra/webapps/planet/edit-blog.xml
new file mode 100644
index 0000000000..890b23dcce
--- /dev/null
+++ b/extra/webapps/planet/edit-blog.xml
@@ -0,0 +1,40 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit Blog</t:title>
+
+ <t:form action="edit-blog">
+
+ <t:edit component="id" />
+
+ <table>
+
+ <tr>
+ <th class="field-label">Blog name:</th>
+ <td><t:edit component="name" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Home page:</th>
+ <td><t:edit component="www-url" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Atom feed:</th>
+ <td><t:edit component="atom-url" /></td>
+ </tr>
+
+ </table>
+
+ <input type="SUBMIT" value="Done" />
+
+ </t:form>
+
+ <t:a href="view" query="id">View</t:a>
+ |
+ <t:form action="delete-blog" class="inline">
+ <t:edit component="id" />
+ <button type="submit" class="link-button link">Delete</button>
+ </t:form>
+</t:chloe>
diff --git a/extra/webapps/planet/entry-summary.xml b/extra/webapps/planet/entry-summary.xml
new file mode 100644
index 0000000000..a87703252c
--- /dev/null
+++ b/extra/webapps/planet/entry-summary.xml
@@ -0,0 +1,10 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <p class="news">
+ <strong><t:view component="title" /></strong> <br/>
+ <t:a value="link" class="more">Read More...</t:a>
+ </p>
+
+</t:chloe>
diff --git a/extra/webapps/planet/entry.xml b/extra/webapps/planet/entry.xml
new file mode 100644
index 0000000000..bc89af3263
--- /dev/null
+++ b/extra/webapps/planet/entry.xml
@@ -0,0 +1,17 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <h2 class="posting-title">
+ <t:a value="link"><t:view component="title" /></t:a>
+ </h2>
+
+ <p class="posting-body">
+ <t:view component="description" />
+ </p>
+
+ <p class="posting-date">
+ <t:a value="link"><t:view component="pub-date" /></t:a>
+ </p>
+
+</t:chloe>
diff --git a/extra/webapps/planet/planet.css b/extra/webapps/planet/planet.css
new file mode 100644
index 0000000000..ea7b7d896c
--- /dev/null
+++ b/extra/webapps/planet/planet.css
@@ -0,0 +1,30 @@
+h1.planet-title {
+ font-size:300%;
+}
+
+.posting-title {
+ background-color:#f5f5f5;
+}
+
+pre, code {
+ color:#000000;
+ font-size:120%;
+}
+
+.infobox {
+ border-left: 1px solid #C1DAD7;
+}
+
+.posting-date {
+ text-align: right;
+ font-size:90%;
+}
+
+a.more {
+ display:block;
+ padding:0 0 5px 0;
+ color:#333;
+ text-decoration:none;
+ text-align:right;
+ border:none;
+}
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
new file mode 100755
index 0000000000..464e2bbfb3
--- /dev/null
+++ b/extra/webapps/planet/planet.factor
@@ -0,0 +1,188 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences sorting locals math
+calendar alarms logging concurrency.combinators namespaces
+db.types db.tuples db
+rss xml.writer
+http.server
+http.server.crud
+http.server.forms
+http.server.actions
+http.server.boilerplate
+http.server.templating.chloe
+http.server.components
+http.server.auth.login
+webapps.factor-website ;
+IN: webapps.planet
+
+TUPLE: planet-factor < dispatcher postings ;
+
+: planet-template ( name -- template )
+ "resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
+
+TUPLE: blog id name www-url atom-url ;
+
+M: blog link-title name>> ;
+
+M: blog link-href www-url>> ;
+
+blog "BLOGS"
+{
+ { "id" "ID" INTEGER +native-id+ }
+ { "name" "NAME" { VARCHAR 256 } +not-null+ }
+ { "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
+ { "atom-url" "ATOMURL" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+: init-blog-table blog ensure-table ;
+
+: <blog> ( id -- todo )
+ blog new
+ swap >>id ;
+
+: blogroll ( -- seq )
+ f <blog> select-tuples [ [ name>> ] compare ] sort ;
+
+: <entry-form> ( -- form )
+ "entry" <form>
+ "entry" planet-template >>view-template
+ "entry-summary" planet-template >>summary-template
+ "title" <string> add-field
+ "description" <html-text> add-field
+ "pub-date" <date> add-field ;
+
+: <blog-form> ( -- form )
+ "blog" <form>
+ "edit-blog" planet-template >>edit-template
+ "view-blog" planet-template >>view-template
+ "blog-admin-link" planet-template >>summary-template
+ "id" <integer>
+ hidden >>renderer
+ add-field
+ "name" <string>
+ t >>required
+ add-field
+ "www-url" <url>
+ t >>required
+ add-field
+ "atom-url" <url>
+ t >>required
+ add-field ;
+
+: <planet-factor-form> ( -- form )
+ "planet-factor" <form>
+ "postings" planet-template >>view-template
+ "postings-summary" planet-template >>summary-template
+ "postings" <entry-form> +plain+ <list> add-field
+ "blogroll" "blog" <link> +unordered+ <list> add-field ;
+
+: <admin-form> ( -- form )
+ "admin" <form>
+ "admin" planet-template >>view-template
+ "blogroll" <blog-form> +unordered+ <list> add-field ;
+
+:: <edit-blogroll-action> ( planet -- action )
+ [let | form [ <admin-form> ] |
+ <action>
+ [
+ blank-values
+
+ blogroll "blogroll" set-value
+
+ form view-form
+ ] >>display
+ ] ;
+
+:: <planet-action> ( planet -- action )
+ [let | form [ <planet-factor-form> ] |
+ <action>
+ [
+ blank-values
+
+ planet postings>> "postings" set-value
+ blogroll "blogroll" set-value
+
+ form view-form
+ ] >>display
+ ] ;
+
+: safe-head ( seq n -- seq' )
+ over length min head ;
+
+:: planet-feed ( planet -- feed )
+ feed new
+ "[ planet-factor ]" >>title
+ "http://planet.factorcode.org" >>link
+ planet postings>> 16 safe-head >>entries ;
+
+:: <feed-action> ( planet -- action )
+ <action>
+ [
+ "text/xml" <content>
+ [ planet planet-feed feed>xml write-xml ] >>body
+ ] >>display ;
+
+: <posting> ( name entry -- entry' )
+ clone [ ": " swap 3append ] change-title ;
+
+: fetch-feed ( url -- feed )
+ download-feed entries>> ;
+
+\ fetch-feed DEBUG add-error-logging
+
+: fetch-blogroll ( blogroll -- entries )
+ dup
+ [ atom-url>> fetch-feed ] parallel-map
+ [ >r name>> r> [ <posting> ] with map ] 2map concat ;
+
+: sort-entries ( entries -- entries' )
+ [ [ pub-date>> ] compare ] sort <reversed> ;
+
+: update-cached-postings ( planet -- )
+ "webapps.planet" [
+ blogroll fetch-blogroll sort-entries 8 safe-head
+ >>postings drop
+ ] with-logging ;
+
+:: <update-action> ( planet -- action )
+ <action>
+ [
+ planet update-cached-postings
+ "" f <temporary-redirect>
+ ] >>display ;
+
+:: <planet-factor-admin> ( planet-factor -- responder )
+ [let | blog-form [ <blog-form> ]
+ blog-ctor [ [ <blog> ] ] |
+ <dispatcher>
+ planet-factor <edit-blogroll-action> >>default
+
+ ! Administrative CRUD
+ blog-ctor "" <delete-action> "delete-blog" add-responder
+ blog-form blog-ctor <view-action> "view-blog" add-responder
+ blog-form blog-ctor "view-blog" <edit-action> "edit-blog" add-responder
+ ] ;
+
+: <planet-factor> ( -- responder )
+ planet-factor new-dispatcher
+ dup <planet-action> >>default
+ dup <feed-action> "feed.xml" add-responder
+ dup <update-action> "update" add-responder
+ dup <planet-factor-admin> <protected> "admin" add-responder
+ <boilerplate>
+ "planet" planet-template >>template ;
+
+: <planet-app> ( -- responder )
+ <planet-factor> <factor-boilerplate> ;
+
+: start-update-task ( planet -- )
+ [ update-cached-postings ] curry 10 minutes every drop ;
+
+: init-planet ( -- )
+ test-db [
+ init-blog-table
+ ] with-db
+
+ <dispatcher>
+ <planet-app> "planet" add-responder
+ main-responder set-global ;
diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml
new file mode 100644
index 0000000000..772f81906d
--- /dev/null
+++ b/extra/webapps/planet/planet.xml
@@ -0,0 +1,31 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<t:comment>
+ <t:atom title="Planet Factor - Atom" href="feed.xml" />
+</t:comment>
+ <t:style include="resource:extra/webapps/planet/planet.css" />
+
+ <div class="navbar">
+ <t:a href="list">Front Page</t:a>
+ | <t:a href="feed.xml">Atom Feed</t:a>
+
+ | <t:a href="admin">Admin</t:a>
+
+ <t:comment>
+ <t:if code="http.server.auth.login:allow-edit-profile?">
+ | <t:a href="edit-profile">Edit Profile</t:a>
+ </t:if>
+
+ <t:form action="logout" class="inline">
+ | <button type="submit" class="link-button link">Logout</button>
+ </t:form>
+ </t:comment>
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
diff --git a/extra/webapps/planet/postings-summary.xml b/extra/webapps/planet/postings-summary.xml
new file mode 100644
index 0000000000..950191e4c3
--- /dev/null
+++ b/extra/webapps/planet/postings-summary.xml
@@ -0,0 +1,7 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:summary component="postings" />
+
+</t:chloe>
diff --git a/extra/webapps/planet/postings.xml b/extra/webapps/planet/postings.xml
new file mode 100644
index 0000000000..f59a4f61b8
--- /dev/null
+++ b/extra/webapps/planet/postings.xml
@@ -0,0 +1,19 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Planet Factor</t:title>
+
+ <table width="100%" cellpadding="10">
+ <tr>
+ <td> <t:view component="postings" /> </td>
+
+ <td valign="top" width="25%" class="infobox">
+ <h2>Blogroll</h2>
+
+ <t:summary component="blogroll" />
+ </td>
+ </tr>
+ </table>
+
+</t:chloe>
diff --git a/extra/webapps/planet/view-blog.xml b/extra/webapps/planet/view-blog.xml
new file mode 100644
index 0000000000..fbc03aff25
--- /dev/null
+++ b/extra/webapps/planet/view-blog.xml
@@ -0,0 +1,41 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>View Blog</t:title>
+
+ <table>
+
+ <tr>
+ <th class="field-label">Blog name:</th>
+ <td><t:view component="name" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Home page:</th>
+ <td>
+ <t:a value="www-url">
+ <t:view component="www-url" />
+ </t:a>
+ </td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Atom feed:</th>
+ <td>
+ <t:a value="atom-url">
+ <t:view component="atom-url" />
+ </t:a>
+ </td>
+ </tr>
+
+ </table>
+
+ <t:a href="edit-blog" query="id">Edit</t:a>
+ |
+ <t:form action="delete-blog" class="inline">
+ <t:edit component="id" />
+ <button type="submit" class="link-button link">Delete</button>
+ </t:form>
+
+</t:chloe>
diff --git a/extra/webapps/todo/edit-todo.xml b/extra/webapps/todo/edit-todo.xml
new file mode 100644
index 0000000000..71d6900f1a
--- /dev/null
+++ b/extra/webapps/todo/edit-todo.xml
@@ -0,0 +1,26 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit Item</t:title>
+
+ <t:form action="edit">
+ <t:edit component="id" />
+
+ <table>
+ <tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
+ <tr><th class="field-label">Priority: </th><td><t:edit component="priority" /></td></tr>
+ <tr><th class="field-label big-field-label">Description:</th><td><t:edit component="description" /></td></tr>
+ </table>
+
+ <input type="SUBMIT" value="Done" />
+ </t:form>
+
+ <t:a href="view" query="id">View</t:a>
+ |
+ <t:form action="delete" class="inline">
+ <t:edit component="id" />
+ <button type="submit" class="link-button link">Delete</button>
+ </t:form>
+
+</t:chloe>
diff --git a/extra/webapps/todo/todo-list.xml b/extra/webapps/todo/todo-list.xml
new file mode 100644
index 0000000000..1887fccdc1
--- /dev/null
+++ b/extra/webapps/todo/todo-list.xml
@@ -0,0 +1,12 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>My Todo List</t:title>
+
+ <table class="todo-list">
+ <tr><th>Summary</th><th>Priority</th><th>View</th><th>Edit</th></tr>
+ <t:summary component="list" />
+ </table>
+
+</t:chloe>
diff --git a/extra/webapps/todo/todo-summary.xml b/extra/webapps/todo/todo-summary.xml
new file mode 100644
index 0000000000..9e03b7f135
--- /dev/null
+++ b/extra/webapps/todo/todo-summary.xml
@@ -0,0 +1,20 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <tr>
+ <td>
+ <t:view component="summary" />
+ </td>
+ <td>
+ <t:view component="priority" />
+ </td>
+ <td>
+ <t:a href="view" query="id">View</t:a>
+ </td>
+ <td>
+ <t:a href="edit" query="id">Edit</t:a>
+ </td>
+ </tr>
+
+</t:chloe>
diff --git a/extra/webapps/todo/todo.css b/extra/webapps/todo/todo.css
new file mode 100644
index 0000000000..2520a56128
--- /dev/null
+++ b/extra/webapps/todo/todo.css
@@ -0,0 +1,25 @@
+.big-field-label {
+ vertical-align: top;
+}
+
+.description {
+ border: 1px dashed #ccc;
+ background-color: #f5f5f5;
+ padding: 5px;
+ font-size: 150%;
+ color: #000000;
+}
+
+pre {
+ font-size: 75%;
+}
+
+.todo-list {
+ border-style: none;
+}
+
+.todo-list td, .todo-list th {
+ border-width: 1px;
+ padding: 2px;
+ border-style: solid;
+}
diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
new file mode 100755
index 0000000000..97af356dc5
--- /dev/null
+++ b/extra/webapps/todo/todo.factor
@@ -0,0 +1,86 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel locals sequences namespaces
+db db.types db.tuples
+http.server.components http.server.components.farkup
+http.server.forms http.server.templating.chloe
+http.server.boilerplate http.server.crud http.server.auth
+http.server.actions http.server.db
+http.server.auth.login
+http.server
+webapps.factor-website ;
+IN: webapps.todo
+
+TUPLE: todo uid id priority summary description ;
+
+todo "TODO"
+{
+ { "uid" "UID" { VARCHAR 256 } +not-null+ }
+ { "id" "ID" +native-id+ }
+ { "priority" "PRIORITY" INTEGER +not-null+ }
+ { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
+ { "description" "DESCRIPTION" { VARCHAR 256 } }
+} define-persistent
+
+: init-todo-table todo ensure-table ;
+
+: <todo> ( id -- todo )
+ todo new
+ swap >>id
+ uid >>uid ;
+
+: todo-template ( name -- template )
+ "resource:extra/webapps/todo/" swap ".xml" 3append <chloe> ;
+
+: <todo-form> ( -- form )
+ "todo" <form>
+ "view-todo" todo-template >>view-template
+ "edit-todo" todo-template >>edit-template
+ "todo-summary" todo-template >>summary-template
+ "id" <integer>
+ hidden >>renderer
+ add-field
+ "summary" <string>
+ t >>required
+ add-field
+ "priority" <integer>
+ t >>required
+ 0 >>default
+ 0 >>min-value
+ 10 >>max-value
+ add-field
+ "description" <farkup>
+ add-field ;
+
+: <todo-list-form> ( -- form )
+ "todo-list" <form>
+ "todo-list" todo-template >>view-template
+ "list" <todo-form> +plain+ <list>
+ add-field ;
+
+TUPLE: todo-responder < dispatcher ;
+
+:: <todo-responder> ( -- responder )
+ [let | todo-form [ <todo-form> ]
+ list-form [ <todo-list-form> ]
+ ctor [ [ <todo> ] ] |
+ todo-responder new-dispatcher
+ list-form ctor <list-action> "list" add-main-responder
+ todo-form ctor <view-action> "view" add-responder
+ todo-form ctor "view" <edit-action> "edit" add-responder
+ ctor "list" <delete-action> "delete" add-responder
+ <boilerplate>
+ "todo" todo-template >>template
+ ] ;
+
+: <todo-app> ( -- responder )
+ <todo-responder> <protected> <factor-boilerplate> ;
+
+: init-todo ( -- )
+ test-db [
+ init-todo-table
+ ] with-db
+
+ <dispatcher>
+ <todo-app> "todo" add-responder
+ main-responder set-global ;
diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml
new file mode 100644
index 0000000000..81a5d3a425
--- /dev/null
+++ b/extra/webapps/todo/todo.xml
@@ -0,0 +1,26 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:style include="resource:extra/webapps/todo/todo.css" />
+
+ <t:style include="resource:extra/xmode/code2html/stylesheet.css" />
+
+ <div class="navbar">
+ <t:a href="list">List Items</t:a>
+ | <t:a href="edit">Add Item</t:a>
+
+ <t:if code="http.server.auth.login:allow-edit-profile?">
+ | <t:a href="edit-profile">Edit Profile</t:a>
+ </t:if>
+
+ <t:form action="logout" class="inline">
+ | <button type="submit" class="link-button link">Logout</button>
+ </t:form>
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
diff --git a/extra/webapps/todo/view-todo.xml b/extra/webapps/todo/view-todo.xml
new file mode 100644
index 0000000000..fea77c1189
--- /dev/null
+++ b/extra/webapps/todo/view-todo.xml
@@ -0,0 +1,23 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>View Item</t:title>
+
+ <table>
+ <tr><th class="field-label">Summary: </th><td><t:view component="summary" /></td></tr>
+ <tr><th class="field-label">Priority: </th><td><t:view component="priority" /></td></tr>
+ </table>
+
+ <div class="description">
+ <t:view component="description" />
+ </div>
+
+ <t:a href="edit" query="id">Edit</t:a>
+ |
+ <t:form action="delete" class="inline">
+ <t:edit component="id" />
+ <button class="link-button link">Delete</button>
+ </t:form>
+
+</t:chloe>
diff --git a/extra/windows/ole32/ole32.factor b/extra/windows/ole32/ole32.factor
index 44ea853af0..6e06830130 100644
--- a/extra/windows/ole32/ole32.factor
+++ b/extra/windows/ole32/ole32.factor
@@ -1,5 +1,5 @@
-USING: alien alien.syntax alien.c-types math kernel sequences
-windows windows.types combinators.lib ;
+USING: alien alien.syntax alien.c-types alien.strings math
+kernel sequences windows windows.types combinators.lib ;
IN: windows.ole32
LIBRARY: ole32
@@ -12,8 +12,8 @@ C-STRUCT: GUID
TYPEDEF: void* REFGUID
TYPEDEF: void* LPUNKNOWN
-TYPEDEF: ushort* LPOLESTR
-TYPEDEF: ushort* LPCOLESTR
+TYPEDEF: wchar_t* LPOLESTR
+TYPEDEF: wchar_t* LPCOLESTR
TYPEDEF: REFGUID REFIID
TYPEDEF: REFGUID REFCLSID
@@ -52,8 +52,8 @@ FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
"{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
: string>guid ( string -- guid )
- string>u16-alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;
+ utf16n string>alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;
: guid>string ( guid -- string )
GUID-STRING-LENGTH 1+ [ "ushort" <c-array> ] keep
- [ StringFromGUID2 drop ] { 2 } multikeep alien>u16-string ;
+ [ StringFromGUID2 drop ] { 2 } multikeep utf16n alien>string ;
diff --git a/extra/windows/shell32/shell32.factor b/extra/windows/shell32/shell32.factor
index d64fb68cb3..a9035eeeaf 100644
--- a/extra/windows/shell32/shell32.factor
+++ b/extra/windows/shell32/shell32.factor
@@ -1,6 +1,6 @@
-USING: alien alien.c-types alien.syntax combinators
+USING: alien alien.c-types alien.strings alien.syntax combinators
kernel windows windows.user32 windows.ole32
-windows.com windows.com.syntax ;
+windows.com windows.com.syntax io.files ;
IN: windows.shell32
: CSIDL_DESKTOP HEX: 00 ; inline
@@ -83,7 +83,7 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi
: ShellExecute ShellExecuteW ; inline
: open-in-explorer ( dir -- )
- f "open" rot f f SW_SHOWNORMAL ShellExecute drop ;
+ f "open" rot (normalize-path) f f SW_SHOWNORMAL ShellExecute drop ;
: shell32-error ( n -- )
ole32-error ; inline
@@ -91,7 +91,7 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi
: shell32-directory ( n -- str )
f swap f SHGFP_TYPE_DEFAULT
MAX_UNICODE_PATH "ushort" <c-array>
- [ SHGetFolderPath shell32-error ] keep alien>u16-string ;
+ [ SHGetFolderPath shell32-error ] keep utf16n alien>string ;
: desktop ( -- str )
CSIDL_DESKTOPDIRECTORY shell32-directory ;
diff --git a/extra/windows/types/types.factor b/extra/windows/types/types.factor
index 61b409e8e1..8b4b2d98d2 100644
--- a/extra/windows/types/types.factor
+++ b/extra/windows/types/types.factor
@@ -66,9 +66,8 @@ TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER
TYPEDEF: WCHAR TCHAR
TYPEDEF: TCHAR TBYTE
-! TYPEDEF: uchar* LPCSTR
-TYPEDEF: ushort* LPCSTR
-TYPEDEF: ushort* LPWSTR
+TYPEDEF: wchar_t* LPCSTR
+TYPEDEF: wchar_t* LPWSTR
@@ -126,10 +125,10 @@ TYPEDEF: WCHAR* LPCWSTR
! TYPEDEF: WCHAR* LPWSTR
TYPEDEF: WCHAR* LPSTR
-TYPEDEF: ushort* LPCTSTR
-TYPEDEF: ushort* LPWTSTR
+TYPEDEF: wchar_t* LPCTSTR
+TYPEDEF: wchar_t* LPWTSTR
-TYPEDEF: ushort* LPTSTR
+TYPEDEF: wchar_t* LPTSTR
TYPEDEF: LPCSTR PCTSTR
TYPEDEF: LPSTR PTSTR
diff --git a/extra/windows/windows.factor b/extra/windows/windows.factor
index 600c0a4039..3e7520d406 100644
--- a/extra/windows/windows.factor
+++ b/extra/windows/windows.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax alien.c-types arrays combinators
-kernel math namespaces parser prettyprint sequences
+USING: alien alien.syntax alien.c-types alien.strings arrays
+combinators kernel math namespaces parser prettyprint sequences
windows.errors windows.types windows.kernel32 words ;
IN: windows
@@ -14,7 +14,7 @@ FUNCTION: void* error_message ( DWORD id ) ;
: (win32-error-string) ( n -- string )
error_message
- dup alien>u16-string
+ dup utf16n alien>string
swap LocalFree drop ;
: win32-error-string ( -- str )
@@ -30,10 +30,10 @@ FUNCTION: void* error_message ( DWORD id ) ;
: win32-error ( -- )
GetLastError (win32-error) ;
-: win32-error=0/f { 0 f } member? [ win32-error ] when ;
-: win32-error>0 0 > [ win32-error ] when ;
-: win32-error<0 0 < [ win32-error ] when ;
-: win32-error<>0 zero? [ win32-error ] unless ;
+: win32-error=0/f ( n -- ) { 0 f } member? [ win32-error ] when ;
+: win32-error>0 ( n -- ) 0 > [ win32-error ] when ;
+: win32-error<0 ( n -- ) 0 < [ win32-error ] when ;
+: win32-error<>0 ( n -- ) zero? [ win32-error ] unless ;
: invalid-handle? ( handle -- )
INVALID_HANDLE_VALUE = [
diff --git a/extra/windows/winsock/winsock.factor b/extra/windows/winsock/winsock.factor
index cc19cdc2a3..39d11b562b 100644
--- a/extra/windows/winsock/winsock.factor
+++ b/extra/windows/winsock/winsock.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2006 Mackenzie Straight, Doug Coleman.
-USING: alien alien.c-types alien.syntax arrays byte-arrays
-kernel math sequences windows.types windows.kernel32
+USING: alien alien.c-types alien.strings alien.syntax arrays
+byte-arrays kernel math sequences windows.types windows.kernel32
windows.errors structs windows math.bitfields ;
IN: windows.winsock
@@ -397,7 +397,7 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi
: (winsock-error-string) ( n -- str )
! #! WSAStartup returns the error code 'n' directly
dup winsock-expected-error?
- [ drop f ] [ error_message alien>u16-string ] if ;
+ [ drop f ] [ error_message utf16n alien>string ] if ;
: winsock-error-string ( -- string/f )
WSAGetLastError (winsock-error-string) ;
diff --git a/extra/x/x.factor b/extra/x/x.factor
index 63d90f58db..aeb6af3ee6 100644
--- a/extra/x/x.factor
+++ b/extra/x/x.factor
@@ -1,7 +1,8 @@
-USING: kernel io alien alien.c-types namespaces threads
+USING: kernel io alien alien.c-types alien.strings namespaces threads
arrays sequences assocs math vars combinators.lib
- x11.constants x11.events x11.xlib mortar slot-accessors geom.rect ;
+ x11.constants x11.events x11.xlib mortar slot-accessors geom.rect
+ io.encodings.ascii ;
IN: x
@@ -29,7 +30,7 @@ define-independent-class
<display> "create" !( name <display> -- display ) [
new-empty swap >>name
- dup $name dup [ string>char-alien ] [ ] if XOpenDisplay
+ dup $name dup [ ascii string>alien ] [ ] if XOpenDisplay
dup [ >>ptr ] [ "XOpenDisplay error" throw ] if
dup $ptr XDefaultScreen >>default-screen
dup $ptr XDefaultRootWindow dupd <window> new >>default-root
@@ -433,7 +434,7 @@ add-method
<window> "fetch-name" !( window -- name-or-f )
[ <- raw f <void*> dup >r XFetchName drop r>
- dup *void* alien-address 0 = [ drop f ] [ *char* ] if ]
+ dup *void* [ drop f ] [ *void* ascii alien>string ] if ]
add-method
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
diff --git a/extra/x11/clipboard/clipboard.factor b/extra/x11/clipboard/clipboard.factor
index a63a3903a1..9e1e0ef920 100755
--- a/extra/x11/clipboard/clipboard.factor
+++ b/extra/x11/clipboard/clipboard.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.syntax arrays kernel math
-namespaces sequences io.encodings.string io.encodings.utf8 x11.xlib
-x11.constants ;
+USING: alien alien.c-types alien.strings alien.syntax arrays
+kernel math namespaces sequences io.encodings.string
+io.encodings.utf8 io.encodings.ascii x11.xlib x11.constants ;
IN: x11.clipboard
! This code was based on by McCLIM's Backends/CLX/port.lisp
@@ -25,7 +25,7 @@ TUPLE: x-clipboard atom contents ;
CurrentTime XConvertSelection drop ;
: snarf-property ( prop-return -- string )
- dup *void* [ *char* ] [ drop f ] if ;
+ dup *void* [ *void* ascii alien>string ] [ drop f ] if ;
: window-property ( win prop delete? -- string )
>r dpy get -rot 0 -1 r> AnyPropertyType
diff --git a/extra/x11/xlib/xlib.factor b/extra/x11/xlib/xlib.factor
index 752c6c442e..154bf4d6ff 100755
--- a/extra/x11/xlib/xlib.factor
+++ b/extra/x11/xlib/xlib.factor
@@ -11,8 +11,9 @@
! modify, just find the function or data structure in the manual
! and note the section.
-USING: kernel arrays alien alien.c-types alien.syntax
-math math.bitfields words sequences namespaces continuations ;
+USING: kernel arrays alien alien.c-types alien.strings
+alien.syntax math math.bitfields words sequences namespaces
+continuations io.encodings.ascii ;
IN: x11.xlib
LIBRARY: xlib
@@ -1372,7 +1373,7 @@ SYMBOL: root
: initialize-x ( display-string -- )
init-locale
- dup [ string>char-alien ] when
+ dup [ ascii string>alien ] when
XOpenDisplay check-display dpy set-global
dpy get XDefaultScreen scr set-global
dpy get scr get XRootWindow root set-global ;
diff --git a/extra/xml/writer/writer.factor b/extra/xml/writer/writer.factor
index 27880da07f..44c92006a0 100644
--- a/extra/xml/writer/writer.factor
+++ b/extra/xml/writer/writer.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math namespaces sequences strings
-io io.streams.string xml.data assocs wrap xml.entities
-unicode.categories ;
+assocs combinators io io.streams.string
+xml.data wrap xml.entities unicode.categories ;
IN: xml.writer
SYMBOL: xml-pprint?
@@ -61,6 +61,9 @@ M: string write-item
?indent CHAR: < write1
dup print-name tag-attrs print-attrs ;
+: write-start-tag ( tag -- )
+ write-tag ">" write ;
+
M: contained-tag write-item
write-tag "/>" write ;
@@ -72,11 +75,14 @@ M: contained-tag write-item
?indent "</" write print-name CHAR: > write1 ;
M: open-tag write-item
- xml-pprint? [ [
- over sensitive? not and xml-pprint? set
- dup write-tag CHAR: > write1
- dup write-children write-end-tag
- ] keep ] change ;
+ xml-pprint? get >r
+ {
+ [ sensitive? not xml-pprint? get and xml-pprint? set ]
+ [ write-start-tag ]
+ [ write-children ]
+ [ write-end-tag ]
+ } cleave
+ r> xml-pprint? set ;
M: comment write-item
"<!--" write comment-text write "-->" write ;
@@ -97,10 +103,12 @@ M: instruction write-item
[ write-item ] each ;
: write-xml ( xml -- )
- dup xml-prolog write-prolog
- dup xml-before write-chunk
- dup write-item
- xml-after write-chunk ;
+ {
+ [ xml-prolog write-prolog ]
+ [ xml-before write-chunk ]
+ [ write-item ]
+ [ xml-after write-chunk ]
+ } cleave ;
: print-xml ( xml -- )
write-xml nl ;
diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor
index 62f0f6ede3..22d3217ee6 100755
--- a/extra/xmode/catalog/catalog.factor
+++ b/extra/xmode/catalog/catalog.factor
@@ -36,9 +36,13 @@ TAGS>
f \ modes set-global ;
MEMO: (load-mode) ( name -- rule-sets )
- modes at mode-file
- "extra/xmode/modes/" prepend
- resource-path utf8 <file-reader> parse-mode ;
+ modes at [
+ mode-file
+ "extra/xmode/modes/" prepend
+ resource-path utf8 <file-reader> parse-mode
+ ] [
+ "text" (load-mode)
+ ] if* ;
SYMBOL: rule-sets
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 86552d6401..5aa47c8c6c 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -122,7 +122,7 @@ void clear_cards(CELL from, CELL to)
void set_data_heap(F_DATA_HEAP *data_heap_)
{
data_heap = data_heap_;
- nursery = &data_heap->generations[NURSERY];
+ nursery = data_heap->generations[NURSERY];
init_cards_offset();
clear_cards(NURSERY,TENURED);
}
@@ -231,7 +231,7 @@ DEFINE_PRIMITIVE(data_room)
for(gen = 0; gen < data_heap->gen_count; gen++)
{
- F_ZONE *z = &data_heap->generations[gen];
+ F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]);
set_array_nth(a,gen * 2,tag_fixnum((z->end - z->here) >> 10));
set_array_nth(a,gen * 2 + 1,tag_fixnum((z->size) >> 10));
}
@@ -583,7 +583,7 @@ CELL collect_next(CELL scan)
INLINE void reset_generation(CELL i)
{
- F_ZONE *z = &data_heap->generations[i];
+ F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
z->here = z->start;
if(secure_gc)
memset((void*)z->start,69,z->size);
@@ -608,7 +608,7 @@ void begin_gc(CELL requested_bytes)
old_data_heap = data_heap;
set_data_heap(grow_data_heap(old_data_heap,requested_bytes));
- newspace = &data_heap->generations[collecting_gen];
+ newspace = &data_heap->generations[TENURED];
}
else if(collecting_accumulation_gen_p())
{
@@ -783,6 +783,11 @@ void gc(void)
garbage_collection(TENURED,false,0);
}
+void minor_gc(void)
+{
+ garbage_collection(NURSERY,false,0);
+}
+
DEFINE_PRIMITIVE(gc)
{
gc();
@@ -794,12 +799,6 @@ DEFINE_PRIMITIVE(gc_time)
box_unsigned_8(gc_time);
}
-void simple_gc(void)
-{
- if(nursery->here + ALLOT_BUFFER_ZONE > nursery->end)
- garbage_collection(NURSERY,false,0);
-}
-
DEFINE_PRIMITIVE(become)
{
F_ARRAY *new_objects = untag_array(dpop());
diff --git a/vm/data_gc.h b/vm/data_gc.h
index 2490ed8805..be9ed159b7 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -20,6 +20,7 @@ DECLARE_PRIMITIVE(next_object);
DECLARE_PRIMITIVE(end_scan);
void gc(void);
+DLLEXPORT void minor_gc(void);
/* generational copying GC divides memory into zones */
typedef struct {
@@ -125,7 +126,7 @@ void collect_cards(void);
F_ZONE *newspace;
/* new objects are allocated here */
-DLLEXPORT F_ZONE *nursery;
+DLLEXPORT F_ZONE nursery;
INLINE bool in_zone(F_ZONE *z, CELL pointer)
{
@@ -200,7 +201,7 @@ INLINE bool should_copy(CELL untagged)
else if(HAVE_AGING_P && collecting_gen == AGING)
return !in_zone(&data_heap->generations[TENURED],untagged);
else if(HAVE_NURSERY_P && collecting_gen == NURSERY)
- return in_zone(&data_heap->generations[NURSERY],untagged);
+ return in_zone(&nursery,untagged);
else
{
critical_error("Bug in should_copy",untagged);
@@ -315,13 +316,15 @@ INLINE void* allot_object(CELL type, CELL a)
{
CELL *object;
- if(HAVE_NURSERY_P && nursery->size - ALLOT_BUFFER_ZONE > a)
+ if(HAVE_NURSERY_P && nursery.size - ALLOT_BUFFER_ZONE > a)
{
/* If there is insufficient room, collect the nursery */
- if(nursery->here + ALLOT_BUFFER_ZONE + a > nursery->end)
+ if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end)
garbage_collection(NURSERY,false,0);
- object = allot_zone(nursery,a);
+ CELL h = nursery.here;
+ nursery.here = h + align8(a);
+ object = (void*)h;
}
/* If the object is bigger than the nursery, allocate it in
tenured space */
@@ -360,8 +363,6 @@ INLINE void* allot_object(CELL type, CELL a)
CELL collect_next(CELL scan);
-DLLEXPORT void simple_gc(void);
-
DECLARE_PRIMITIVE(gc);
DECLARE_PRIMITIVE(gc_time);
DECLARE_PRIMITIVE(become);
diff --git a/vm/debug.c b/vm/debug.c
index 840d252769..b86ec808bc 100755
--- a/vm/debug.c
+++ b/vm/debug.c
@@ -227,7 +227,11 @@ void dump_zone(F_ZONE *z)
void dump_generations(void)
{
int i;
- for(i = 0; i < data_heap->gen_count; i++)
+
+ printf("Nursery: ");
+ dump_zone(&nursery);
+
+ for(i = 1; i < data_heap->gen_count; i++)
{
printf("Generation %d: ",i);
dump_zone(&data_heap->generations[i]);
diff --git a/vm/errors.c b/vm/errors.c
index 6d99d34766..57dc8b66a1 100755
--- a/vm/errors.c
+++ b/vm/errors.c
@@ -96,7 +96,7 @@ void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack)
general_error(ERROR_RS_UNDERFLOW,F,F,native_stack);
else if(in_page(addr, rs_bot, rs_size, 0))
general_error(ERROR_RS_OVERFLOW,F,F,native_stack);
- else if(in_page(addr, nursery->end, 0, 0))
+ else if(in_page(addr, nursery.end, 0, 0))
critical_error("allot_object() missed GC check",0);
else if(in_page(addr, gc_locals_region->start, 0, -1))
critical_error("gc locals underflow",0);
diff --git a/vm/ffi_test.c b/vm/ffi_test.c
index 9cec5ccbad..b2cbf9b6b5 100755
--- a/vm/ffi_test.c
+++ b/vm/ffi_test.c
@@ -250,3 +250,28 @@ double ffi_test_36(struct test_struct_12 x)
{
return x.x;
}
+
+static int global_var;
+
+void ffi_test_36_point_5(void)
+{
+ printf("int_ffi_test_36_point_5\n");
+ global_var = 0;
+}
+
+int ffi_test_37(int (*f)(int, int, int))
+{
+ printf("ffi_test_37\n");
+ printf("global_var is %d\n",global_var);
+ global_var = f(global_var,global_var * 2,global_var * 3);
+ printf("global_var is %d\n",global_var);
+ fflush(stdout);
+ return global_var;
+}
+
+unsigned long long ffi_test_38(unsigned long long x, unsigned long long y)
+{
+ return x * y;
+}
+
+
diff --git a/vm/ffi_test.h b/vm/ffi_test.h
index aac5d32f93..d455d999b1 100755
--- a/vm/ffi_test.h
+++ b/vm/ffi_test.h
@@ -61,3 +61,9 @@ DLLEXPORT double ffi_test_35(struct test_struct_11 x, int y);
struct test_struct_12 { int a; double x; };
DLLEXPORT double ffi_test_36(struct test_struct_12 x);
+
+DLLEXPORT void int_ffi_test_36_point_5(void);
+
+DLLEXPORT int ffi_test_37(int (*f)(int, int, int));
+
+DLLEXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long long y);
diff --git a/vm/os-macosx-ppc.h b/vm/os-macosx-ppc.h
index 640aeb796d..13213acbbc 100644
--- a/vm/os-macosx-ppc.h
+++ b/vm/os-macosx-ppc.h
@@ -8,6 +8,8 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
Modified for Factor by Slava Pestov */
+#include <ucontext.h>
+
#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 2)
#define MACH_EXC_STATE_TYPE ppc_exception_state_t
diff --git a/vm/os-macosx-x86.32.h b/vm/os-macosx-x86.32.h
index d5e5827a5c..7c830c775d 100644
--- a/vm/os-macosx-x86.32.h
+++ b/vm/os-macosx-x86.32.h
@@ -8,6 +8,8 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
Modified for Factor by Slava Pestov */
+#include <ucontext.h>
+
#define MACH_EXC_STATE_TYPE i386_exception_state_t
#define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE
#define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT
diff --git a/vm/os-macosx-x86.64.h b/vm/os-macosx-x86.64.h
index d2bb48c3fe..b11aa80ce8 100644
--- a/vm/os-macosx-x86.64.h
+++ b/vm/os-macosx-x86.64.h
@@ -8,6 +8,8 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
Modified for Factor by Slava Pestov and Daniel Ehrenberg */
+#include <ucontext.h>
+
#define MACH_EXC_STATE_TYPE x86_exception_state64_t
#define MACH_EXC_STATE_FLAVOR x86_EXCEPTION_STATE64
#define MACH_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT
diff --git a/vm/primitives.c b/vm/primitives.c
index 2906a154a2..da04870ecd 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -139,10 +139,6 @@ void *primitives[] = {
primitive_set_alien_double,
primitive_alien_cell,
primitive_set_alien_cell,
- primitive_alien_to_char_string,
- primitive_string_to_char_alien,
- primitive_alien_to_u16_string,
- primitive_string_to_u16_alien,
primitive_throw,
primitive_alien_address,
primitive_slot,
diff --git a/vm/types.c b/vm/types.c
index d9fd152c97..b4e5269f4e 100755
--- a/vm/types.c
+++ b/vm/types.c
@@ -608,10 +608,6 @@ DEFINE_PRIMITIVE(resize_string)
void box_##type##_string(const type *str) \
{ \
dpush(str ? tag_object(from_##type##_string(str)) : F); \
- } \
- DEFINE_PRIMITIVE(alien_to_##type##_string) \
- { \
- drepl(tag_object(from_##type##_string(alien_offset(dpeek())))); \
}
MEMORY_TO_STRING(char,u8)
@@ -671,14 +667,6 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
type *unbox_##type##_string(void) \
{ \
return to_##type##_string(untag_string(dpop()),true); \
- } \
- DEFINE_PRIMITIVE(string_to_##type##_alien) \
- { \
- CELL string, t; \
- string = dpeek(); \
- t = type_of(string); \
- if(t != ALIEN_TYPE && t != BYTE_ARRAY_TYPE && t != F_TYPE) \
- drepl(tag_object(string_to_##type##_alien(untag_string(string),true))); \
}
STRING_TO_MEMORY(char);
diff --git a/vm/types.h b/vm/types.h
index 03ac84d5a5..3ce1838b8b 100755
--- a/vm/types.h
+++ b/vm/types.h
@@ -160,24 +160,20 @@ DECLARE_PRIMITIVE(resize_string);
F_STRING *memory_to_char_string(const char *string, CELL length);
F_STRING *from_char_string(const char *c_string);
DLLEXPORT void box_char_string(const char *c_string);
-DECLARE_PRIMITIVE(alien_to_char_string);
F_STRING *memory_to_u16_string(const u16 *string, CELL length);
F_STRING *from_u16_string(const u16 *c_string);
DLLEXPORT void box_u16_string(const u16 *c_string);
-DECLARE_PRIMITIVE(alien_to_u16_string);
void char_string_to_memory(F_STRING *s, char *string);
F_BYTE_ARRAY *string_to_char_alien(F_STRING *s, bool check);
char* to_char_string(F_STRING *s, bool check);
DLLEXPORT char *unbox_char_string(void);
-DECLARE_PRIMITIVE(string_to_char_alien);
void u16_string_to_memory(F_STRING *s, u16 *string);
F_BYTE_ARRAY *string_to_u16_alien(F_STRING *s, bool check);
u16* to_u16_string(F_STRING *s, bool check);
DLLEXPORT u16 *unbox_u16_string(void);
-DECLARE_PRIMITIVE(string_to_u16_alien);
/* String getters and setters */
CELL string_nth(F_STRING* string, CELL index);