_darcs
*.obj
*.o
+*.s
*.exe
Factor/factor
*.a
}
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>"
}
: <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? [
{ $subsection >c-ushort-array }\r
{ $subsection >c-void*-array }\r
{ $subsection c-bool-array> }\r
-{ $subsection c-char*-array> }\r
{ $subsection c-char-array> }\r
{ $subsection c-double-array> }\r
{ $subsection c-float-array> }\r
{ $subsection c-uint-array> }\r
{ $subsection c-ulong-array> }\r
{ $subsection c-ulonglong-array> }\r
-{ $subsection c-ushort*-array> }\r
{ $subsection c-ushort-array> }\r
{ $subsection c-void*-array> } ;\r
\r
{ $subsection double-nth }\r
{ $subsection set-double-nth }\r
{ $subsection void*-nth }\r
-{ $subsection set-void*-nth }\r
-{ $subsection char*-nth }\r
-{ $subsection ushort*-nth } ;\r
+{ $subsection set-void*-nth } ;\r
\r
ARTICLE: "c-arrays" "C arrays"\r
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."\r
-! 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 ;
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> ] ;
{ <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." } ;
{ $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." }
{ $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"
"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
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* ;
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*>
! 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
: 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? ;
: 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 ;
"box_float" >>boxer
"to_float" >>unboxer
single-float-regs >>reg-class
- [ >float ] >>prep
+ [ >float ] >>unboxer-quot
"float" define-primitive-type
<c-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
namespaces namespaces tools.test sequences inference words\r
arrays parser quotations continuations inference.backend effects\r
namespaces.private io io.streams.string memory system threads\r
-tools.test ;\r
+tools.test math ;\r
\r
FUNCTION: void ffi_test_0 ;\r
[ ] [ ffi_test_0 ] unit-test\r
\r
[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test\r
\r
+FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;\r
+\r
+[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test\r
+\r
! Test callbacks\r
\r
: callback-1 "void" { } "cdecl" [ ] alien-callback ;\r
] alien-callback ;\r
\r
[ ] [ callback-8 callback_test_1 ] unit-test\r
+\r
+: callback-9\r
+ "int" { "int" "int" "int" } "cdecl" [\r
+ + + 1+\r
+ ] alien-callback ;\r
+\r
+FUNCTION: void ffi_test_36_point_5 ( ) ;\r
+\r
+[ ] [ ffi_test_36_point_5 ] unit-test\r
+\r
+FUNCTION: int ffi_test_37 ( void* func ) ;\r
+\r
+[ 1 ] [ callback-9 ffi_test_37 ] unit-test\r
+\r
+[ 7 ] [ callback-9 ffi_test_37 ] unit-test\r
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 ;
: 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>>
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>> [
: 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." ;
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
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
: callback-bottom ( node -- )
xt>> [ word-xt drop <alien> ] curry
- recursive-state get infer-quot ;
+ f infer-quot ;
\ alien-callback [
4 ensure-values
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 ;
: 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 ;
-! 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 ;
--- /dev/null
+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"
--- /dev/null
+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
--- /dev/null
+! 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
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" }
[ 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" } ;
-!
-! [ 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
+C-STRUCT: align-test
+ { "int" "x" }
+ { "double" "y" } ;
+
+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 ;
: 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 -- )
! 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
+++ /dev/null
-USING: arrays bit-arrays help.markup help.syntax kernel\r
-bit-vectors.private combinators ;\r
-IN: bit-vectors\r
-\r
-ARTICLE: "bit-vectors" "Bit vectors"\r
-"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."\r
-$nl\r
-"Bit vectors form a class:"\r
-{ $subsection bit-vector }\r
-{ $subsection bit-vector? }\r
-"Creating bit vectors:"\r
-{ $subsection >bit-vector }\r
-{ $subsection <bit-vector> }\r
-"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"\r
-{ $code "?V{ } clone" } ;\r
-\r
-ABOUT: "bit-vectors"\r
-\r
-HELP: bit-vector\r
-{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ;\r
-\r
-HELP: <bit-vector>\r
-{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }\r
-{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;\r
-\r
-HELP: >bit-vector\r
-{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } }\r
-{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;\r
-\r
-HELP: bit-array>vector\r
-{ $values { "bit-array" "an array" } { "length" "a non-negative integer" } { "bit-vector" bit-vector } }\r
-{ $description "Creates a new bit vector using the array for underlying storage with the specified initial length." }\r
-{ $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." } ;\r
+++ /dev/null
-IN: bit-vectors.tests\r
-USING: tools.test bit-vectors vectors sequences kernel math ;\r
-\r
-[ 0 ] [ 123 <bit-vector> length ] unit-test\r
-\r
-: do-it\r
- 1234 swap [ >r even? r> push ] curry each ;\r
-\r
-[ t ] [\r
- 3 <bit-vector> dup do-it\r
- 3 <vector> dup do-it sequence=\r
-] unit-test\r
-\r
-[ t ] [ ?V{ } bit-vector? ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays kernel kernel.private math sequences\r
-sequences.private growable bit-arrays ;\r
-IN: bit-vectors\r
-\r
-<PRIVATE\r
-\r
-: bit-array>vector ( bit-array length -- bit-vector )\r
- bit-vector boa ; inline\r
-\r
-PRIVATE>\r
-\r
-: <bit-vector> ( n -- bit-vector )\r
- <bit-array> 0 bit-array>vector ; inline\r
-\r
-: >bit-vector ( seq -- bit-vector ) ?V{ } clone-like ;\r
-\r
-M: bit-vector like\r
- drop dup bit-vector? [\r
- dup bit-array?\r
- [ dup length bit-array>vector ] [ >bit-vector ] if\r
- ] unless ;\r
-\r
-M: bit-vector new-sequence\r
- drop [ <bit-array> ] keep >fixnum bit-array>vector ;\r
-\r
-M: bit-vector equal?\r
- over bit-vector? [ sequence= ] [ 2drop f ] if ;\r
-\r
-M: bit-array new-resizable drop <bit-vector> ;\r
-\r
-INSTANCE: bit-vector growable\r
+++ /dev/null
-Growable bit arrays
+++ /dev/null
-collections
"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"
}
} 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
{
{ "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
[ "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 ;
";"
"<PRIVATE"
"?{"
- "?V{"
"BIN:"
"B{"
- "BV{"
"C:"
"CHAR:"
"DEFER:"
"ERROR:"
"F{"
- "FV{"
"FORGET:"
"GENERIC#"
"GENERIC:"
+++ /dev/null
-USING: arrays byte-arrays help.markup help.syntax kernel\r
-byte-vectors.private combinators ;\r
-IN: byte-vectors\r
-\r
-ARTICLE: "byte-vectors" "Byte vectors"\r
-"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."\r
-$nl\r
-"Byte vectors form a class:"\r
-{ $subsection byte-vector }\r
-{ $subsection byte-vector? }\r
-"Creating byte vectors:"\r
-{ $subsection >byte-vector }\r
-{ $subsection <byte-vector> }\r
-"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"\r
-{ $code "BV{ } clone" } ;\r
-\r
-ABOUT: "byte-vectors"\r
-\r
-HELP: byte-vector\r
-{ $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ;\r
-\r
-HELP: <byte-vector>\r
-{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }\r
-{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;\r
-\r
-HELP: >byte-vector\r
-{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } }\r
-{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }\r
-{ $errors "Throws an error if the sequence contains elements other than integers." } ;\r
-\r
-HELP: byte-array>vector\r
-{ $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } }\r
-{ $description "Creates a new byte vector using the array for underlying storage with the specified initial length." }\r
-{ $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." } ;\r
+++ /dev/null
-IN: byte-vectors.tests\r
-USING: tools.test byte-vectors vectors sequences kernel ;\r
-\r
-[ 0 ] [ 123 <byte-vector> length ] unit-test\r
-\r
-: do-it\r
- 123 [ over push ] each ;\r
-\r
-[ t ] [\r
- 3 <byte-vector> do-it\r
- 3 <vector> do-it sequence=\r
-] unit-test\r
-\r
-[ t ] [ BV{ } byte-vector? ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays kernel kernel.private math sequences\r
-sequences.private growable byte-arrays ;\r
-IN: byte-vectors\r
-\r
-<PRIVATE\r
-\r
-: byte-array>vector ( byte-array length -- byte-vector )\r
- byte-vector boa ; inline\r
-\r
-PRIVATE>\r
-\r
-: <byte-vector> ( n -- byte-vector )\r
- <byte-array> 0 byte-array>vector ; inline\r
-\r
-: >byte-vector ( seq -- byte-vector ) BV{ } clone-like ;\r
-\r
-M: byte-vector like\r
- drop dup byte-vector? [\r
- dup byte-array?\r
- [ dup length byte-array>vector ] [ >byte-vector ] if\r
- ] unless ;\r
-\r
-M: byte-vector new-sequence\r
- drop [ <byte-array> ] keep >fixnum byte-array>vector ;\r
-\r
-M: byte-vector equal?\r
- over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
-\r
-M: byte-array new-resizable drop <byte-vector> ;\r
-\r
-INSTANCE: byte-vector growable\r
+++ /dev/null
-Growable byte arrays
+++ /dev/null
-collections
tools.test vectors words quotations classes classes.algebra\r
classes.private classes.union classes.mixin classes.predicate\r
vectors definitions source-files compiler.units growable\r
-random inference effects kernel.private ;\r
+random inference effects kernel.private sbufs ;\r
\r
: class= [ class< ] 2keep swap class< and ;\r
\r
\r
[ f ] [ null class-not null class= ] unit-test\r
\r
+[ t ] [\r
+ fixnum class-not\r
+ fixnum fixnum class-not class-or\r
+ class<\r
+] unit-test\r
+\r
+! Test method inlining\r
+[ f ] [ fixnum { } min-class ] unit-test\r
+\r
+[ string ] [\r
+ \ string\r
+ [ integer string array reversed sbuf\r
+ slice vector quotation ]\r
+ sort-classes min-class\r
+] unit-test\r
+\r
+[ fixnum ] [\r
+ \ fixnum\r
+ [ fixnum integer object ]\r
+ sort-classes min-class\r
+] unit-test\r
+\r
+[ integer ] [\r
+ \ fixnum\r
+ [ integer float object ]\r
+ sort-classes min-class\r
+] unit-test\r
+\r
+[ object ] [\r
+ \ word\r
+ [ integer float object ]\r
+ sort-classes min-class\r
+] unit-test\r
+\r
+[ reversed ] [\r
+ \ reversed\r
+ [ integer reversed slice ]\r
+ sort-classes min-class\r
+] unit-test\r
+\r
+[ f ] [ null { number fixnum null } min-class ] unit-test\r
+\r
! Test for hangs?\r
: random-class classes random ;\r
\r
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }\r
{ [ over anonymous-union? ] [ left-anonymous-union< ] }\r
{ [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }\r
- { [ over anonymous-complement? ] [ 2drop f ] }\r
{ [ over members ] [ left-union-class< ] }\r
{ [ dup anonymous-union? ] [ right-anonymous-union< ] }\r
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }\r
+ { [ over anonymous-complement? ] [ 2drop f ] }\r
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }\r
{ [ dup members ] [ right-union-class< ] }\r
{ [ over superclass ] [ superclass< ] }\r
[ ] unfold nip ;\r
\r
: min-class ( class seq -- class/f )\r
- [ dupd classes-intersect? ] subset dup empty? [\r
- 2drop f\r
- ] [\r
+ over [ classes-intersect? ] curry subset\r
+ dup empty? [ 2drop f ] [\r
tuck [ class< ] with all? [ peek ] [ drop f ] if\r
] if ;\r
\r
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 ;
drop
] [
dup length 4 <=
- over keys [ word? ] contains? or
+ over keys [ [ word? ] [ wrapper? ] bi or ] contains? or
[
linear-case-quot
] [
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
[ ] [ "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
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
! 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
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> ;
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!
} 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
-! 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
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 ( -- )
HOOK: %box-alien cpu ( dst src -- )
+! GC check
+HOOK: %gc cpu
+
: operand ( var -- op ) get v>operand ; inline
: unique-operands ( operands quot -- )
-! 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
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
: %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
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 ( -- )
[
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
{ { 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
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 ;
EDX 26 SHR
EDX 1 AND
{ EAX EBX ECX EDX } [ POP ] each
- JNE
+ JE
] { } define-if-intrinsic
"-no-sse2" cli-args member? [
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 ;
: 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 ;
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 ;
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 [+] ;
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
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 -- )
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 - ;
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
{ { 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
+++ /dev/null
-USING: arrays float-arrays help.markup help.syntax kernel\r
-float-vectors.private combinators ;\r
-IN: float-vectors\r
-\r
-ARTICLE: "float-vectors" "Float vectors"\r
-"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."\r
-$nl\r
-"Float vectors form a class:"\r
-{ $subsection float-vector }\r
-{ $subsection float-vector? }\r
-"Creating float vectors:"\r
-{ $subsection >float-vector }\r
-{ $subsection <float-vector> }\r
-"If you don't care about initial capacity, a more elegant way to create a new float vector is to write:"\r
-{ $code "FV{ } clone" } ;\r
-\r
-ABOUT: "float-vectors"\r
-\r
-HELP: float-vector\r
-{ $description "The class of resizable float vectors. See " { $link "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general information." } ;\r
-\r
-HELP: <float-vector>\r
-{ $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } }\r
-{ $description "Creates a new float vector that can hold " { $snippet "n" } " floats before resizing." } ;\r
-\r
-HELP: >float-vector\r
-{ $values { "seq" "a sequence" } { "float-vector" float-vector } }\r
-{ $description "Outputs a freshly-allocated float vector with the same elements as a given sequence." }\r
-{ $errors "Throws an error if the sequence contains elements other than real numbers." } ;\r
-\r
-HELP: float-array>vector\r
-{ $values { "float-array" "an array" } { "length" "a non-negative integer" } { "float-vector" float-vector } }\r
-{ $description "Creates a new float vector using the array for underlying storage with the specified initial length." }\r
-{ $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." } ;\r
+++ /dev/null
-IN: float-vectors.tests\r
-USING: tools.test float-vectors vectors sequences kernel ;\r
-\r
-[ 0 ] [ 123 <float-vector> length ] unit-test\r
-\r
-: do-it\r
- 12345 [ over push ] each ;\r
-\r
-[ t ] [\r
- 3 <float-vector> do-it\r
- 3 <vector> do-it sequence=\r
-] unit-test\r
-\r
-[ t ] [ FV{ } float-vector? ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays kernel kernel.private math sequences\r
-sequences.private growable float-arrays ;\r
-IN: float-vectors\r
-\r
-<PRIVATE\r
-\r
-: float-array>vector ( float-array length -- float-vector )\r
- float-vector boa ; inline\r
-\r
-PRIVATE>\r
-\r
-: <float-vector> ( n -- float-vector )\r
- 0.0 <float-array> 0 float-array>vector ; inline\r
-\r
-: >float-vector ( seq -- float-vector ) FV{ } clone-like ;\r
-\r
-M: float-vector like\r
- drop dup float-vector? [\r
- dup float-array?\r
- [ dup length float-array>vector ] [ >float-vector ] if\r
- ] unless ;\r
-\r
-M: float-vector new-sequence\r
- drop [ 0.0 <float-array> ] keep >fixnum float-array>vector ;\r
-\r
-M: float-vector equal?\r
- over float-vector? [ sequence= ] [ 2drop f ] if ;\r
-\r
-M: float-array new-resizable drop <float-vector> ;\r
-\r
-INSTANCE: float-vector growable\r
+++ /dev/null
-Growable float arrays
+++ /dev/null
-collections
{ $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."
! 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
: 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 ;
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 )
: 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 ;
: 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 ;
"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
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
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 ;
: 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 <=
: 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 )
-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 ;
: <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' )
>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
] [ ] 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 ;
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
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?
{ $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."
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?
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 ;
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 ;
\ 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 )
: <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 ;
drop join-values inline-block apply-infer
r> over set-node-in-d
dup node,
- collect-recursion [
+ calls>> [
[ flatten-curries ] modify-values
] each
] [
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
! 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 )
[ { 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 ] [
[
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 )
] \ 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
[ 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 = [
] unit-test
] when
+[ f ] [
+ [ { integer } declare -63 shift 4095 bitand ]
+ \ shift inlined?
+] unit-test
+
[ t ] [
[ B{ 1 0 } *short 0 number= ]
\ number= inlined?
] 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
-! 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
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 ;
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> , ;
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 )
[ 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 )
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
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 ;
] 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
[
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
>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 ;
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
{
: (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
(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 ;
: 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 ;
: 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 ;
{ 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
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 ;
peek-d infer-call
] "infer" set-word-prop
+\ call t "no-compile" set-word-prop
+
\ execute [
1 ensure-values
pop-literal nip
\ 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
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"
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+UTF16 encoding/decoding
--- /dev/null
+USING: help.markup help.syntax io.encodings strings ;
+IN: io.encodings.utf16
+
+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 } ;
+
+ABOUT: "io.encodings.utf16"
+
+HELP: utf16le
+{ $class-description "The encoding descriptor for UTF-16LE, that is, UTF-16 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: utf16be
+{ $class-description "The encoding descriptor for UTF-16BE, that is, UTF-16 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
+
+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" } ;
+
+{ utf16 utf16le utf16be } related-words
--- /dev/null
+USING: kernel tools.test io.encodings.utf16 arrays sbufs
+io.streams.byte-array sequences io.encodings io unicode
+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
+[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test
+
+[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode >array ] unit-test
+
+[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode >array ] unit-test
+[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test
+[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
+
+[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test
+
+[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test
+[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test
+
+[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test
+
+: correct-endian
+ code>> class little-endian? [ utf16le = ] [ utf16be = ] if ;
+
+[ t ] [ B{ } utf16n <byte-reader> correct-endian ] unit-test
+[ t ] [ utf16n <byte-writer> correct-endian ] unit-test
--- /dev/null
+! 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 ;
+IN: io.encodings.utf16
+
+TUPLE: utf16be ;
+
+TUPLE: utf16le ;
+
+TUPLE: utf16 ;
+
+<PRIVATE
+
+! UTF-16BE decoding
+
+: append-nums ( byte ch -- ch )
+ over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
+
+: double-be ( stream byte -- stream char )
+ over stream-read1 swap append-nums ;
+
+: quad-be ( stream byte -- stream char )
+ double-be over stream-read1 [
+ dup -2 shift BIN: 110111 number= [
+ >r 2 shift r> BIN: 11 bitand bitor
+ over stream-read1 swap append-nums HEX: 10000 +
+ ] [ 2drop dup stream-read1 drop replacement-char ] if
+ ] when* ;
+
+: ignore ( stream -- stream char )
+ dup stream-read1 drop replacement-char ;
+
+: begin-utf16be ( stream byte -- stream char )
+ dup -3 shift BIN: 11011 number= [
+ dup BIN: 00000100 bitand zero?
+ [ BIN: 11 bitand quad-be ]
+ [ drop ignore ] if
+ ] [ double-be ] if ;
+
+M: utf16be decode-char
+ drop dup stream-read1 dup [ begin-utf16be ] when nip ;
+
+! UTF-16LE decoding
+
+: quad-le ( stream ch -- stream char )
+ over stream-read1 swap 10 shift bitor
+ over stream-read1 dup -2 shift BIN: 110111 = [
+ BIN: 11 bitand append-nums HEX: 10000 +
+ ] [ 2drop replacement-char ] if ;
+
+: double-le ( stream byte1 byte2 -- stream char )
+ dup -3 shift BIN: 11011 = [
+ dup BIN: 100 bitand 0 number=
+ [ BIN: 11 bitand 8 shift bitor quad-le ]
+ [ 2drop replacement-char ] if
+ ] [ append-nums ] if ;
+
+: begin-utf16le ( stream byte -- stream char )
+ over stream-read1 [ double-le ] [ drop replacement-char ] if* ;
+
+M: utf16le decode-char
+ drop dup stream-read1 dup [ begin-utf16le ] when nip ;
+
+! UTF-16LE/BE encoding
+
+: encode-first ( char -- byte1 byte2 )
+ -10 shift
+ dup -8 shift BIN: 11011000 bitor
+ swap HEX: FF bitand ;
+
+: encode-second ( char -- byte3 byte4 )
+ BIN: 1111111111 bitand
+ dup -8 shift BIN: 11011100 bitor
+ swap BIN: 11111111 bitand ;
+
+: stream-write2 ( stream char1 char2 -- )
+ rot [ stream-write1 ] curry bi@ ;
+
+: char>utf16be ( stream char -- )
+ dup HEX: FFFF > [
+ HEX: 10000 -
+ 2dup encode-first stream-write2
+ encode-second stream-write2
+ ] [ h>b/b swap stream-write2 ] if ;
+
+M: utf16be encode-char ( char stream encoding -- )
+ drop swap char>utf16be ;
+
+: char>utf16le ( char stream -- )
+ dup HEX: FFFF > [
+ HEX: 10000 -
+ 2dup encode-first swap stream-write2
+ encode-second swap stream-write2
+ ] [ h>b/b stream-write2 ] if ;
+
+M: utf16le encode-char ( char stream encoding -- )
+ drop swap char>utf16le ;
+
+! UTF-16
+
+: bom-le B{ HEX: ff HEX: fe } ; inline
+
+: bom-be B{ HEX: fe HEX: ff } ; inline
+
+: start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
+
+: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
+
+TUPLE: missing-bom ;
+M: missing-bom summary drop "The BOM for a UTF-16 stream was missing" ;
+
+: bom>le/be ( bom -- le/be )
+ dup bom-le sequence= [ drop utf16le ] [
+ bom-be sequence= [ utf16be ] [ missing-bom ] if
+ ] if ;
+
+M: utf16 <decoder> ( stream utf16 -- decoder )
+ drop 2 over stream-read bom>le/be <decoder> ;
+
+M: utf16 <encoder> ( stream utf16 -- encoder )
+ drop bom-le over stream-write utf16le <encoder> ;
+
+PRIVATE>
--- /dev/null
+! 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 ;
[ 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
: 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 ] }
USING: help.markup help.syntax kernel sequences quotations
-math.private math.functions ;
+math.private ;
IN: math
ARTICLE: "division-by-zero" "Division by zero"
{ $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"
{ $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" } "." }
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
: 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
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
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? [
- 2drop
- ] [
- [ node-literals ?union ] keep set-node-literals
- ] if ;
+: add-node-literals ( node assoc -- )
+ [ ?union ] curry change-literals drop ;
-: add-node-classes ( assoc node -- )
- over assoc-empty? [
- 2drop
- ] [
- [ node-classes ?union ] keep set-node-classes
- ] if ;
+: add-node-classes ( node assoc -- )
+ [ ?union ] curry change-classes drop ;
-: substitute-values ( assoc node -- )
- over assoc-empty? [
+: substitute-values ( node assoc -- )
+ dup 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
#! 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
--- /dev/null
+! 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 ;
+
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
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
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
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? ;
] unit-test
[ f ] [
- [ [ [ ] map ] map ] dataflow dup detect-loops
+ [ [ [ ] map ] map ] dataflow detect-loops
[ dup #label? swap #loop? not and ] node-exists?
] unit-test
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
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
! 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
] [ 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
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? ;
-! 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
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) ;
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
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
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 [
] 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 -- )
#! 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 ;
--- /dev/null
+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
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 -- )
[ 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 ;
! Partial dispatch of math-generic words
: normalize-math-class ( class -- class' )
{
+ null
fixnum bignum integer
ratio rational
float real
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 ;
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 [
[ 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 ;
] "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
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 } {
- { { number 0 } [ drop ] }
- { { 0 number } [ nip ] }
-} define-identities
+: define-math-identities ( word identities -- )
+ >r all-derived-ops r> define-identities ;
+
+\ number= {
+ { { @ @ } [ 2drop t ] }
+} define-math-identities
-{ fixnum+ } {
+\ + {
{ { number 0 } [ drop ] }
{ { 0 number } [ nip ] }
-} define-identities
+} define-math-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?
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@ ;
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
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 ? )
r> post-process ; inline
{
- { mod fixnum mod-range }
- { fixnum-mod f mod-range }
- { bignum-mod f mod-range }
- { float-mod f mod-range }
-
- { rem integer rem-range }
+ { mod { } mod-range }
+ { rem { { fixnum 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 )
{ <= 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
{
! 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? ] ,
{ <= 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
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 ;
-
-: 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? ;
-
-: fixnum-shift-fast? ( node -- ? )
- dup fixnum-shift-fast-pos?
- [ drop t ] [ fixnum-shift-fast-neg? ] if ;
-
-\ fixnum-shift {
+: 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 ;
+
+: 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 ;
+
+: convert-mod-to-and ( #call -- node )
+ dup
+ dup node-in-d second node-literal 1-
+ [ nip bitand ] curry f splice-quot ;
+
+\ mod [
+ {
+ {
+ [ 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 fixnum-shift-fast? ]
- [ [ fixnum-shift-fast ] f splice-quot ]
+ [ dup fixnumify-bitand? ]
+ [ fixnumify-bitand ]
}
} define-optimizers
--- /dev/null
+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
--- /dev/null
+! 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
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 } } ] [
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 ;
[ 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 ;
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
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
! 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 ? )
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
! 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 -- )
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{ \ } ;
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 ;
! 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 ;
! 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
! 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 ;
{ $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 }
{ <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> } "." } ;
[ 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
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 ;
: flip ( matrix -- newmatrix )
dup empty? [
dup [ length ] map infimum
- [ <column> dup like ] with map
+ swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as
] unless ;
{ $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" } "." ;
{ $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" } ;
{ $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" } }
! 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
"{" [ \ } [ >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
{ $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:"
{ $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 } "." ;
-USING: namespaces io tools.test threads kernel ;
+USING: namespaces io tools.test threads kernel
+concurrency.combinators math ;
IN: threads.tests
3 "x" set
] 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
tnamespace set-at ;
: tchange ( key quot -- )
- tnamespace change-at ; inline
+ tnamespace swap change-at ; inline
: threads 41 getenv ;
--- /dev/null
+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 ;
-USING: namespaces math sequences splitting kernel ;
+USING: namespaces math sequences splitting kernel columns ;
IN: benchmark.dispatch2
: sequences
USING: sequences math mirrors splitting kernel namespaces
-assocs alien.syntax ;
+assocs alien.syntax columns ;
IN: benchmark.dispatch3
GENERIC: g ( obj -- str )
+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
! 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 ;
HINTS: spectral-norm fixnum ;
: spectral-norm-main ( -- )
- 2000 spectral-norm . ;
+ 5500 spectral-norm . ;
MAIN: spectral-norm-main
--- /dev/null
+USING: arrays bit-arrays help.markup help.syntax kernel\r
+bit-vectors.private combinators ;\r
+IN: bit-vectors\r
+\r
+ARTICLE: "bit-vectors" "Bit vectors"\r
+"A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."\r
+$nl\r
+"Bit vectors form a class:"\r
+{ $subsection bit-vector }\r
+{ $subsection bit-vector? }\r
+"Creating bit vectors:"\r
+{ $subsection >bit-vector }\r
+{ $subsection <bit-vector> }\r
+"Literal syntax:"\r
+{ $subsection POSTPONE: ?V{ }\r
+"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"\r
+{ $code "?V{ } clone" } ;\r
+\r
+ABOUT: "bit-vectors"\r
+\r
+HELP: bit-vector\r
+{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;\r
+\r
+HELP: <bit-vector>\r
+{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }\r
+{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;\r
+\r
+HELP: >bit-vector\r
+{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } }\r
+{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;\r
+\r
+HELP: bit-array>vector\r
+{ $values { "bit-array" "an array" } { "length" "a non-negative integer" } { "bit-vector" bit-vector } }\r
+{ $description "Creates a new bit vector using the array for underlying storage with the specified initial length." }\r
+{ $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." } ;\r
+\r
+HELP: ?V{\r
+{ $syntax "?V{ elements... }" }\r
+{ $values { "elements" "a list of booleans" } }\r
+{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." } \r
+{ $examples { $code "?V{ t f t }" } } ;\r
+\r
--- /dev/null
+IN: bit-vectors.tests\r
+USING: tools.test bit-vectors vectors sequences kernel math ;\r
+\r
+[ 0 ] [ 123 <bit-vector> length ] unit-test\r
+\r
+: do-it\r
+ 1234 swap [ >r even? r> push ] curry each ;\r
+\r
+[ t ] [\r
+ 3 <bit-vector> dup do-it\r
+ 3 <vector> dup do-it sequence=\r
+] unit-test\r
+\r
+[ t ] [ ?V{ } bit-vector? ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: arrays kernel kernel.private math sequences\r
+sequences.private growable bit-arrays prettyprint.backend\r
+parser accessors ;\r
+IN: bit-vectors\r
+\r
+TUPLE: bit-vector underlying fill ;\r
+\r
+M: bit-vector underlying underlying>> { bit-array } declare ;\r
+\r
+M: bit-vector set-underlying (>>underlying) ;\r
+\r
+M: bit-vector length fill>> { array-capacity } declare ;\r
+\r
+M: bit-vector set-fill (>>fill) ;\r
+\r
+<PRIVATE\r
+\r
+: bit-array>vector ( bit-array length -- bit-vector )\r
+ bit-vector boa ; inline\r
+\r
+PRIVATE>\r
+\r
+: <bit-vector> ( n -- bit-vector )\r
+ <bit-array> 0 bit-array>vector ; inline\r
+\r
+: >bit-vector ( seq -- bit-vector )\r
+ T{ bit-vector f ?{ } 0 } clone-like ;\r
+\r
+M: bit-vector like\r
+ drop dup bit-vector? [\r
+ dup bit-array?\r
+ [ dup length bit-array>vector ] [ >bit-vector ] if\r
+ ] unless ;\r
+\r
+M: bit-vector new-sequence\r
+ drop [ <bit-array> ] keep >fixnum bit-array>vector ;\r
+\r
+M: bit-vector equal?\r
+ over bit-vector? [ sequence= ] [ 2drop f ] if ;\r
+\r
+M: bit-array new-resizable drop <bit-vector> ;\r
+\r
+INSTANCE: bit-vector growable\r
+\r
+: ?V{ \ } [ >bit-vector ] parse-literal ; parsing\r
+\r
+M: bit-vector >pprint-sequence ;\r
+\r
+M: bit-vector pprint-delims drop \ ?V{ \ } ;\r
--- /dev/null
+Growable bit arrays
--- /dev/null
+collections
SYMBOL: builder-debug
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
: delete-child-factor ( -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+SYMBOL: upload-to-factorcode
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
SYMBOL: builds-dir
: builds ( -- path )
: 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 ( -- )
{ status-vm status-boot status-test status-build status-release status }
[ off ]
each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: upload-to-factorcode
-
SYMBOL: builder-from
SYMBOL: builder-recipients
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: subject-status ( -- str ) status get [ "report" ] [ "error" ] if ;
: subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ;
--- /dev/null
+USING: arrays byte-arrays help.markup help.syntax kernel\r
+byte-vectors.private combinators ;\r
+IN: byte-vectors\r
+\r
+ARTICLE: "byte-vectors" "Byte vectors"\r
+"A byte vector is a resizable mutable sequence of unsigned bytes. Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary."\r
+$nl\r
+"Byte vectors form a class:"\r
+{ $subsection byte-vector }\r
+{ $subsection byte-vector? }\r
+"Creating byte vectors:"\r
+{ $subsection >byte-vector }\r
+{ $subsection <byte-vector> }\r
+"Literal syntax:"\r
+{ $subsection POSTPONE: BV{ }\r
+"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"\r
+{ $code "BV{ } clone" } ;\r
+\r
+ABOUT: "byte-vectors"\r
+\r
+HELP: byte-vector\r
+{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ;\r
+\r
+HELP: <byte-vector>\r
+{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }\r
+{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;\r
+\r
+HELP: >byte-vector\r
+{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } }\r
+{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }\r
+{ $errors "Throws an error if the sequence contains elements other than integers." } ;\r
+\r
+HELP: byte-array>vector\r
+{ $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } }\r
+{ $description "Creates a new byte vector using the array for underlying storage with the specified initial length." }\r
+{ $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." } ;\r
+\r
+HELP: BV{\r
+{ $syntax "BV{ elements... }" }\r
+{ $values { "elements" "a list of bytes" } }\r
+{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } \r
+{ $examples { $code "BV{ 1 2 3 12 }" } } ;\r
--- /dev/null
+IN: byte-vectors.tests\r
+USING: tools.test byte-vectors vectors sequences kernel ;\r
+\r
+[ 0 ] [ 123 <byte-vector> length ] unit-test\r
+\r
+: do-it\r
+ 123 [ over push ] each ;\r
+\r
+[ t ] [\r
+ 3 <byte-vector> do-it\r
+ 3 <vector> do-it sequence=\r
+] unit-test\r
+\r
+[ t ] [ BV{ } byte-vector? ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: arrays kernel kernel.private math sequences\r
+sequences.private growable byte-arrays prettyprint.backend\r
+parser accessors ;\r
+IN: byte-vectors\r
+\r
+TUPLE: byte-vector underlying fill ;\r
+\r
+M: byte-vector underlying underlying>> { byte-array } declare ;\r
+\r
+M: byte-vector set-underlying (>>underlying) ;\r
+\r
+M: byte-vector length fill>> { array-capacity } declare ;\r
+\r
+M: byte-vector set-fill (>>fill) ;\r
+\r
+<PRIVATE\r
+\r
+: byte-array>vector ( byte-array length -- byte-vector )\r
+ byte-vector boa ; inline\r
+\r
+PRIVATE>\r
+\r
+: <byte-vector> ( n -- byte-vector )\r
+ <byte-array> 0 byte-array>vector ; inline\r
+\r
+: >byte-vector ( seq -- byte-vector )\r
+ T{ byte-vector f B{ } 0 } clone-like ;\r
+\r
+M: byte-vector like\r
+ drop dup byte-vector? [\r
+ dup byte-array?\r
+ [ dup length byte-array>vector ] [ >byte-vector ] if\r
+ ] unless ;\r
+\r
+M: byte-vector new-sequence\r
+ drop [ <byte-array> ] keep >fixnum byte-array>vector ;\r
+\r
+M: byte-vector equal?\r
+ over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
+\r
+M: byte-array new-resizable drop <byte-vector> ;\r
+\r
+INSTANCE: byte-vector growable\r
+\r
+: BV{ \ } [ >byte-vector ] parse-literal ; parsing\r
+\r
+M: byte-vector >pprint-sequence ;\r
+\r
+M: byte-vector pprint-delims drop \ BV{ \ } ;\r
--- /dev/null
+Growable byte arrays
--- /dev/null
+collections
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
#! 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 ;
#! 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+ ;
-USING: calendar.format calendar kernel tools.test\r
-io.streams.string ;\r
+USING: calendar.format calendar kernel math tools.test\r
+io.streams.string accessors io ;\r
IN: calendar.format.tests\r
\r
[ 0 ] [\r
- "Z" [ read-rfc3339-gmt-offset ] with-string-reader\r
+ "Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours\r
] unit-test\r
\r
[ 1 ] [\r
- "+01" [ read-rfc3339-gmt-offset ] with-string-reader\r
+ "+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours\r
] unit-test\r
\r
[ -1 ] [\r
- "-01" [ read-rfc3339-gmt-offset ] with-string-reader\r
+ "-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours\r
] unit-test\r
\r
[ -1-1/2 ] [\r
- "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader\r
+ "-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours\r
] unit-test\r
\r
[ 1+1/2 ] [\r
- "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader\r
+ "+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours\r
] unit-test\r
\r
[ ] [ now timestamp>rfc3339 drop ] unit-test\r
[ ] [ now timestamp>rfc822 drop ] unit-test\r
+\r
+[ 8/1000 -4 ] [\r
+ "2008-04-19T04:56:00.008-04:00" rfc3339>timestamp\r
+ [ second>> ] [ gmt-offset>> hour>> ] bi\r
+] unit-test\r
+\r
+[ T{ duration f 0 0 0 0 0 0 } ] [\r
+ "GMT" parse-rfc822-gmt-offset\r
+] unit-test\r
+\r
+[ T{ duration f 0 0 0 -5 0 0 } ] [\r
+ "-0500" parse-rfc822-gmt-offset\r
+] unit-test\r
+\r
+[ T{ timestamp f 2008 4 22 14 36 12 T{ duration f 0 0 0 0 0 0 } } ] [\r
+ "Tue, 22 Apr 2008 14:36:12 GMT" rfc822>timestamp\r
+] unit-test\r
+\r
+[ t ] [ now dup timestamp>rfc822 rfc822>timestamp time- 1 seconds before? ] unit-test\r
USING: math math.parser kernel sequences io calendar\r
-accessors arrays io.streams.string combinators accessors ;\r
+accessors arrays io.streams.string splitting\r
+combinators accessors debugger ;\r
IN: calendar.format\r
\r
GENERIC: day. ( obj -- )\r
[ hour>> write-00 ] [ minute>> write-00 ] bi ;\r
\r
: write-gmt-offset ( gmt-offset -- )\r
- dup instant <=> {\r
- { [ dup 0 = ] [ 2drop "GMT" write ] }\r
- { [ dup 0 < ] [ drop "-" write before (write-gmt-offset) ] }\r
- { [ dup 0 > ] [ drop "+" write (write-gmt-offset) ] }\r
- } cond ;\r
+ dup instant <=> sgn {\r
+ { 0 [ drop "GMT" write ] }\r
+ { -1 [ "-" write before (write-gmt-offset) ] }\r
+ { 1 [ "+" write (write-gmt-offset) ] }\r
+ } case ;\r
\r
: timestamp>rfc822 ( timestamp -- str )\r
#! RFC822 timestamp format\r
[ minute>> write-00 ] bi ;\r
\r
: write-rfc3339-gmt-offset ( duration -- )\r
- dup instant <=> {\r
- { [ dup 0 = ] [ 2drop "Z" write ] }\r
- { [ dup 0 < ] [ drop CHAR: - write1 before (write-rfc3339-gmt-offset) ] }\r
- { [ dup 0 > ] [ drop CHAR: + write1 (write-rfc3339-gmt-offset) ] }\r
- } cond ;\r
+ dup instant <=> sgn {\r
+ { 0 [ drop "Z" write ] }\r
+ { -1 [ CHAR: - write1 before (write-rfc3339-gmt-offset) ] }\r
+ { 1 [ CHAR: + write1 (write-rfc3339-gmt-offset) ] }\r
+ } case ;\r
\r
: (timestamp>rfc3339) ( timestamp -- )\r
- dup year>> number>string write CHAR: - write1\r
- dup month>> write-00 CHAR: - write1\r
- dup day>> write-00 CHAR: T write1\r
- dup hour>> write-00 CHAR: : write1\r
- dup minute>> write-00 CHAR: : write1\r
- dup second>> >fixnum write-00\r
- gmt-offset>> write-rfc3339-gmt-offset ;\r
+ {\r
+ [ year>> number>string write CHAR: - write1 ]\r
+ [ month>> write-00 CHAR: - write1 ]\r
+ [ day>> write-00 CHAR: T write1 ]\r
+ [ hour>> write-00 CHAR: : write1 ]\r
+ [ minute>> write-00 CHAR: : write1 ]\r
+ [ second>> >fixnum write-00 ]\r
+ [ gmt-offset>> write-rfc3339-gmt-offset ]\r
+ } cleave ;\r
\r
: timestamp>rfc3339 ( timestamp -- str )\r
[ (timestamp>rfc3339) ] with-string-writer ;\r
\r
: read-00 2 read string>number ;\r
\r
+: read-000 3 read string>number ;\r
+\r
: read-0000 4 read string>number ;\r
\r
-: read-rfc3339-gmt-offset ( -- n )\r
- read1 dup CHAR: Z = [ drop 0 ] [\r
- { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case\r
- read-00\r
- read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case\r
- 60 / + *\r
+: signed-gmt-offset ( dt ch -- dt' )\r
+ { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;\r
+\r
+: read-rfc3339-gmt-offset ( ch -- dt )\r
+ dup CHAR: Z = [ drop instant ] [\r
+ >r\r
+ read-00 hours\r
+ read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes\r
+ time+\r
+ r> signed-gmt-offset\r
] if ;\r
\r
: read-ymd ( -- y m d )\r
read-ymd\r
"Tt" expect\r
read-hms\r
- read-rfc3339-gmt-offset ! timezone\r
+ read1 { { CHAR: . [ read-000 1000 / + read1 ] } [ ] } case\r
+ read-rfc3339-gmt-offset\r
<timestamp> ;\r
\r
: rfc3339>timestamp ( str -- timestamp )\r
[ (rfc3339>timestamp) ] with-string-reader ;\r
\r
+ERROR: invalid-rfc822-date ;\r
+\r
+: check-rfc822-date ( obj/f -- obj ) [ invalid-rfc822-date ] unless* ;\r
+\r
+: read-token ( seps -- token )\r
+ [ read-until ] keep member? check-rfc822-date drop ;\r
+\r
+: read-sp ( -- token ) " " read-token ;\r
+\r
+: checked-number ( str -- n )\r
+ string>number check-rfc822-date ;\r
+\r
+: parse-rfc822-gmt-offset ( string -- dt )\r
+ dup "GMT" = [ drop instant ] [\r
+ unclip >r\r
+ 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+\r
+ r> signed-gmt-offset\r
+ ] if ;\r
+\r
+: (rfc822>timestamp) ( -- timestamp )\r
+ timestamp new\r
+ "," read-token day-abbreviations3 member? check-rfc822-date drop\r
+ read1 CHAR: \s assert=\r
+ read-sp checked-number >>day\r
+ read-sp month-abbreviations index check-rfc822-date >>month\r
+ read-sp checked-number >>year\r
+ ":" read-token checked-number >>hour\r
+ ":" read-token checked-number >>minute\r
+ " " read-token checked-number >>second\r
+ readln parse-rfc822-gmt-offset >>gmt-offset ;\r
+\r
+: rfc822>timestamp ( str -- timestamp )\r
+ [ (rfc822>timestamp) ] with-string-reader ;\r
+\r
: (ymdhms>timestamp) ( -- timestamp )\r
- read-ymd " " expect read-hms 0 <timestamp> ;\r
+ read-ymd " " expect read-hms instant <timestamp> ;\r
\r
: ymdhms>timestamp ( str -- timestamp )\r
[ (ymdhms>timestamp) ] with-string-reader ;\r
\r
: (hms>timestamp) ( -- timestamp )\r
- f f f read-hms f <timestamp> ;\r
+ f f f read-hms instant <timestamp> ;\r
\r
: hms>timestamp ( str -- timestamp )\r
[ (hms>timestamp) ] with-string-reader ;\r
\r
: (ymd>timestamp) ( -- timestamp )\r
- read-ymd f f f f <timestamp> ;\r
+ read-ymd f f f instant <timestamp> ;\r
\r
: ymd>timestamp ( str -- timestamp )\r
[ (ymd>timestamp) ] with-string-reader ;\r
-! 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 )
: 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
! 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 )
: <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
--- /dev/null
+Slava Pestov
+Daniel Ehrenberg
--- /dev/null
+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"
--- /dev/null
+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
--- /dev/null
+! 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
--- /dev/null
+Virtual sequence view of a matrix column
--- /dev/null
+collections
! 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
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 ) ;
: 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 ;
! 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
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
: >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 ;
! 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
update-statements
delete-statements ;
-: construct-db ( class -- obj )
+: new-db ( class -- obj )
new
H{ } clone >>insert-statements
H{ } clone >>update-statements
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 -- )
] 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 ;
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 )
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 -- )
- dup sequence? [
- [ execute-statement ] each
- ] [
- query-results dispose
- ] if ;
+M: throwable execute-statement* ( statement type -- )
+ drop query-results dispose ;
+
+M: nonthrowable execute-statement* ( statement type -- )
+ drop [ query-results dispose ] [ 2drop ] recover ;
-M: nonthrowable-statement execute-statement ( statement -- )
+: execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
] [
- [ query-results dispose ] [ 2drop ] recover
+ dup type>> execute-statement*
] if ;
: bind-statement ( obj statement -- )
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 )
"\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? ;
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 )
} 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
] 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 ;
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 ;
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 ] }
dup [ bytes>object ] when ] }
[ no-sql-type ]
} case ;
- ! PQgetlength PQgetisnull
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
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 ;
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
] [
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 ;
-
-M: postgresql-db begin-transaction ( -- )
- "BEGIN" sql-command ;
+ <simple-statement> dup prepare-statement ;
-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 )
[
"(" 0%
over [ "," 0% ]
[
- sql-spec-type f lookup-type 0%
+ type>> lookup-type 0%
] interleave
")" 0%
" returns bigint as '" 0%
"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 )
[
"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 )
[
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 ;
--- /dev/null
+! 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 ;
USING: kernel namespaces db.sql sequences math ;
IN: db.sql.tests
-TUPLE: person name age ;
+! TUPLE: person name age ;
: insert-1
{ insert
{ table "person" }
{ select
{ columns "salary" }
{ from "staff" }
- { where { "branchno" "b003" } }
+ { where { "branchno" = "b003" } }
}
}
{ "branchno" > 3 } }
: 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% ] }
{ [ 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 ;
! 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" {
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 ) ;
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 -- * )
[ sqlite-error ]
} cond ;
-: sqlite-open ( filename -- db )
+: sqlite-open ( path -- db )
+ normalize-path
"void*" <c-object>
[ sqlite3_open sqlite-check-result ] keep *void* ;
: 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 ;
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 ;
{
{ 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 ] }
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 ;
: 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 ] }
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 ;
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? ;
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 ;
-M: sqlite-statement bind-statement* ( statement -- )
+: reset-bindings ( statement -- )
sqlite-maybe-prepare
- dup statement-bound? [ dup reset-statement ] when
+ handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
+
+M: sqlite-statement low-level-bind ( statement -- )
[ statement-bind-params ] [ statement-handle ] bi
- sqlite-bind ;
+ swap [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
+
+M: sqlite-statement bind-statement* ( statement -- )
+ sqlite-maybe-prepare
+ 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
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 )
[
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 ;
! 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
"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
"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" } }
}
[ ] [ 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"
{
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
-
[ ] [ person1 get insert-tuple ] unit-test
[ person1 get insert-tuple ] must-fail ;
{ 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+ }
[ ] [ 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
: 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
+ [ t ] [
+ T{ secret } select-tuples
+ first message>> "kilroy was here" head?
+ ] 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 length 3 =
+ ] unit-test ;
-! \ insert-tuple must-infer
-! \ update-tuple must-infer
-! \ delete-tuple must-infer
-! \ select-tuple must-infer
-! \ define-persistent must-infer
+[ 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
! 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
"db-columns" set-word-prop
"db-relations" set-word-prop ;
-: db-table ( class -- obj ) "db-table" word-prop ;
-: db-columns ( class -- obj ) "db-columns" word-prop ;
-: db-relations ( class -- obj ) "db-relations" word-prop ;
+ERROR: not-persistent ;
+
+: db-table ( class -- obj )
+ "db-table" word-prop [ not-persistent ] unless* ;
+
+: db-columns ( class -- obj )
+ "db-columns" word-prop ;
+
+: db-relations ( class -- obj )
+ "db-relations" word-prop ;
: set-primary-key ( key tuple -- )
[
- class db-columns find-primary-key sql-spec-slot-name
+ class db-columns find-primary-key slot-name>>
] keep set-slot-named ;
+SYMBOL: sql-counter
+: next-sql-counter ( -- str )
+ sql-counter [ inc ] [ get ] bi number>string ;
+
! returns a sequence of prepared-statements
HOOK: create-sql-statement db ( class -- obj )
HOOK: drop-sql-statement db ( class -- obj )
HOOK: 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? [
[ 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
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+
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 ;
[ 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
+ERROR: unknown-modifier ;
+
: lookup-modifier ( obj -- str )
- dup array? [
- unclip lookup-modifier swap compound-modifier
- ] [
- modifier-table at*
- [ "unknown modifier" throw ] unless
- ] if ;
+ {
+ { [ dup array? ] [ unclip lookup-modifier swap compound ] }
+ [ persistent-table at* [ unknown-modifier ] unless third ]
+ } cond ;
+
+ERROR: no-sql-type ;
-: lookup-type* ( obj -- str )
+: (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 ;
" " 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 ;
: 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 ;
! 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 ;
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
: 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
[ "<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
! 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
: 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 ;
--- /dev/null
+USING: arrays float-arrays help.markup help.syntax kernel\r
+float-vectors.private combinators ;\r
+IN: float-vectors\r
+\r
+ARTICLE: "float-vectors" "Float vectors"\r
+"A float vector is a resizable mutable sequence of unsigned floats. Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary."\r
+$nl\r
+"Float vectors form a class:"\r
+{ $subsection float-vector }\r
+{ $subsection float-vector? }\r
+"Creating float vectors:"\r
+{ $subsection >float-vector }\r
+{ $subsection <float-vector> }\r
+"Literal syntax:"\r
+{ $subsection POSTPONE: FV{ }\r
+"If you don't care about initial capacity, a more elegant way to create a new float vector is to write:"\r
+{ $code "FV{ } clone" } ;\r
+\r
+ABOUT: "float-vectors"\r
+\r
+HELP: float-vector\r
+{ $description "The class of resizable float vectors. See " { $link "float-vectors" } " for information." } ;\r
+\r
+HELP: <float-vector>\r
+{ $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } }\r
+{ $description "Creates a new float vector that can hold " { $snippet "n" } " floats before resizing." } ;\r
+\r
+HELP: >float-vector\r
+{ $values { "seq" "a sequence" } { "float-vector" float-vector } }\r
+{ $description "Outputs a freshly-allocated float vector with the same elements as a given sequence." }\r
+{ $errors "Throws an error if the sequence contains elements other than real numbers." } ;\r
+\r
+HELP: float-array>vector\r
+{ $values { "float-array" "an array" } { "length" "a non-negative integer" } { "float-vector" float-vector } }\r
+{ $description "Creates a new float vector using the array for underlying storage with the specified initial length." }\r
+{ $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." } ;\r
+\r
+HELP: FV{\r
+{ $syntax "FV{ elements... }" }\r
+{ $values { "elements" "a list of real numbers" } }\r
+{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." } \r
+{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ;\r
--- /dev/null
+IN: float-vectors.tests\r
+USING: tools.test float-vectors vectors sequences kernel ;\r
+\r
+[ 0 ] [ 123 <float-vector> length ] unit-test\r
+\r
+: do-it\r
+ 12345 [ over push ] each ;\r
+\r
+[ t ] [\r
+ 3 <float-vector> do-it\r
+ 3 <vector> do-it sequence=\r
+] unit-test\r
+\r
+[ t ] [ FV{ } float-vector? ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: arrays kernel kernel.private math sequences\r
+sequences.private growable float-arrays prettyprint.backend\r
+parser accessors ;\r
+IN: float-vectors\r
+\r
+TUPLE: float-vector underlying fill ;\r
+\r
+M: float-vector underlying underlying>> { float-array } declare ;\r
+\r
+M: float-vector set-underlying (>>underlying) ;\r
+\r
+M: float-vector length fill>> { array-capacity } declare ;\r
+\r
+M: float-vector set-fill (>>fill) ;\r
+\r
+<PRIVATE\r
+\r
+: float-array>vector ( float-array length -- float-vector )\r
+ float-vector boa ; inline\r
+\r
+PRIVATE>\r
+\r
+: <float-vector> ( n -- float-vector )\r
+ 0.0 <float-array> 0 float-array>vector ; inline\r
+\r
+: >float-vector ( seq -- float-vector )\r
+ T{ float-vector f F{ } 0 } clone-like ;\r
+\r
+M: float-vector like\r
+ drop dup float-vector? [\r
+ dup float-array?\r
+ [ dup length float-array>vector ] [ >float-vector ] if\r
+ ] unless ;\r
+\r
+M: float-vector new-sequence\r
+ drop [ 0.0 <float-array> ] keep >fixnum float-array>vector ;\r
+\r
+M: float-vector equal?\r
+ over float-vector? [ sequence= ] [ 2drop f ] if ;\r
+\r
+M: float-array new-resizable drop <float-vector> ;\r
+\r
+INSTANCE: float-vector growable\r
+\r
+: FV{ \ } [ >float-vector ] parse-literal ; parsing\r
+\r
+M: float-vector >pprint-sequence ;\r
+\r
+M: float-vector pprint-delims drop \ FV{ \ } ;\r
--- /dev/null
+Growable float arrays
--- /dev/null
+collections
: funny-dip '[ @ _ ] call ; inline
[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
+
+[ { 1 2 3 } ] [
+ 3 1 '[ , [ , + ] map ] call
+] unit-test
: @ "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
-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
[ <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 ;
-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
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 )
<int> dupd GetUserName zero? [
free win32-error f
] [
- [ alien>u16-string ] keep free
+ pull-win32-string
] if ;
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 ;
: 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 ;
{ $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" }
{ $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
\ $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 ;
"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
[ "/" "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
port: 80
version: "1.1"
cookies: V{ }
- header: H{ }
+ header: H{ { "connection" "close" } }
}
] [
[
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
: 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
] 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 ;
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 ;
[ "/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
cookies: V{ }
}
] [
- read-request-test-1 [
+ read-request-test-1 lf>crlf [
read-request
] with-string-reader
] unit-test
;
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
STRING: read-request-test-2
HEAD http://foo/bar HTTP/1.1
Host: www.sex.com
+
;
[
cookies: V{ }
}
] [
- read-request-test-2 [
+ read-request-test-2 lf>crlf [
read-request
] with-string-reader
] unit-test
cookies: V{ }
}
] [
- read-response-test-1
+ read-response-test-1 lf>crlf
[ read-response ] with-string-reader
] unit-test
;
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
<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
"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
! 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
#! 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
] 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 )
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 ;
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 ;
"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*
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 -- )
: <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
>>code ;
: read-response-message
- readln >>message ;
+ read-crlf >>message ;
: read-response-header
read-header >>header
[ 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
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
{ { "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
;
[ 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
;
[ "/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
--- /dev/null
+<?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>
+++ /dev/null
-<% USING: http.server.components http.server.auth.login\r
-http.server namespaces kernel combinators ; %>\r
-<html>\r
-<body>\r
-<h1>Edit profile</h1>\r
-\r
-<form method="POST" action="edit-profile">\r
-<% hidden-form-field %>\r
-\r
-<table>\r
-\r
-<tr>\r
-<td>User name:</td>\r
-<td><% "username" component render-view %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Real name:</td>\r
-<td><% "realname" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Specifying a real name is optional.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Current password:</td>\r
-<td><% "password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>If you don't want to change your current password, leave this field blank.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>New password:</td>\r
-<td><% "new-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Verify:</td>\r
-<td><% "verify-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>If you are changing your password, enter it twice to ensure it is correct.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>E-mail:</td>\r
-<td><% "email" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>\r
-</tr>\r
-\r
-</table>\r
-\r
-<p><input type="submit" value="Update" />\r
-\r
-<% {\r
- { [ login-failed? get ] [ "invalid password" render-error ] }\r
- { [ password-mismatch? get ] [ "passwords do not match" render-error ] }\r
- { [ t ] [ ] }\r
-} cond %>\r
-\r
-</p>\r
-\r
-</form>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?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>
http.server.components\r
http.server.forms\r
http.server.sessions\r
-http.server.templating.fhtml\r
+http.server.boilerplate\r
+http.server.templating\r
+http.server.templating.chloe\r
http.server.validators ;\r
IN: http.server.auth.login\r
QUALIFIED: smtp\r
: save-user-after ( user -- )\r
<user-saver> add-always-destructor ;\r
\r
+: login-template ( name -- template )\r
+ "resource:extra/http/server/auth/login/" swap ".xml"\r
+ 3append <chloe> ;\r
+\r
! ! ! Login\r
\r
: <login-form>\r
"login" <form>\r
- "resource:extra/http/server/auth/login/login.fhtml" >>edit-template\r
+ "login" login-template >>edit-template\r
"username" <username>\r
t >>required\r
add-field\r
<action>\r
[ blank-values ] >>init\r
\r
- [\r
- "text/html" <content>\r
- [ form edit-form ] >>body\r
- ] >>display\r
+ [ form edit-form ] >>display\r
\r
[\r
blank-values\r
\r
: <register-form> ( -- form )\r
"register" <form>\r
- "resource:extra/http/server/auth/login/register.fhtml" >>edit-template\r
+ "register" login-template >>edit-template\r
"username" <username>\r
t >>required\r
add-field\r
<action>\r
[ blank-values ] >>init\r
\r
- [\r
- "text/html" <content>\r
- [ form edit-form ] >>body\r
- ] >>display\r
+ [ form edit-form ] >>display\r
\r
[\r
blank-values\r
\r
: <edit-profile-form> ( -- form )\r
"edit-profile" <form>\r
- "resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template\r
+ "edit-profile" login-template >>edit-template\r
"username" <username> add-field\r
"realname" <string> add-field\r
"password" <password> add-field\r
dup email>> "email" set-value\r
] >>init\r
\r
- [\r
- "text/html" <content>\r
- [ form edit-form ] >>body\r
- ] >>display\r
+ [ form edit-form ] >>display\r
\r
[\r
blank-values\r
\r
: <recover-form-1> ( -- form )\r
"register" <form>\r
- "resource:extra/http/server/auth/login/recover-1.fhtml" >>edit-template\r
+ "recover-1" login-template >>edit-template\r
"username" <username>\r
t >>required\r
add-field\r
<action>\r
[ blank-values ] >>init\r
\r
- [\r
- "text/html" <content>\r
- [ form edit-form ] >>body\r
- ] >>display\r
+ [ form edit-form ] >>display\r
\r
[\r
blank-values\r
send-password-email\r
] when*\r
\r
- "resource:extra/http/server/auth/login/recover-2.fhtml" serve-template\r
+ "recover-2" login-template serve-template\r
] >>submit\r
] ;\r
\r
: <recover-form-3>\r
"new-password" <form>\r
- "resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template\r
+ "recover-3" login-template >>edit-template\r
"username" <username>\r
hidden >>renderer\r
t >>required\r
] H{ } make-assoc values set\r
] >>init\r
\r
- [\r
- "text/html" <content>\r
- [ <recover-form-3> edit-form ] >>body\r
- ] >>display\r
+ [ <recover-form-3> edit-form ] >>display\r
\r
[\r
blank-values\r
"new-password" value >>password\r
users update-user\r
\r
- "resource:extra/http/server/auth/login/recover-4.fhtml"\r
- serve-template\r
+ "recover-4" login-template serve-template\r
] [\r
<400>\r
] if*\r
dup login set\r
call-next-method ;\r
\r
+: <login-boilerplate> ( responder -- responder' )\r
+ <boilerplate>\r
+ "boilerplate" login-template >>template ;\r
+\r
: <login> ( responder -- auth )\r
login new-dispatcher\r
- swap <protected> >>default\r
- <login-action> "login" add-responder\r
- <logout-action> "logout" add-responder\r
+ swap >>default\r
+ <login-action> <login-boilerplate> "login" add-responder\r
+ <logout-action> <login-boilerplate> "logout" add-responder\r
no-users >>users ;\r
\r
! ! ! Configuration\r
\r
: allow-edit-profile ( login -- login )\r
- <edit-profile-action> <protected> "edit-profile" add-responder ;\r
+ <edit-profile-action> <protected> <login-boilerplate>\r
+ "edit-profile" add-responder ;\r
\r
: allow-registration ( login -- login )\r
- <register-action> "register" add-responder ;\r
+ <register-action> <login-boilerplate>\r
+ "register" add-responder ;\r
\r
: allow-password-recovery ( login -- login )\r
- <recover-action-1> "recover-password" add-responder\r
- <recover-action-3> "new-password" add-responder ;\r
+ <recover-action-1> <login-boilerplate>\r
+ "recover-password" add-responder\r
+ <recover-action-3> <login-boilerplate>\r
+ "new-password" add-responder ;\r
\r
: allow-edit-profile? ( -- ? )\r
login get responders>> "edit-profile" swap key? ;\r
+++ /dev/null
-<% USING: http.server.auth.login http.server.components http.server\r
-kernel namespaces ; %>\r
-<html>\r
-<body>\r
-<h1>Login required</h1>\r
-\r
-<form method="POST" action="login">\r
-\r
-<% hidden-form-field %>\r
-\r
-<table>\r
-\r
-<tr>\r
-<td>User name:</td>\r
-<td><% "username" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Password:</td>\r
-<td><% "password" component render-edit %></td>\r
-</tr>\r
-\r
-</table>\r
-\r
-<p><input type="submit" value="Log in" />\r
-<%\r
-login-failed? get\r
-[ "Invalid username or password" render-error ] when\r
-%>\r
-</p>\r
-\r
-</form>\r
-\r
-<p>\r
-<% allow-registration? [ %>\r
- <a href="<% "register" f write-link %>">Register</a>\r
-<% ] when %>\r
-<% allow-password-recovery? [ %>\r
- <a href="<% "recover-password" f write-link %>">\r
- Recover Password\r
- </a>\r
-<% ] when %>\r
-</p>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?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>
+++ /dev/null
-<% USING: http.server.components http.server ; %>\r
-<html>\r
-<body>\r
-<h1>Recover lost password: step 1 of 4</h1>\r
-\r
-<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>\r
-\r
-<form method="POST" action="recover-password">\r
-\r
-<% hidden-form-field %>\r
-\r
-<table>\r
-\r
-<tr>\r
-<td>User name:</td>\r
-<td><% "username" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>E-mail:</td>\r
-<td><% "email" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Captcha:</td>\r
-<td><% "captcha" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>\r
-</tr>\r
-\r
-</table>\r
-\r
-<input type="submit" value="Recover password" />\r
-\r
-</form>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?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>
+++ /dev/null
-<% USING: http.server.components ; %>\r
-<html>\r
-<body>\r
-<h1>Recover lost password: step 2 of 4</h1>\r
-\r
-<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>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?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>
+++ /dev/null
-<% USING: http.server.components http.server.auth.login http.server\r
-namespaces kernel combinators ; %>\r
-<html>\r
-<body>\r
-<h1>Recover lost password: step 3 of 4</h1>\r
-\r
-<p>Choose a new password for your account.</p>\r
-\r
-<form method="POST" action="new-password">\r
-\r
-<% hidden-form-field %>\r
-\r
-<table>\r
-\r
-<% "username" component render-edit %>\r
-<% "ticket" component render-edit %>\r
-\r
-<tr>\r
-<td>Password:</td>\r
-<td><% "new-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Verify password:</td>\r
-<td><% "verify-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Enter your password twice to ensure it is correct.</td>\r
-</tr>\r
-\r
-</table>\r
-\r
-<p><input type="submit" value="Set password" />\r
-\r
-<% password-mismatch? get [\r
- "passwords do not match" render-error\r
-] when %>\r
-\r
-</p>\r
-\r
-</form>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?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>
+++ /dev/null
-<% USING: http.server ; %>\r
-<html>\r
-<body>\r
-<h1>Recover lost password: step 4 of 4</h1>\r
-\r
-<p>Your password has been reset.\r
-You may now <a href="<% "login" f write-link %>">log in</a>.</p>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?xml version='1.0' ?>\r
+\r
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">\r
+\r
+ <t:title>Recover lost password: step 4 of 4</t:title>\r
+\r
+ <p>Your password has been reset. You may now <t:a href="login">log in</t:a>.</p>\r
+\r
+</t:chloe>\r
+++ /dev/null
-<% USING: http.server.components http.server.auth.login\r
-http.server namespaces kernel combinators ; %>\r
-<html>\r
-<body>\r
-<h1>New user registration</h1>\r
-\r
-<form method="POST" action="register">\r
-<% hidden-form-field %>\r
-\r
-<table>\r
-\r
-<tr>\r
-<td>User name:</td>\r
-<td><% "username" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Real name:</td>\r
-<td><% "realname" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Specifying a real name is optional.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Password:</td>\r
-<td><% "new-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Verify:</td>\r
-<td><% "verify-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Enter your password twice to ensure it is correct.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>E-mail:</td>\r
-<td><% "email" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Captcha:</td>\r
-<td><% "captcha" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>\r
-</tr>\r
-\r
-</table>\r
-\r
-<p><input type="submit" value="Register" />\r
-\r
-<% {\r
- { [ password-mismatch? get ] [ "passwords do not match" render-error ] }\r
- { [ user-exists? get ] [ "username taken" render-error ] }\r
- { [ t ] [ ] }\r
-} cond %>\r
-\r
-</p>\r
-\r
-</form>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?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>
--- /dev/null
+! 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 ;
IN: http.server.components.tests\r
USING: http.server.components http.server.forms\r
http.server.validators namespaces tools.test kernel accessors\r
-tuple-syntax mirrors http.server.actions\r
+tuple-syntax mirrors\r
+http http.server.actions http.server.templating.fhtml\r
io.streams.string io.streams.null ;\r
\r
-\ render-edit must-infer\r
-\r
validation-failed? off\r
\r
[ 3 ] [ "3" "n" <number> validate ] unit-test\r
\r
: <test-form> ( -- form )\r
"test" <form>\r
- "resource:extra/http/server/components/test/form.fhtml" >>view-template\r
- "resource:extra/http/server/components/test/form.fhtml" >>edit-template\r
+ "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>view-template\r
+ "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>edit-template\r
"text" <string>\r
t >>required\r
add-field\r
"hi" >>default\r
add-field ;\r
\r
-[ ] [ <test-tuple> <mirror> values set <test-form> view-form ] unit-test\r
+[ ] [ <test-tuple> <mirror> values set <test-form> view-form write-response-body drop ] unit-test\r
\r
-[ ] [ <test-tuple> <mirror> values set <test-form> edit-form ] unit-test\r
+[ ] [ <test-tuple> <mirror> values set <test-form> edit-form write-response-body drop ] unit-test\r
\r
[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [\r
<test-tuple> from-tuple\r
[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test\r
\r
[ ] [ "password" <password> "p" set ] unit-test\r
+\r
+[ ] [ "pub-date" <date> "d" set ] unit-test\r
! 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
: 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
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 ;
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 ;
http.server.components ;\r
IN: http.server.components.farkup\r
\r
-TUPLE: farkup-renderer < textarea-renderer ;\r
+TUPLE: farkup-renderer < text-renderer ;\r
\r
-: farkup-renderer T{ farkup-renderer } ;\r
+: <farkup-renderer> ( -- renderer )\r
+ farkup-renderer new-text-renderer ;\r
\r
M: farkup-renderer render-view*\r
drop string-lines "\n" join convert-farkup write ;\r
\r
: <farkup> ( id -- component )\r
<text>\r
- farkup-renderer >>renderer ;\r
+ <farkup-renderer> >>renderer ;\r
[ "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 )
+:: <edit-action> ( form ctor next -- action )
<action>
- [ f ctor call from-tuple form set-defaults ] >>init
+ { { "id" [ [ v-number ] v-optional ] } } >>get-params
[
- "text/html" <content>
- [ form edit-form ] >>body
- ] >>display
-
- [
- f ctor call from-tuple
+ "id" get ctor call
- form validate-form
-
- values-tuple insert-tuple
+ "id" get
+ [ select-tuple from-tuple ]
+ [ from-tuple form set-defaults ]
+ if
+ ] >>init
- "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
-
- [
- "text/html" <content>
- [ form edit-form ] >>body
- ] >>display
+ [ 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 ;
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 ;
-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 -- )
[
] 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* ;
+
+: view-form ( form -- response )
+ dup view-template>> <form-response> ;
-: edit-form ( form -- )
- dup edit-template>> '[ , run-template ] with-form ;
+: edit-form ( form -- response )
+ dup edit-template>> <form-response> ;
: validate-param ( id component -- )
[ [ params get at ] [ validate ] bi* ]
: 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 ;
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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ Hello world
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:title>Hello world</t:title>
+ Blah blah
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:title>Hello world</t:title>
+</t:chloe>
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+<?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>
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 = ;
! 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" ;
: 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+
] 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
--- /dev/null
+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 ;
[ "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
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 ? ;
: 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
: 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 )
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-UTF16 encoding/decoding
+++ /dev/null
-USING: help.markup help.syntax io.encodings strings ;
-IN: io.encodings.utf16
-
-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 } ;
-
-ABOUT: "io.encodings.utf16"
-
-HELP: utf16le
-{ $class-description "The encoding descriptor for UTF-16LE, that is, UTF-16 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: utf16be
-{ $class-description "The encoding descriptor for UTF-16BE, that is, UTF-16 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
-{ $see-also "encodings-introduction" } ;
-
-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
+++ /dev/null
-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 ;
-IN: io.encodings.utf16.tests
-
-[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test
-[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test
-
-[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode >array ] unit-test
-
-[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode >array ] unit-test
-[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test
-[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
-
-[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test
-
-[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test
-[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test
-
-[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test
-
-: correct-endian
- code>> class little-endian? [ utf16le = ] [ utf16be = ] if ;
-
-[ t ] [ B{ } utf16n <byte-reader> correct-endian ] unit-test
-[ t ] [ utf16n <byte-writer> correct-endian ] unit-test
+++ /dev/null
-! 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 ;
-IN: io.encodings.utf16
-
-TUPLE: utf16be ;
-
-TUPLE: utf16le ;
-
-TUPLE: utf16 ;
-
-TUPLE: utf16n ;
-
-<PRIVATE
-
-! UTF-16BE decoding
-
-: append-nums ( byte ch -- ch )
- over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
-
-: double-be ( stream byte -- stream char )
- over stream-read1 swap append-nums ;
-
-: quad-be ( stream byte -- stream char )
- double-be over stream-read1 [
- dup -2 shift BIN: 110111 number= [
- >r 2 shift r> BIN: 11 bitand bitor
- over stream-read1 swap append-nums HEX: 10000 +
- ] [ 2drop dup stream-read1 drop replacement-char ] if
- ] when* ;
-
-: ignore ( stream -- stream char )
- dup stream-read1 drop replacement-char ;
-
-: begin-utf16be ( stream byte -- stream char )
- dup -3 shift BIN: 11011 number= [
- dup BIN: 00000100 bitand zero?
- [ BIN: 11 bitand quad-be ]
- [ drop ignore ] if
- ] [ double-be ] if ;
-
-M: utf16be decode-char
- drop dup stream-read1 dup [ begin-utf16be ] when nip ;
-
-! UTF-16LE decoding
-
-: quad-le ( stream ch -- stream char )
- over stream-read1 swap 10 shift bitor
- over stream-read1 dup -2 shift BIN: 110111 = [
- BIN: 11 bitand append-nums HEX: 10000 +
- ] [ 2drop replacement-char ] if ;
-
-: double-le ( stream byte1 byte2 -- stream char )
- dup -3 shift BIN: 11011 = [
- dup BIN: 100 bitand 0 number=
- [ BIN: 11 bitand 8 shift bitor quad-le ]
- [ 2drop replacement-char ] if
- ] [ append-nums ] if ;
-
-: begin-utf16le ( stream byte -- stream char )
- over stream-read1 [ double-le ] [ drop replacement-char ] if* ;
-
-M: utf16le decode-char
- drop dup stream-read1 dup [ begin-utf16le ] when nip ;
-
-! UTF-16LE/BE encoding
-
-: encode-first ( char -- byte1 byte2 )
- -10 shift
- dup -8 shift BIN: 11011000 bitor
- swap HEX: FF bitand ;
-
-: encode-second ( char -- byte3 byte4 )
- BIN: 1111111111 bitand
- dup -8 shift BIN: 11011100 bitor
- swap BIN: 11111111 bitand ;
-
-: stream-write2 ( stream char1 char2 -- )
- rot [ stream-write1 ] curry bi@ ;
-
-: char>utf16be ( stream char -- )
- dup HEX: FFFF > [
- HEX: 10000 -
- 2dup encode-first stream-write2
- encode-second stream-write2
- ] [ h>b/b swap stream-write2 ] if ;
-
-M: utf16be encode-char ( char stream encoding -- )
- drop swap char>utf16be ;
-
-: char>utf16le ( char stream -- )
- dup HEX: FFFF > [
- HEX: 10000 -
- 2dup encode-first swap stream-write2
- encode-second swap stream-write2
- ] [ h>b/b stream-write2 ] if ;
-
-M: utf16le encode-char ( char stream encoding -- )
- drop swap char>utf16le ;
-
-! UTF-16
-
-: bom-le B{ HEX: ff HEX: fe } ; inline
-
-: bom-be B{ HEX: fe HEX: ff } ; inline
-
-: start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
-
-: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
-
-TUPLE: missing-bom ;
-M: missing-bom summary drop "The BOM for a UTF-16 stream was missing" ;
-
-: bom>le/be ( bom -- le/be )
- dup bom-le sequence= [ drop utf16le ] [
- bom-be sequence= [ utf16be ] [ missing-bom ] if
- ] if ;
-
-M: utf16 <decoder> ( stream utf16 -- decoder )
- drop 2 over stream-read bom>le/be <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>
{ $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." } ;
"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 } ;
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?
[ ] [ "m" get dispose ] unit-test
] with-monitors
-
[
[ "monitor-test" temp-file delete-tree ] ignore-errors
[ ] [ "m" get dispose ] unit-test
] with-monitors
+
+ ! Out-of-scope disposal should not fail
+ [ "" resource-path t <monitor> ] with-monitors dispose
] when
! 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' )
: 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>> [
-! 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
<< {
M: object host-name ( -- name )
256 <byte-array> dup dup length gethostname
zero? [ "gethostname failed" throw ] unless
- alien>char-string ;
+ ascii alien>string ;
! 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 ;
+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 ;
-SYMBOL: watches
-
-SYMBOL: inotify
-
: wd>monitor ( wd -- monitor ) watches get at ;
: <inotify> ( -- port/f )
] 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 -- ? )
{
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 ;
! 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 -- )
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 -- )
] if ;
! Server sockets - TCP and Unix domain
-USE: unix
-
: init-server-socket ( fd -- )
SOL_SOCKET SO_REUSEADDR sockopt ;
: 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
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> ;
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 ;
--- /dev/null
+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
--- /dev/null
+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
+>>
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
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
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 )
- nip <reversed> [ load-local ] map concat ;
+: load-locals-quot ( args -- quot )
+ dup [ local-reader? ] contains? [
+ <reversed> [
+ local-reader? [ 1array >r ] [ >r ] ?
+ ] map concat
+ ] [
+ length [ load-locals ] curry >quotation
+ ] if ;
-: 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 -- )
+
+: free-vars ( form -- vars )
+ [ free-vars* ] { } make prune ;
-: add-if-free ( vars object -- vars )
+: 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 -- )
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
M: object local-rewrite* , ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: make-local ( name -- word )
"!" ?tail [
<local-reader>
! 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 ;
{ $subsection gcd }
{ $subsection log2 }
{ $subsection next-power-of-2 }
+"Modular exponentiation:"
+{ $subsection ^mod }
+{ $subsection mod-inv }
"Tests:"
{ $subsection power-of-2? }
{ $subsection even? }
{ $subsection ceiling }
{ $subsection floor }
{ $subsection truncate }
-{ $subsection round } ;
+{ $subsection round }
+"Inexact comparison:"
+{ $subsection ~ } ;
ARTICLE: "power-functions" "Powers and logarithms"
"Squares:"
{ $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" } "." }
[ 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
[ ~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
! 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 )
-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 ;
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
: [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 ;
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) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: 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
! 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
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
: 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
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
: 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 ] }
: 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>
! 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
: 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 )
: 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 )
-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)
! 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
!
! 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
: 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 ;
! =========================================================
! 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
: 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 -- )
{
: 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 ;
! =========================================================
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 ( -- )
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 )
: 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
: 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 ;
--- /dev/null
+! 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) ;
--- /dev/null
+! 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) ;
--- /dev/null
+! 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) ;
--- /dev/null
+! 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) ;
--- /dev/null
+! 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) ;
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ;
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*
: 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 ;
[ 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
} 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
-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
"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
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 ;
[ "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 )
[ "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
[ 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
{ "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 -- )
"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, ;
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 ;
: 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@
[
#! 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 -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 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
>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
--- /dev/null
+
+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
--- /dev/null
+
+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
! 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
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
$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
! 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
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
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 ;
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 -- )
[ 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 ;
--- /dev/null
+James Cash
--- /dev/null
+Deploying minimal stand-alone binaries on *nix-like systems
--- /dev/null
+! 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
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 [
[ 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 ;
>n ndrop >c c>
continue continue-with
stop yield suspend sleep (spawn)
- suspend
} [
dup [ execute break ] curry
"step-into" set-word-prop
{ +name+ "FactorView" }
{ +protocols+ { "NSTextInput" } }
}
+
+! Rendering
+! Rendering
+{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
+ [ 3drop window relayout-1 ]
+}
+
! Events
{ "acceptsFirstMouse:" "bool" { "id" "SEL" "id" }
[ 3drop 1 ]
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
! 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? ;
-! 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 ;
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>> ;
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 [
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 ;
: <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
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 -- )
IN: ui.tools.walker\r
USING: help.markup help.syntax ui.commands ui.operations\r
-tools.walker ;\r
+ui.render tools.walker sequences ;\r
+\r
+ARTICLE: "ui-walker-step" "Stepping through code"\r
+"If the current position points to a word, the various stepping commands behave as follows:"\r
+{ $list\r
+ { { $link com-step } " executes the word and moves the current position one word further." }\r
+ { { $link com-into } " enters the word's definition, unless it is a primitive, in which case it behaves like " { $link com-step } "." }\r
+ { { $link com-out } " executes until the end of the current quotation." }\r
+}\r
+"If the current position points to a literal, the various stepping commands behave as follows:"\r
+{ $list\r
+ { { $link com-step } " pushes the literal on the data stack." }\r
+ { { $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." }\r
+ { { $link com-out } " executes until the end of the current quotation." }\r
+}\r
+"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:"\r
+{ $code "{ 10 20 30 } [ 3 + . ] each" }\r
+"If the current position is on the quotation and " { $link com-into } " is invoked, the following quotation is pushed on the stack:"\r
+{ $code "[ break 3 + . ]" }\r
+"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."\r
+$nl\r
+"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." ;\r
+\r
+ARTICLE: "breakpoints" "Setting breakpoints"\r
+"In addition to invoking the walker explicitly through the UI, it is possible to set breakpoints on words. See " { $link "tools.annotations" } "."\r
+$nl\r
+"Breakpoints can be inserted directly into code:"\r
+{ $subsection break }\r
+"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." ;\r
\r
ARTICLE: "ui-walker" "UI walker"\r
"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 } "."\r
$nl\r
-"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."\r
-{ $command-map walker-gadget "toolbar" }\r
-"Walkers are instances of " { $link walker-gadget } "." ;\r
+"Walkers are instances of " { $link walker-gadget } "."\r
+{ $subsection "ui-walker-step" }\r
+{ $subsection "breakpoints" }\r
+{ $command-map walker-gadget "toolbar" } ;\r
+\r
+ABOUT: "ui-walker"\r
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 ;
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 -- )
! 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
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
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
: 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 ;
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 ;
! 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
} 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
: 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 ;
: 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 ;
: 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 ;
: 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 ;
: 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 ;
: 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
-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
! 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 ;
--- /dev/null
+
+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
--- /dev/null
+! 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 ;
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+Slava Pestov
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+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;
+}
--- /dev/null
+! 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 ;
--- /dev/null
+<?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>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:summary component="postings" />
+
+</t:chloe>
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+.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;
+}
--- /dev/null
+! 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 ;
--- /dev/null
+<?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>
--- /dev/null
+<?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>
-USING: alien alien.syntax alien.c-types math kernel sequences\r
-windows windows.types combinators.lib ;\r
+USING: alien alien.syntax alien.c-types alien.strings math\r
+kernel sequences windows windows.types combinators.lib ;\r
IN: windows.ole32\r
\r
LIBRARY: ole32\r
\r
TYPEDEF: void* REFGUID\r
TYPEDEF: void* LPUNKNOWN\r
-TYPEDEF: ushort* LPOLESTR\r
-TYPEDEF: ushort* LPCOLESTR\r
+TYPEDEF: wchar_t* LPOLESTR\r
+TYPEDEF: wchar_t* LPCOLESTR\r
\r
TYPEDEF: REFGUID REFIID\r
TYPEDEF: REFGUID REFCLSID\r
"{01234567-89ab-cdef-0123-456789abcdef}" length ; inline\r
\r
: string>guid ( string -- guid )\r
- string>u16-alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;\r
+ utf16n string>alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;\r
: guid>string ( guid -- string )\r
GUID-STRING-LENGTH 1+ [ "ushort" <c-array> ] keep\r
- [ StringFromGUID2 drop ] { 2 } multikeep alien>u16-string ;\r
+ [ StringFromGUID2 drop ] { 2 } multikeep utf16n alien>string ;\r
\r
-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
: 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
: 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 ;
TYPEDEF: WCHAR TCHAR
TYPEDEF: TCHAR TBYTE
-! TYPEDEF: uchar* LPCSTR
-TYPEDEF: ushort* LPCSTR
-TYPEDEF: ushort* LPWSTR
+TYPEDEF: wchar_t* LPCSTR
+TYPEDEF: wchar_t* LPWSTR
! 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
! 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
: (win32-error-string) ( n -- string )
error_message
- dup alien>u16-string
+ dup utf16n alien>string
swap LocalFree drop ;
: win32-error-string ( -- str )
: 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 = [
! 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
: (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) ;
-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
<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
<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
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 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
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
! 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
: 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 ;
! Copyright (C) 2005, 2006 Daniel Ehrenberg\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: hashtables kernel math namespaces sequences strings\r
-io io.streams.string xml.data assocs wrap xml.entities\r
-unicode.categories ;\r
+assocs combinators io io.streams.string\r
+xml.data wrap xml.entities unicode.categories ;\r
IN: xml.writer\r
\r
SYMBOL: xml-pprint?\r
?indent CHAR: < write1\r
dup print-name tag-attrs print-attrs ;\r
\r
+: write-start-tag ( tag -- )\r
+ write-tag ">" write ;\r
+\r
M: contained-tag write-item\r
write-tag "/>" write ;\r
\r
?indent "</" write print-name CHAR: > write1 ;\r
\r
M: open-tag write-item\r
- xml-pprint? [ [\r
- over sensitive? not and xml-pprint? set\r
- dup write-tag CHAR: > write1\r
- dup write-children write-end-tag\r
- ] keep ] change ;\r
+ xml-pprint? get >r\r
+ {\r
+ [ sensitive? not xml-pprint? get and xml-pprint? set ]\r
+ [ write-start-tag ]\r
+ [ write-children ]\r
+ [ write-end-tag ]\r
+ } cleave\r
+ r> xml-pprint? set ;\r
\r
M: comment write-item\r
"<!--" write comment-text write "-->" write ;\r
[ write-item ] each ;\r
\r
: write-xml ( xml -- )\r
- dup xml-prolog write-prolog\r
- dup xml-before write-chunk\r
- dup write-item\r
- xml-after write-chunk ;\r
+ {\r
+ [ xml-prolog write-prolog ]\r
+ [ xml-before write-chunk ]\r
+ [ write-item ]\r
+ [ xml-after write-chunk ]\r
+ } cleave ;\r
\r
: print-xml ( xml -- )\r
write-xml nl ;\r
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
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);
}
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));
}
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);
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())
{
garbage_collection(TENURED,false,0);
}
+void minor_gc(void)
+{
+ garbage_collection(NURSERY,false,0);
+}
+
DEFINE_PRIMITIVE(gc)
{
gc();
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());
DECLARE_PRIMITIVE(end_scan);
void gc(void);
+DLLEXPORT void minor_gc(void);
/* generational copying GC divides memory into zones */
typedef struct {
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)
{
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);
{
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 */
CELL collect_next(CELL scan);
-DLLEXPORT void simple_gc(void);
-
DECLARE_PRIMITIVE(gc);
DECLARE_PRIMITIVE(gc_time);
DECLARE_PRIMITIVE(become);
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]);
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);
{
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;
+}
+
+
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);
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
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
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
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,
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)
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);
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);
projects / factor.git / commitdiff