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

Merge branch 'master' into unicode 

Conflicts:

	core/io/encodings/utf16/utf16-tests.factor
	core/io/encodings/utf16/utf16.factor
	core/io/encodings/utf8/utf8-tests.factor
db4
Daniel Ehrenberg 2008-02-15 20:12:38 -06:00
parent 4678da8861 900e82b552
commit 2a2d7cf04e
89 changed files with 1643 additions and 1061 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -326,7 +326,7 @@ M: alien-callback-error summary
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ; drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
: callback-bottom ( node -- ) : callback-bottom ( node -- )
alien-callback-xt [ word-xt <alien> ] curry alien-callback-xt [ word-xt drop <alien> ] curry
recursive-state get infer-quot ; recursive-state get infer-quot ;
\ alien-callback [ \ alien-callback [

24
core/alien/structs/structs-tests.factor
View File

@ -9,18 +9,20 @@ C-STRUCT: bar
[ 36 ] [ "bar" heap-size ] unit-test [ 36 ] [ "bar" heap-size ] unit-test
[ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test [ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
C-STRUCT: align-test ! This was actually only correct on Windows/x86:
{ "int" "x" }
{ "double" "y" } ;
[ 16 ] [ "align-test" heap-size ] unit-test ! C-STRUCT: align-test
! { "int" "x" }
cell 4 = [ ! { "double" "y" } ;
C-STRUCT: one !
{ "long" "a" } { "double" "b" } { "int" "c" } ; ! [ 16 ] [ "align-test" heap-size ] unit-test
!
[ 24 ] [ "one" heap-size ] unit-test ! cell 4 = [
] when ! C-STRUCT: one
! { "long" "a" } { "double" "b" } { "int" "c" } ;
!
! [ 24 ] [ "one" heap-size ] unit-test
! ] when
: MAX_FOOS 30 ; : MAX_FOOS 30 ;

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

@ -59,6 +59,7 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
{ $subsection diff } { $subsection diff }
{ $subsection remove-all } { $subsection remove-all }
{ $subsection substitute } { $subsection substitute }
{ $subsection substitute-here }
{ $see-also key? } ; { $see-also key? } ;
ARTICLE: "assocs-mutation" "Storing keys and values in assocs" ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
@ -266,12 +267,16 @@ HELP: remove-all
{ $notes "The values of the keys in the assoc are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." } { $notes "The values of the keys in the assoc are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." }
{ $side-effects "assoc" } ; { $side-effects "assoc" } ;
HELP: substitute HELP: substitute-here
{ $values { "assoc" assoc } { "seq" "a mutable sequence" } } { $values { "seq" "a mutable sequence" } { "assoc" assoc } }
{ $description "Replaces elements of " { $snippet "seq" } " which appear in as keys in " { $snippet "assoc" } " with the corresponding values, acting as the identity on all other elements." } { $description "Replaces elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " with the corresponding values, acting as the identity on all other elements." }
{ $errors "Throws an error if " { $snippet "assoc" } " contains values whose types are not permissible in " { $snippet "seq" } "." } { $errors "Throws an error if " { $snippet "assoc" } " contains values whose types are not permissible in " { $snippet "seq" } "." }
{ $side-effects "seq" } ; { $side-effects "seq" } ;
HELP: substitute
{ $values { "seq" sequence } { "assoc" assoc } { "newseq" sequence } }
{ $description "Creates a new sequence where elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " are replaced by the corresponding values, and all other elements are unchanged." } ;
HELP: cache HELP: cache
{ $values { "key" "a key" } { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } } { $values { "key" "a key" } { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
{ $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc." } { $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc." }

10
core/assocs/assocs.factor
View File

@ -124,8 +124,14 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: remove-all ( assoc seq -- subseq ) : remove-all ( assoc seq -- subseq )
swap [ key? not ] curry subset ; swap [ key? not ] curry subset ;
: substitute ( assoc seq -- ) : (substitute)
swap [ dupd at* [ nip ] [ drop ] if ] curry change-each ; [ dupd at* [ nip ] [ drop ] if ] curry ; inline
: substitute-here ( seq assoc -- )
(substitute) change-each ;
: substitute ( seq assoc -- newseq )
(substitute) map ;
: cache ( key assoc quot -- value ) : cache ( key assoc quot -- value )
2over at [ 2over at [

2
core/bootstrap/stage2.factor
View File

@ -59,7 +59,7 @@ SYMBOL: bootstrap-time
default-image-name "output-image" set-global default-image-name "output-image" set-global
"math help compiler tools ui ui.tools io" "include" set-global "math help handbook compiler tools ui ui.tools io" "include" set-global
"" "exclude" set-global "" "exclude" set-global
parse-command-line parse-command-line

22
core/combinators/combinators-docs.factor
View File

@ -7,11 +7,7 @@ ARTICLE: "combinators-quot" "Quotation construction utilities"
"Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:" "Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:"
{ $subsection cond>quot } { $subsection cond>quot }
{ $subsection case>quot } { $subsection case>quot }
{ $subsection alist>quot } { $subsection alist>quot } ;
"A powerful tool used to optimize code in several places is open-coded hashtable dispatch:"
{ $subsection hash-case>quot }
{ $subsection distribute-buckets }
{ $subsection hash-dispatch-quot } ;
ARTICLE: "combinators" "Additional combinators" ARTICLE: "combinators" "Additional combinators"
"The " { $vocab-link "combinators" } " vocabulary is usually used because it provides two combinators which abstract out nested chains of " { $link if } ":" "The " { $vocab-link "combinators" } " vocabulary is usually used because it provides two combinators which abstract out nested chains of " { $link if } ":"
@ -104,19 +100,17 @@ HELP: case>quot
{ $values { "assoc" "a sequence of pairs of quotations" } { "default" quotation } { "quot" quotation } } { $values { "assoc" "a sequence of pairs of quotations" } { "default" quotation } { "quot" quotation } }
{ $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "." { $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "."
$nl $nl
"The quotation actually tests each possible case in order;" { $link hash-case>quot } " produces more efficient code." } ; "This word uses three strategies:"
{ $list
"If the assoc only has a few keys, a linear search is generated."
{ "If the assoc has a large number of keys which form a contiguous range of integers, a direct dispatch is generated using the " { $link dispatch } " word together with a bounds check." }
"Otherwise, an open-coded hashtable dispatch is generated."
} } ;
HELP: distribute-buckets HELP: distribute-buckets
{ $values { "assoc" "an alist" } { "initial" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- assoc )" } } { "buckets" "a new array" } } { $values { "assoc" "an alist" } { "initial" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- assoc )" } } { "buckets" "a new array" } }
{ $description "Sorts the entries of " { $snippet "assoc" } " into buckets, using the quotation to yield a set of keys for each entry. The hashcode of each key is computed, and the entry is placed in all corresponding buckets. Each bucket is initially cloned from " { $snippet "initial" } "; this should either be an empty vector or a one-element vector containing a pair." } { $description "Sorts the entries of " { $snippet "assoc" } " into buckets, using the quotation to yield a set of keys for each entry. The hashcode of each key is computed, and the entry is placed in all corresponding buckets. Each bucket is initially cloned from " { $snippet "initial" } "; this should either be an empty vector or a one-element vector containing a pair." }
{ $notes "This word is used in the implemention of " { $link hash-case>quot } " and " { $link standard-combination } "." } ; { $notes "This word is used in the implemention of " { $link hash-case-quot } " and " { $link standard-combination } "." } ;
HELP: hash-case>quot
{ $values { "default" quotation } { "assoc" "an association list mapping quotations to quotations" } { "quot" quotation } }
{ $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "."
$nl
"The quotation uses an efficient hash-based search to avoid testing the object against all possible keys." }
{ $notes "This word is used behind the scenes to compile " { $link case } " forms efficiently; it can also be called directly, which is useful for meta-programming." } ;
HELP: dispatch ( n array -- ) HELP: dispatch ( n array -- )
{ $values { "n" "a fixnum" } { "array" "an array of quotations" } } { $values { "n" "a fixnum" } { "array" "an array of quotations" } }

7
core/combinators/combinators-tests.factor Normal file → Executable file
View File

@ -69,3 +69,10 @@ namespaces combinators words ;
! Interpreted ! Interpreted
[ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test [ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test
[ 1 3 t ] [ { 1 3 2 } contiguous-range? ] unit-test
[ f ] [ { 1 2 2 4 } contiguous-range? 2nip ] unit-test
[ f ] [ { + 3 2 } contiguous-range? 2nip ] unit-test
[ f ] [ { 1 0 7 } contiguous-range? 2nip ] unit-test
[ f ] [ { 1 1 3 7 } contiguous-range? 2nip ] unit-test
[ 4 8 t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test

55
core/combinators/combinators.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: combinators IN: combinators
USING: arrays sequences sequences.private math.private USING: arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors ; kernel kernel.private math assocs quotations vectors
hashtables sorting ;
TUPLE: no-cond ; TUPLE: no-cond ;
@ -31,16 +32,24 @@ TUPLE: no-case ;
: recursive-hashcode ( n obj quot -- code ) : recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
! These go here, not in sequences and hashtables, since those
! two depend on combinators
M: sequence hashcode* M: sequence hashcode*
[ sequence-hashcode ] recursive-hashcode ; [ sequence-hashcode ] recursive-hashcode ;
M: hashtable hashcode*
[
dup assoc-size 1 number=
[ assoc-hashcode ] [ nip assoc-size ] if
] recursive-hashcode ;
: alist>quot ( default assoc -- quot ) : alist>quot ( default assoc -- quot )
[ rot \ if 3array append [ ] like ] assoc-each ; [ rot \ if 3array append [ ] like ] assoc-each ;
: cond>quot ( assoc -- quot ) : cond>quot ( assoc -- quot )
reverse [ no-cond ] swap alist>quot ; reverse [ no-cond ] swap alist>quot ;
: case>quot ( default assoc -- quot ) : linear-case-quot ( default assoc -- quot )
[ >r [ dupd = ] curry r> \ drop add* ] assoc-map [ >r [ dupd = ] curry r> \ drop add* ] assoc-map
alist>quot ; alist>quot ;
@ -63,20 +72,50 @@ M: sequence hashcode*
: hash-case-table ( default assoc -- array ) : hash-case-table ( default assoc -- array )
V{ } [ 1array ] distribute-buckets V{ } [ 1array ] distribute-buckets
[ case>quot ] with map ; [ linear-case-quot ] with map ;
: hash-dispatch-quot ( table -- quot ) : hash-dispatch-quot ( table -- quot )
[ length 1- [ fixnum-bitand ] curry ] keep [ length 1- [ fixnum-bitand ] curry ] keep
[ dispatch ] curry append ; [ dispatch ] curry append ;
: hash-case>quot ( default assoc -- quot ) : hash-case-quot ( default assoc -- quot )
hash-case-table hash-dispatch-quot
[ dup hashcode >fixnum ] swap append ;
: contiguous-range? ( keys -- from to ? )
dup [ fixnum? ] all? [
dup all-unique? [
dup infimum over supremum
[ - swap prune length + 1 = ] 2keep rot
] [
drop f f f
] if
] [
drop f f f
] if ;
: dispatch-case ( value from to default array -- )
>r >r 3dup between? [
drop - >fixnum r> drop r> dispatch
] [
2drop r> call r> drop
] if ; inline
: dispatch-case-quot ( default assoc from to -- quot )
-roll -roll sort-keys values [ >quotation ] map
[ dispatch-case ] 2curry 2curry ;
: case>quot ( default assoc -- quot )
dup empty? [ dup empty? [
drop drop
] [ ] [
dup length 4 <= [ dup length 4 <= [
case>quot linear-case-quot
] [ ] [
hash-case-table hash-dispatch-quot dup keys contiguous-range? [
[ dup hashcode >fixnum ] swap append dispatch-case-quot
] [
2drop hash-case-quot
] if
] if ] if
] if ; ] if ;

3
core/compiler/tests/simple.factor
View File

@ -227,3 +227,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
[ 3 ] [ t single-combination-test-2 ] unit-test [ 3 ] [ t single-combination-test-2 ] unit-test
[ 3 ] [ 3 single-combination-test-2 ] unit-test [ 3 ] [ 3 single-combination-test-2 ] unit-test
[ f ] [ f single-combination-test-2 ] unit-test [ f ] [ f single-combination-test-2 ] unit-test
! Regression
[ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test

17
core/compiler/tests/templates.factor
View File

@ -3,7 +3,7 @@ USING: arrays compiler kernel kernel.private math
hashtables.private math.private namespaces sequences hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private sequences.private tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts sequences.private byte-arrays alien alien.accessors layouts
words definitions compiler.units ; words definitions compiler.units io combinators ;
IN: temporary IN: temporary
! Oops! ! Oops!
@ -191,3 +191,18 @@ TUPLE: my-tuple ;
2 1 2 1
[ 2dup fixnum< [ >r die r> ] when ] compile-call [ 2dup fixnum< [ >r die r> ] when ] compile-call
] unit-test ] unit-test
! Regression
: a-dummy drop "hi" print ;
[ ] [
1 [
dup 0 2 3dup pick >= [ >= ] [ 2drop f ] if [
drop - >fixnum {
[ a-dummy ]
[ a-dummy ]
[ a-dummy ]
} dispatch
] [ 2drop no-case ] if
] compile-call
] unit-test

4
core/debugger/debugger-tests.factor Executable file
View File

@ -0,0 +1,4 @@
IN: temporary
USING: debugger kernel continuations tools.test ;
[ ] [ [ drop ] [ error. ] recover ] unit-test

40
core/generator/generator.factor
View File

@ -26,7 +26,7 @@ SYMBOL: compiling-word
SYMBOL: compiling-label SYMBOL: compiling-label
SYMBOL: compiling-loop? SYMBOL: compiling-loops
! Label of current word, after prologue, makes recursion faster ! Label of current word, after prologue, makes recursion faster
SYMBOL: current-label-start SYMBOL: current-label-start
@ -34,7 +34,7 @@ SYMBOL: current-label-start
: compiled-stack-traces? ( -- ? ) 36 getenv ; : compiled-stack-traces? ( -- ? ) 36 getenv ;
: begin-compiling ( word label -- ) : begin-compiling ( word label -- )
compiling-loop? off H{ } clone compiling-loops set
compiling-label set compiling-label set
compiling-word set compiling-word set
compiled-stack-traces? compiled-stack-traces?
@ -94,8 +94,8 @@ M: node generate-node drop iterate-next ;
: generate-call ( label -- next ) : generate-call ( label -- next )
dup maybe-compile dup maybe-compile
end-basic-block end-basic-block
dup compiling-label get eq? compiling-loop? get and [ dup compiling-loops get at [
drop current-label-start get %jump-label f %jump-label f
] [ ] [
tail-call? [ tail-call? [
%jump f %jump f
@ -104,7 +104,7 @@ M: node generate-node drop iterate-next ;
%call %call
iterate-next iterate-next
] if ] if
] if ; ] ?if ;
! #label ! #label
M: #label generate-node M: #label generate-node
@ -113,17 +113,13 @@ M: #label generate-node
r> ; r> ;
! #loop ! #loop
: compiling-loop ( word -- )
<label> dup resolve-label swap compiling-loops get set-at ;
M: #loop generate-node M: #loop generate-node
end-basic-block end-basic-block
[ dup node-param compiling-loop
dup node-param compiling-label set node-child generate-nodes
current-label-start define-label
current-label-start resolve-label
compiling-loop? on
node-child generate-nodes
end-basic-block
] with-scope
init-templates
iterate-next ; iterate-next ;
! #if ! #if
@ -158,17 +154,10 @@ M: #if generate-node
] with-generator ] with-generator
] keep ; ] keep ;
: tail-dispatch? ( node -- ? )
#! Is the dispatch a jump to a tail call to a word?
dup #call? swap node-successor #return? and ;
: dispatch-branches ( node -- ) : dispatch-branches ( node -- )
node-children [ node-children [
dup tail-dispatch? [ compiling-word get dispatch-branch
node-param %dispatch-label
] [
compiling-word get dispatch-branch
] if %dispatch-label
] each ; ] each ;
: generate-dispatch ( node -- ) : generate-dispatch ( node -- )
@ -276,5 +265,6 @@ M: #r> generate-node
! #return ! #return
M: #return generate-node M: #return generate-node
node-param compiling-label get eq? compiling-loop? get and end-basic-block
[ end-basic-block %return ] unless f ; node-param compiling-loops get key?
[ %return ] unless f ;

2
core/generator/registers/registers.factor Normal file → Executable file
View File

@ -504,7 +504,7 @@ M: loc lazy-store
: substitute-vregs ( values vregs -- ) : substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map [ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-subset >hashtable [ substitute-vreg? ] assoc-subset >hashtable
[ swap substitute ] curry each-phantom ; [ substitute-here ] curry each-phantom ;
: set-operand ( value var -- ) : set-operand ( value var -- )
>r dup constant? [ constant-value ] when r> set ; >r dup constant? [ constant-value ] when r> set ;

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

@ -58,16 +58,15 @@ TUPLE: no-math-method left right generic ;
2drop object-method 2drop object-method
] if ; ] if ;
: math-vtable* ( picker max quot -- quot ) : math-vtable ( picker quot -- quot )
[ [
rot , \ tag , >r
[ >r [ bootstrap-type>class ] map r> map % ] { } make , , \ tag ,
num-tags get [ bootstrap-type>class ]
r> compose map ,
\ dispatch , \ dispatch ,
] [ ] make ; inline ] [ ] make ; inline
: math-vtable ( picker quot -- quot )
num-tags get swap math-vtable* ; inline
TUPLE: math-combination ; TUPLE: math-combination ;
M: math-combination make-default-method M: math-combination make-default-method

18
core/hashtables/hashtables.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private slots.private math assocs USING: arrays kernel kernel.private slots.private math assocs
math.private sequences sequences.private vectors math.private sequences sequences.private vectors ;
combinators ;
IN: hashtables IN: hashtables
<PRIVATE <PRIVATE
@ -161,17 +160,10 @@ M: hashtable clone
(clone) dup hash-array clone over set-hash-array ; (clone) dup hash-array clone over set-hash-array ;
M: hashtable equal? M: hashtable equal?
{ over hashtable? [
{ [ over hashtable? not ] [ 2drop f ] } 2dup [ assoc-size ] 2apply number=
{ [ 2dup [ assoc-size ] 2apply number= not ] [ 2drop f ] } [ assoc= ] [ 2drop f ] if
{ [ t ] [ assoc= ] } ] [ 2drop f ] if ;
} cond ;
M: hashtable hashcode*
[
dup assoc-size 1 number=
[ assoc-hashcode ] [ nip assoc-size ] if
] recursive-hashcode ;
! Default method ! Default method
M: assoc new-assoc drop <hashtable> ; M: assoc new-assoc drop <hashtable> ;

3
core/inference/dataflow/dataflow-docs.factor
View File

@ -1,4 +1,5 @@
USING: inference.dataflow help.syntax help.markup ; USING: help.syntax help.markup ;
IN: inference.dataflow
HELP: #return HELP: #return
{ $values { "label" "a word or " { $link f } } { "node" "a new " { $link node } } } { $values { "label" "a word or " { $link f } } { "node" "a new " { $link node } } }

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

@ -317,4 +317,8 @@ UNION: #tail
POSTPONE: f #return #tail-values #tail-merge #terminate ; POSTPONE: f #return #tail-values #tail-merge #terminate ;
: tail-call? ( -- ? ) : tail-call? ( -- ? )
node-stack get [ node-successor #tail? ] all? ; #! We don't consider calls which do non-local exits to be
#! tail calls, because this gives better error traces.
node-stack get [
node-successor dup #tail? swap #terminate? not and
] all? ;

2
core/inference/known-words/known-words.factor
View File

@ -345,7 +345,7 @@ M: object infer-call
\ <word> { object object } { word } <effect> set-primitive-effect \ <word> { object object } { word } <effect> set-primitive-effect
\ <word> make-flushable \ <word> make-flushable
\ word-xt { word } { integer } <effect> set-primitive-effect \ word-xt { word } { integer integer } <effect> set-primitive-effect
\ word-xt make-flushable \ word-xt make-flushable
\ getenv { fixnum } { object } <effect> set-primitive-effect \ getenv { fixnum } { object } <effect> set-primitive-effect

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

@ -35,7 +35,7 @@ IN: inference.transforms
dup peek swap 1 head* dup peek swap 1 head*
] [ ] [
[ no-case ] swap [ no-case ] swap
] if hash-case>quot ] if case>quot
] if ] if
] 1 define-transform ] 1 define-transform

4
core/io/encodings/encodings.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg. ! Copyright (C) 2006, 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors io.streams.lines io.streams.plain USING: math kernel sequences sbufs vectors io.streams.lines io.streams.plain
namespaces unicode.syntax growable strings io classes io.streams.c namespaces unicode growable strings io classes io.streams.c
continuations ; continuations ;
IN: io.encodings IN: io.encodings
@ -19,7 +19,7 @@ SYMBOL: begin
over push 0 begin ; over push 0 begin ;
: push-replacement ( buf -- buf ch state ) : push-replacement ( buf -- buf ch state )
UNICHAR: replacement-character decoded ; CHAR: replacement-character decoded ;
: finish-decoding ( buf ch state -- str ) : finish-decoding ( buf ch state -- str )
begin eq? [ decode-error ] unless drop "" like ; begin eq? [ decode-error ] unless drop "" like ;

2
core/io/encodings/latin1/latin1.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: io.encodings strings kernel ; USING: io io.encodings strings kernel ;
IN: io.encodings.latin1 IN: io.encodings.latin1
TUPLE: latin1 stream ; TUPLE: latin1 stream ;

4
core/io/encodings/utf8/utf8-docs.factor Normal file → Executable file
View File

@ -1,12 +1,12 @@
USING: help.markup help.syntax io.encodings strings ; USING: help.markup help.syntax io.encodings strings ;
IN: io.encodings.utf8 IN: io.encodings.utf8
ARTICLE: "io.utf8" "Working with UTF8-encoded data" ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data"
"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences." "The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences."
{ $subsection encode-utf8 } { $subsection encode-utf8 }
{ $subsection decode-utf8 } ; { $subsection decode-utf8 } ;
ABOUT: "io.utf8" ABOUT: "io.encodings.utf8"
HELP: decode-utf8 HELP: decode-utf8
{ $values { "seq" "a sequence of bytes" } { "str" string } } { $values { "seq" "a sequence of bytes" } { "str" string } }

8
core/io/encodings/utf8/utf8-tests.factor
View File

@ -1,5 +1,5 @@
USING: io.encodings.utf8 tools.test sbufs kernel io io.encodings USING: io.encodings.utf8 tools.test sbufs kernel io
sequences strings arrays unicode.syntax ; sequences strings arrays unicode ;
: decode-utf8-w/stream ( array -- newarray ) : decode-utf8-w/stream ( array -- newarray )
>sbuf dup reverse-here utf8 <decoding> contents ; >sbuf dup reverse-here utf8 <decoding> contents ;
@ -7,7 +7,7 @@ sequences strings arrays unicode.syntax ;
: encode-utf8-w/stream ( array -- newarray ) : encode-utf8-w/stream ( array -- newarray )
SBUF" " clone tuck utf8 <encoding> stream-write >array ; SBUF" " clone tuck utf8 <encoding> stream-write >array ;
[ { UNICHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test [ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test
[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test [ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test
@ -15,7 +15,7 @@ sequences strings arrays unicode.syntax ;
[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8-w/stream >array ] unit-test [ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
[ { UNICHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream >array ] unit-test [ { CHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test [ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test

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

@ -3,8 +3,7 @@
USING: arrays generic assocs inference inference.class USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use combinators classes optimizer.def-use ;
optimizer.pattern-match generic.standard optimizer.specializers ;
IN: optimizer.backend IN: optimizer.backend
SYMBOL: class-substitutions SYMBOL: class-substitutions
@ -38,10 +37,10 @@ GENERIC: optimize-node* ( node -- node/t changed? )
over assoc-empty? [ over assoc-empty? [
2drop 2drop
] [ ] [
2dup node-in-d substitute 2dup node-in-d swap substitute-here
2dup node-in-r substitute 2dup node-in-r swap substitute-here
2dup node-out-d substitute 2dup node-out-d swap substitute-here
node-out-r substitute node-out-r swap substitute-here
] if ; ] if ;
: perform-substitutions ( node -- ) : perform-substitutions ( node -- )
@ -76,7 +75,6 @@ DEFER: optimize-nodes
optimizer-changed get optimizer-changed get
] with-scope optimizer-changed set ; ] with-scope optimizer-changed set ;
! Generic nodes
M: node optimize-node* drop t f ; M: node optimize-node* drop t f ;
! Post-inlining cleanup ! Post-inlining cleanup
@ -112,362 +110,10 @@ M: #return optimize-node* cleanup-inlining ;
! #values ! #values
M: #values optimize-node* cleanup-inlining ; M: #values optimize-node* cleanup-inlining ;
! Some utilities for splicing in dataflow IR subtrees
M: f set-node-successor 2drop ; M: f set-node-successor 2drop ;
: splice-node ( old new -- ) : splice-node ( old new -- )
dup splice-def-use last-node set-node-successor ; dup splice-def-use last-node set-node-successor ;
GENERIC: remember-method* ( method-spec node -- )
M: #call remember-method*
[ node-history ?push ] keep set-node-history ;
M: node remember-method*
2drop ;
: remember-method ( method-spec node -- )
swap dup second +inlined+ depends-on
[ swap remember-method* ] curry each-node ;
: (splice-method) ( #call method-spec quot -- node )
#! Must remember the method before splicing in, otherwise
#! the rest of the IR will also remember the method
pick node-in-d dataflow-with
[ remember-method ] keep
[ swap infer-classes/node ] 2keep
[ splice-node ] keep ;
: splice-quot ( #call quot -- node )
over node-in-d dataflow-with
[ swap infer-classes/node ] 2keep
[ splice-node ] keep ;
: drop-inputs ( node -- #shuffle ) : drop-inputs ( node -- #shuffle )
node-in-d clone \ #shuffle in-node ; node-in-d clone \ #shuffle in-node ;
! Constant branch folding
: fold-branch ( node branch# -- node )
over node-children nth
swap node-successor over splice-node ;
! #if
: known-boolean-value? ( node value -- value ? )
2dup node-literal? [
node-literal t
] [
node-class {
{ [ dup null class< ] [ drop f f ] }
{ [ dup general-t class< ] [ drop t t ] }
{ [ dup \ f class< ] [ drop f t ] }
{ [ t ] [ drop f f ] }
} cond
] if ;
: fold-if-branch? dup node-in-d first known-boolean-value? ;
: fold-if-branch ( node value -- node' )
over drop-inputs >r
0 1 ? fold-branch
r> [ set-node-successor ] keep ;
: only-one ( seq -- elt/f )
dup length 1 = [ first ] [ drop f ] if ;
: lift-throw-tail? ( #if -- tail/? )
dup node-successor node-successor
[ active-children only-one ] [ drop f ] if ;
: clone-node ( node -- newnode )
clone dup [ clone ] modify-values ;
: detach-node-successor ( node -- successor )
dup node-successor #terminate rot set-node-successor ;
: lift-branch ( #if node -- )
>r detach-node-successor r> splice-node ;
M: #if optimize-node*
dup fold-if-branch? [ fold-if-branch t ] [
2drop t f
! drop dup lift-throw-tail? dup [
! dupd lift-branch t
! ] [
! 2drop t f
! ] if
] if ;
: fold-dispatch-branch? dup node-in-d first tuck node-literal? ;
: fold-dispatch-branch ( node value -- node' )
dupd node-literal
over drop-inputs >r fold-branch r>
[ set-node-successor ] keep ;
M: #dispatch optimize-node*
dup fold-dispatch-branch? [
fold-dispatch-branch t
] [
2drop t f
] if ;
! #loop
! BEFORE:
! #label -> C -> #return 1
! |
! -> #if -> #merge -> #return 2
! |
! --------
! | |
! A B
! | |
! #values |
! #call-label
! |
! |
! #values
! AFTER:
! #label -> #terminate
! |
! -> #if -> #terminate
! |
! --------
! | |
! A B
! | |
! #values |
! | #call-label
! #merge |
! | |
! C #values
! |
! #return 1
: find-final-if ( node -- #if/f )
dup [
dup #if? [
dup node-successor #tail? [
node-successor find-final-if
] unless
] [
node-successor find-final-if
] if
] when ;
: lift-loop-tail? ( #label -- tail/f )
dup node-successor node-successor [
dup node-param swap node-child find-final-if dup [
node-children [ penultimate-node ] map
[
dup #call-label?
[ node-param eq? not ] [ 2drop t ] if
] with subset only-one
] [ 2drop f ] if
] [ drop f ] if ;
! M: #loop optimize-node*
! dup lift-loop-tail? dup [
! last-node >r
! dup detach-node-successor
! over node-child find-final-if detach-node-successor
! [ set-node-successor ] keep
! r> set-node-successor
! t
! ] [
! 2drop t f
! ] if ;
! #call
: splice-method ( #call method-spec/t quot/t -- node/t )
#! t indicates failure
{
{ [ dup t eq? ] [ 3drop t ] }
{ [ 2over swap node-history member? ] [ 3drop t ] }
{ [ t ] [ (splice-method) ] }
} cond ;
! Single dispatch method inlining optimization
: already-inlined? ( node -- ? )
#! Was this node inlined from definition of 'word'?
dup node-param swap node-history memq? ;
: specific-method ( class word -- class ) order min-class ;
: node-class# ( node n -- class )
over node-in-d <reversed> ?nth node-class ;
: dispatching-class ( node word -- class )
[ dispatch# node-class# ] keep specific-method ;
! A heuristic to avoid excessive inlining
DEFER: (flat-length)
: word-flat-length ( word -- n )
dup get over inline? not or
[ drop 1 ] [ dup dup set word-def (flat-length) ] if ;
: (flat-length) ( seq -- n )
[
{
{ [ dup quotation? ] [ (flat-length) 1+ ] }
{ [ dup array? ] [ (flat-length) ] }
{ [ dup word? ] [ word-flat-length ] }
{ [ t ] [ drop 1 ] }
} cond
] map sum ;
: flat-length ( seq -- n )
[ word-def (flat-length) ] with-scope ;
: will-inline-method ( node word -- method-spec/t quot/t )
#! t indicates failure
tuck dispatching-class dup [
swap [ 2array ] 2keep
method method-word
dup flat-length 10 >=
[ 1quotation ] [ word-def ] if
] [
2drop t t
] if ;
: inline-standard-method ( node word -- node )
dupd will-inline-method splice-method ;
! Partial dispatch of math-generic words
: math-both-known? ( word left right -- ? )
math-class-max swap specific-method ;
: will-inline-math-method ( word left right -- method-spec/t quot/t )
#! t indicates failure
3dup math-both-known?
[ [ 3array ] 3keep math-method ] [ 3drop t t ] if ;
: inline-math-method ( #call word -- node )
over node-input-classes first2
will-inline-math-method splice-method ;
: inline-method ( #call -- node )
dup node-param {
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
{ [ t ] [ 2drop t ] }
} cond ;
! Resolve type checks at compile time where possible
: comparable? ( actual testing -- ? )
#! If actual is a subset of testing or if the two classes
#! are disjoint, return t.
2dup class< >r classes-intersect? not r> or ;
: optimize-predicate? ( #call -- ? )
dup node-param "predicating" word-prop dup [
>r node-class-first r> comparable?
] [
2drop f
] if ;
: literal-quot ( node literals -- quot )
#! Outputs a quotation which drops the node's inputs, and
#! pushes some literals.
>r node-in-d length \ drop <repetition>
r> [ literalize ] map append >quotation ;
: inline-literals ( node literals -- node )
#! Make #shuffle -> #push -> #return -> successor
dupd literal-quot splice-quot ;
: evaluate-predicate ( #call -- ? )
dup node-param "predicating" word-prop >r
node-class-first r> class< ;
: optimize-predicate ( #call -- node )
dup evaluate-predicate swap
dup node-successor #if? [
dup drop-inputs >r
node-successor swap 0 1 ? fold-branch
r> [ set-node-successor ] keep
] [
swap 1array inline-literals
] if ;
: optimizer-hooks ( node -- conditions )
node-param "optimizer-hooks" word-prop ;
: optimizer-hook ( node -- pair/f )
dup optimizer-hooks [ first call ] find 2nip ;
: optimize-hook ( node -- )
dup optimizer-hook second call ;
: define-optimizers ( word optimizers -- )
"optimizer-hooks" set-word-prop ;
: flush-eval? ( #call -- ? )
dup node-param "flushable" word-prop [
node-out-d [ unused? ] all?
] [
drop f
] if ;
: flush-eval ( #call -- node )
dup node-param +inlined+ depends-on
dup node-out-d length f <repetition> inline-literals ;
: partial-eval? ( #call -- ? )
dup node-param "foldable" word-prop [
dup node-in-d [ node-literal? ] with all?
] [
drop f
] if ;
: literal-in-d ( #call -- inputs )
dup node-in-d [ node-literal ] with map ;
: partial-eval ( #call -- node )
dup node-param +inlined+ depends-on
dup literal-in-d over node-param 1quotation
[ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
: define-identities ( words identities -- )
[ "identities" set-word-prop ] curry each ;
: find-identity ( node -- quot )
[ node-param "identities" word-prop ] keep
[ swap first in-d-match? ] curry find
nip dup [ second ] when ;
: apply-identities ( node -- node/f )
dup find-identity dup [ splice-quot ] [ 2drop f ] if ;
: optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [
>r node-input-classes r> specialized-length tail*
[ types length 1 = ] all?
] [
2drop f
] if ;
: optimistic-inline ( #call -- node )
dup node-param dup +inlined+ depends-on
word-def splice-quot ;
: method-body-inline? ( #call -- ? )
node-param dup method-body?
[ flat-length 8 <= ] [ drop f ] if ;
M: #call optimize-node*
{
{ [ dup flush-eval? ] [ flush-eval ] }
{ [ dup partial-eval? ] [ partial-eval ] }
{ [ dup find-identity ] [ apply-identities ] }
{ [ dup optimizer-hook ] [ optimize-hook ] }
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
{ [ dup optimistic-inline? ] [ optimistic-inline ] }
{ [ dup method-body-inline? ] [ optimistic-inline ] }
{ [ t ] [ inline-method ] }
} cond dup not ;

121
core/optimizer/control/control-tests.factor Normal file → Executable file
View File

@ -1,6 +1,7 @@
IN: temporary IN: temporary
USING: tools.test optimizer.control combinators kernel USING: tools.test optimizer.control combinators kernel
sequences inference.dataflow math inference ; sequences inference.dataflow math inference classes strings
optimizer ;
: label-is-loop? ( node word -- ? ) : label-is-loop? ( node word -- ? )
[ [
@ -60,3 +61,121 @@ sequences inference.dataflow math inference ;
[ loop-test-3 ] dataflow dup detect-loops [ loop-test-3 ] dataflow dup detect-loops
\ loop-test-3 label-is-not-loop? \ loop-test-3 label-is-not-loop?
] unit-test ] unit-test
: loop-test-4 ( a -- )
dup [
loop-test-4
] [
drop
] if ; inline
: find-label ( node -- label )
dup #label? [ node-successor find-label ] unless ;
: test-loop-exits
dataflow dup detect-loops find-label
dup node-param swap
[ node-child find-tail find-loop-exits [ class ] map ] keep
#label-loop? ;
[ { #values } t ] [
[ loop-test-4 ] test-loop-exits
] unit-test
: loop-test-5 ( a -- )
dup [
dup string? [
loop-test-5
] [
drop
] if
] [
drop
] if ; inline
[ { #values #values } t ] [
[ loop-test-5 ] test-loop-exits
] unit-test
: loop-test-6 ( a -- )
dup [
dup string? [
loop-test-6
] [
3 throw
] if
] [
drop
] if ; inline
[ { #values } t ] [
[ loop-test-6 ] test-loop-exits
] unit-test
[ f ] [
[ [ [ ] map ] map ] dataflow dup detect-loops
[ dup #label? swap #loop? not and ] node-exists?
] unit-test
: blah f ;
DEFER: a
: b ( -- )
blah [ b ] [ a ] if ; inline
: a ( -- )
blah [ b ] [ a ] if ; inline
[ t ] [
[ a ] dataflow dup detect-loops
\ a label-is-loop?
] unit-test
[ t ] [
[ a ] dataflow dup detect-loops
\ b label-is-loop?
] unit-test
[ t ] [
[ b ] dataflow dup detect-loops
\ a label-is-loop?
] unit-test
[ t ] [
[ a ] dataflow dup detect-loops
\ b label-is-loop?
] unit-test
DEFER: a'
: b' ( -- )
blah [ b' b' ] [ a' ] if ; inline
: a' ( -- )
blah [ b' ] [ a' ] if ; inline
[ f ] [
[ a' ] dataflow dup detect-loops
\ a' label-is-loop?
] unit-test
[ f ] [
[ b' ] dataflow dup detect-loops
\ b' label-is-loop?
] unit-test
! I used to think this should be f, but doing this on pen and
! paper almost convinced me that a loop conversion here is
! sound. The loop analysis algorithm looks pretty solid -- its
! a standard iterative dataflow problem after all -- so I'm
! tempted to believe the computer here
[ t ] [
[ b' ] dataflow dup detect-loops
\ a' label-is-loop?
] unit-test
[ f ] [
[ a' ] dataflow dup detect-loops
\ b' label-is-loop?
] unit-test

352
core/optimizer/control/control.factor Normal file → Executable file
View File

@ -1,36 +1,336 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel inference.dataflow combinators sequences USING: arrays generic assocs inference inference.class
namespaces math ; inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.backend generic.standard ;
IN: optimizer.control IN: optimizer.control
GENERIC: detect-loops* ( node -- ) ! ! ! Rudimentary CFA
M: node detect-loops* drop ; ! A LOOP
!
! #label A
! |
! #if ----> #merge ----> #return
! |
! -------------
! | |
! #call-label A |
! | ...
! #values
!
! NOT A LOOP (call to A not in tail position):
!
!
! #label A
! |
! #if ----> ... ----> #merge ----> #return
! |
! -------------
! | |
! #call-label A |
! | ...
! ...
! |
! #values
!
! NOT A LOOP (call to A nested inside another label which is
! not a loop):
!
!
! #label A
! |
! #if ----> #merge ----> ... ----> #return
! |
! -------------
! | |
! ... #label B
! |
! #if -> ...
! |
! ---------
! | |
! #call-label A |
! | |
! #values |
! #call-label B
! |
! ...
M: #label detect-loops* t swap set-#label-loop? ; ! Mapping word => { node { nesting tail? }+ height }
! We record all calls to a label, their control nesting and
! whether it is a tail call or not
SYMBOL: label-info
: not-a-loop ( #label -- ) GENERIC: collect-label-info* ( node -- )
f swap set-#label-loop? ;
: tail-call? ( -- ? ) M: #label collect-label-info*
node-stack get [ V{ } clone node-stack get length 3array ] keep
dup [ #label? ] find-last drop [ 1+ ] [ 0 ] if* tail node-param label-info get set-at ;
[ node-successor #tail? ] all? ;
: detect-loop ( seen-other? label node -- seen-other? continue? ) USE: prettyprint
#! seen-other?: have we seen another label?
{
{ [ dup #label? not ] [ 2drop t ] }
{ [ 2dup node-param eq? not ] [ 3drop t t ] }
{ [ tail-call? not ] [ not-a-loop drop f ] }
{ [ pick ] [ not-a-loop drop f ] }
{ [ t ] [ 2drop f ] }
} cond ;
M: #call-label detect-loops* M: #call-label collect-label-info*
f swap node-param node-stack get <reversed> node-param label-info get at
[ detect-loop ] with all? 2drop ; node-stack get over third tail
[ [ #label? ] subset [ node-param ] map ] keep
[ node-successor #tail? ] all? 2array
swap second push ;
: detect-loops ( node -- ) M: node collect-label-info*
[ detect-loops* ] each-node ; drop ;
: collect-label-info ( node -- )
H{ } clone label-info set
[ collect-label-info* ] each-node ;
! Mapping word => label
SYMBOL: potential-loops
: remove-non-tail-calls ( -- )
label-info get
[ nip second [ second ] all? ] assoc-subset
[ first ] assoc-map
potential-loops set ;
: remove-non-loop-calls ( -- )
! Boolean is set to t if something changed.
! We recurse until a fixed point is reached.
f label-info get [
! If label X is called from within a label Y that is
! no longer a potential loop, then X is no longer a
! potential loop either.
over potential-loops get key? [
second [ first ] map concat
potential-loops get [ key? ] curry all?
[ drop ] [ potential-loops get delete-at t or ] if
] [ 2drop ] if
] assoc-each [ remove-non-loop-calls ] when ;
: detect-loops ( nodes -- )
[
collect-label-info
remove-non-tail-calls
remove-non-loop-calls
potential-loops get [
nip t swap set-#label-loop?
] assoc-each
] with-scope ;
! ! ! Constant branch folding
!
! BEFORE
!
! #if ----> #merge ----> C
! |
! ---------
! | |
! A B
! | |
! #values |
! #values
!
! AFTER
!
! |
! A
! |
! #values
! |
! #merge
! |
! C
: fold-branch ( node branch# -- node )
over node-children nth
swap node-successor over splice-node ;
! #if
: known-boolean-value? ( node value -- value ? )
2dup node-literal? [
node-literal t
] [
node-class {
{ [ dup null class< ] [ drop f f ] }
{ [ dup general-t class< ] [ drop t t ] }
{ [ dup \ f class< ] [ drop f t ] }
{ [ t ] [ drop f f ] }
} cond
] if ;
: fold-if-branch? dup node-in-d first known-boolean-value? ;
: fold-if-branch ( node value -- node' )
over drop-inputs >r
0 1 ? fold-branch
r> [ set-node-successor ] keep ;
! ! ! Lifting code after a conditional if one branch throws
! BEFORE
!
! #if ----> #merge ----> B ----> #return/#values
! |
! |
! ---------
! | |
! | A
! #terminate |
! #values
!
! AFTER
!
! #if ----> #merge (*) ----> #return/#values (**)
! |
! |
! ---------
! | |
! | A
! #terminate |
! #values
! |
! #merge (***)
! |
! B
! |
! #return/#values
!
! (*) has the same outputs as the inputs of (**), and it is not
! the same node as (***)
!
! Note: if (**) is #return is is sound to put #terminate there,
! but not if (**) is #
: only-one ( seq -- elt/f )
dup length 1 = [ first ] [ drop f ] if ;
: lift-throw-tail? ( #if -- tail/? )
dup node-successor #tail?
[ drop f ] [ active-children only-one ] if ;
: clone-node ( node -- newnode )
clone dup [ clone ] modify-values ;
: lift-branch
over
last-node clone-node
dup node-in-d \ #merge out-node
[ set-node-successor ] keep -rot
>r dup node-successor r> splice-node
set-node-successor ;
M: #if optimize-node*
dup fold-if-branch? [ fold-if-branch t ] [
drop dup lift-throw-tail? dup [
dupd lift-branch t
] [
2drop t f
] if
] if ;
! Loop tail hoising: code after a loop can sometimes go in the
! non-recursive branch of the loop
! BEFORE:
! #label -> C -> #return 1
! |
! -> #if -> #merge (*) -> #return 2
! |
! --------
! | |
! A B
! | |
! #values |
! #call-label
! |
! |
! #values
! AFTER:
! #label -> #return 1
! |
! -> #if -------> #merge (*) -> #return 2
! | \-------------------/
! ---------------- |
! | | |
! A B unreacachable code needed to
! | | preserve invariants
! #values |
! | #call-label
! #merge (*) |
! | |
! C #values
! |
! #return 1
: find-tail ( node -- tail )
dup #terminate? [
dup node-successor #tail? [
node-successor find-tail
] unless
] unless ;
: child-tails ( node -- seq )
node-children [ find-tail ] map ;
GENERIC: add-loop-exit* ( label node -- )
M: #branch add-loop-exit*
child-tails [ add-loop-exit* ] with each ;
M: #call-label add-loop-exit*
tuck node-param eq? [ drop ] [ node-successor , ] if ;
M: #terminate add-loop-exit*
2drop ;
M: node add-loop-exit*
nip node-successor dup #terminate? [ drop ] [ , ] if ;
: find-loop-exits ( label node -- seq )
[ add-loop-exit* ] { } make ;
: find-final-if ( node -- #if/f )
dup [
dup #if? [
dup node-successor #tail? [
node-successor find-final-if
] unless
] [
node-successor find-final-if
] if
] when ;
: detach-node-successor ( node -- successor )
dup node-successor #terminate rot set-node-successor ;
: lift-loop-tail? ( #label -- tail/f )
dup node-successor node-successor [
dup node-param swap node-child find-final-if dup [
find-loop-exits only-one
] [ 2drop f ] if
] [ drop f ] if ;
M: #loop optimize-node*
dup lift-loop-tail? dup [
last-node "values" set
dup node-successor "tail" set
dup node-successor last-node "return" set
dup node-child find-final-if node-successor "merge" set
! #label -> #return
"return" get clone-node over set-node-successor
! #merge -> C
"merge" get clone-node "tail" get over set-node-successor
! #values -> #merge ->C
"values" get set-node-successor
t
] [
2drop t f
] if ;

227
core/optimizer/inlining/inlining.factor Executable file
View File

@ -0,0 +1,227 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.backend generic.standard optimizer.specializers
optimizer.def-use optimizer.pattern-match generic.standard
optimizer.control ;
IN: optimizer.inlining
GENERIC: remember-method* ( method-spec node -- )
M: #call remember-method*
[ node-history ?push ] keep set-node-history ;
M: node remember-method*
2drop ;
: remember-method ( method-spec node -- )
swap dup second +inlined+ depends-on
[ swap remember-method* ] curry each-node ;
: (splice-method) ( #call method-spec quot -- node )
#! Must remember the method before splicing in, otherwise
#! the rest of the IR will also remember the method
pick node-in-d dataflow-with
[ remember-method ] keep
[ swap infer-classes/node ] 2keep
[ splice-node ] keep ;
: splice-quot ( #call quot -- node )
over node-in-d dataflow-with
[ swap infer-classes/node ] 2keep
[ splice-node ] keep ;
! #call
: splice-method ( #call method-spec/t quot/t -- node/t )
#! t indicates failure
{
{ [ dup t eq? ] [ 3drop t ] }
{ [ 2over swap node-history member? ] [ 3drop t ] }
{ [ t ] [ (splice-method) ] }
} cond ;
! Single dispatch method inlining optimization
: already-inlined? ( node -- ? )
#! Was this node inlined from definition of 'word'?
dup node-param swap node-history memq? ;
: specific-method ( class word -- class ) order min-class ;
: node-class# ( node n -- class )
over node-in-d <reversed> ?nth node-class ;
: dispatching-class ( node word -- class )
[ dispatch# node-class# ] keep specific-method ;
! A heuristic to avoid excessive inlining
DEFER: (flat-length)
: word-flat-length ( word -- n )
dup get over inline? not or
[ drop 1 ] [ dup dup set word-def (flat-length) ] if ;
: (flat-length) ( seq -- n )
[
{
{ [ dup quotation? ] [ (flat-length) 1+ ] }
{ [ dup array? ] [ (flat-length) ] }
{ [ dup word? ] [ word-flat-length ] }
{ [ t ] [ drop 1 ] }
} cond
] map sum ;
: flat-length ( seq -- n )
[ word-def (flat-length) ] with-scope ;
: will-inline-method ( node word -- method-spec/t quot/t )
#! t indicates failure
tuck dispatching-class dup [
swap [ 2array ] 2keep
method method-word
dup flat-length 10 >=
[ 1quotation ] [ word-def ] if
] [
2drop t t
] if ;
: inline-standard-method ( node word -- node )
dupd will-inline-method splice-method ;
! Partial dispatch of math-generic words
: math-both-known? ( word left right -- ? )
math-class-max swap specific-method ;
: will-inline-math-method ( word left right -- method-spec/t quot/t )
#! t indicates failure
3dup math-both-known?
[ [ 3array ] 3keep math-method ] [ 3drop t t ] if ;
: inline-math-method ( #call word -- node )
over node-input-classes first2
will-inline-math-method splice-method ;
: inline-method ( #call -- node )
dup node-param {
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
{ [ t ] [ 2drop t ] }
} cond ;
! Resolve type checks at compile time where possible
: comparable? ( actual testing -- ? )
#! If actual is a subset of testing or if the two classes
#! are disjoint, return t.
2dup class< >r classes-intersect? not r> or ;
: optimize-predicate? ( #call -- ? )
dup node-param "predicating" word-prop dup [
>r node-class-first r> comparable?
] [
2drop f
] if ;
: literal-quot ( node literals -- quot )
#! Outputs a quotation which drops the node's inputs, and
#! pushes some literals.
>r node-in-d length \ drop <repetition>
r> [ literalize ] map append >quotation ;
: inline-literals ( node literals -- node )
#! Make #shuffle -> #push -> #return -> successor
dupd literal-quot splice-quot ;
: evaluate-predicate ( #call -- ? )
dup node-param "predicating" word-prop >r
node-class-first r> class< ;
: optimize-predicate ( #call -- node )
#! If the predicate is followed by a branch we fold it
#! immediately
dup evaluate-predicate swap
dup node-successor #if? [
dup drop-inputs >r
node-successor swap 0 1 ? fold-branch
r> [ set-node-successor ] keep
] [
swap 1array inline-literals
] if ;
: optimizer-hooks ( node -- conditions )
node-param "optimizer-hooks" word-prop ;
: optimizer-hook ( node -- pair/f )
dup optimizer-hooks [ first call ] find 2nip ;
: optimize-hook ( node -- )
dup optimizer-hook second call ;
: define-optimizers ( word optimizers -- )
"optimizer-hooks" set-word-prop ;
: flush-eval? ( #call -- ? )
dup node-param "flushable" word-prop [
node-out-d [ unused? ] all?
] [
drop f
] if ;
: flush-eval ( #call -- node )
dup node-param +inlined+ depends-on
dup node-out-d length f <repetition> inline-literals ;
: partial-eval? ( #call -- ? )
dup node-param "foldable" word-prop [
dup node-in-d [ node-literal? ] with all?
] [
drop f
] if ;
: literal-in-d ( #call -- inputs )
dup node-in-d [ node-literal ] with map ;
: partial-eval ( #call -- node )
dup node-param +inlined+ depends-on
dup literal-in-d over node-param 1quotation
[ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
: define-identities ( words identities -- )
[ "identities" set-word-prop ] curry each ;
: find-identity ( node -- quot )
[ node-param "identities" word-prop ] keep
[ swap first in-d-match? ] curry find
nip dup [ second ] when ;
: apply-identities ( node -- node/f )
dup find-identity dup [ splice-quot ] [ 2drop f ] if ;
: optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [
>r node-input-classes r> specialized-length tail*
[ types length 1 = ] all?
] [
2drop f
] if ;
: optimistic-inline ( #call -- node )
dup node-param dup +inlined+ depends-on
word-def splice-quot ;
: method-body-inline? ( #call -- ? )
node-param dup method-body?
[ flat-length 8 <= ] [ drop f ] if ;
M: #call optimize-node*
{
{ [ dup flush-eval? ] [ flush-eval ] }
{ [ dup partial-eval? ] [ partial-eval ] }
{ [ dup find-identity ] [ apply-identities ] }
{ [ dup optimizer-hook ] [ optimize-hook ] }
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
{ [ dup optimistic-inline? ] [ optimistic-inline ] }
{ [ dup method-body-inline? ] [ optimistic-inline ] }
{ [ t ] [ inline-method ] }
} cond dup not ;

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

@ -8,7 +8,7 @@ assocs quotations sequences.private io.binary io.crc32
io.streams.string layouts splitting math.intervals io.streams.string layouts splitting math.intervals
math.floats.private tuples tuples.private classes math.floats.private tuples tuples.private classes
optimizer.def-use optimizer.backend optimizer.pattern-match optimizer.def-use optimizer.backend optimizer.pattern-match
float-arrays sequences.private combinators ; optimizer.inlining float-arrays sequences.private combinators ;
! the output of <tuple> and <tuple-boa> has the class which is ! the output of <tuple> and <tuple-boa> has the class which is
! its second-to-last input ! its second-to-last input

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

@ -7,7 +7,7 @@ inference.class inference.dataflow vectors strings sbufs io
namespaces assocs quotations math.intervals sequences.private namespaces assocs quotations math.intervals sequences.private
combinators splitting layouts math.parser classes generic.math combinators splitting layouts math.parser classes generic.math
optimizer.pattern-match optimizer.backend optimizer.def-use optimizer.pattern-match optimizer.backend optimizer.def-use
generic.standard system ; optimizer.inlining generic.standard system ;
{ + bignum+ float+ fixnum+fast } { { + bignum+ float+ fixnum+fast } {
{ { number 0 } [ drop ] } { { number 0 } [ drop ] }

52
core/optimizer/optimizer-tests.factor
View File

@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private optimizer.backend classes inference.dataflow tuples.private
continuations growable ; continuations growable optimizer.inlining namespaces ;
IN: temporary IN: temporary
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
@ -301,3 +301,53 @@ TUPLE: silly-tuple a b ;
[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test [ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test [ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test [ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
! Regression
: lift-throw-tail-regression
dup integer? [ "an integer" ] [
dup string? [ "a string" ] [
"error" throw
] if
] if ;
[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
: lift-loop-tail-test-1 ( a quot -- )
over even? [
[ >r 3 - r> call ] keep lift-loop-tail-test-1
] [
over 0 < [
2drop
] [
[ >r 2 - r> call ] keep lift-loop-tail-test-1
] if
] if ; inline
: lift-loop-tail-test-2
10 [ ] lift-loop-tail-test-1 1 2 3 ;
[ 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-1
1
generic-inline-test
generic-inline-test
generic-inline-test
generic-inline-test
generic-inline-test
generic-inline-test
generic-inline-test
generic-inline-test
generic-inline-test
generic-inline-test ;
[ { t f } ] [
\ generic-inline-test-1 word-def dataflow
[ optimize-1 , optimize-1 , drop ] { } make
] unit-test

2
core/optimizer/optimizer.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces optimizer.backend optimizer.def-use USING: kernel namespaces optimizer.backend optimizer.def-use
optimizer.known-words optimizer.math optimizer.control optimizer.known-words optimizer.math optimizer.control
inference.class ; optimizer.inlining inference.class ;
IN: optimizer IN: optimizer
: optimize-1 ( node -- newnode ? ) : optimize-1 ( node -- newnode ? )

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

@ -266,19 +266,10 @@ HELP: escape
{ $description "Converts from a single-character escape code and the corresponding character." } { $description "Converts from a single-character escape code and the corresponding character." }
{ $examples { $example "CHAR: n escape CHAR: \\n = ." "t" } } ; { $examples { $example "CHAR: n escape CHAR: \\n = ." "t" } } ;
HELP: next-escape
{ $values { "m" "an index into " { $snippet "str" } } { "str" string } { "n" "an index into " { $snippet "str" } } { "ch" "a character" } }
{ $description "Helper word for " { $link parse-string } " which parses an escape sequence starting at the " { $snippet "m" } "th index of " { $snippet "str" } "." }
{ $errors "Throws a " { $link bad-escape } " if the string contains an invalid escape sequence." } ;
HELP: next-char
{ $values { "m" "an index into " { $snippet "str" } } { "str" string } { "n" "an index into " { $snippet "str" } } { "ch" "a character" } }
{ $description "Helper word for " { $link parse-string } " which parses a character starting at the " { $snippet "m" } "th index of " { $snippet "str" } "." } ;
HELP: parse-string HELP: parse-string
{ $values { "str" "a new " { $link string } } } { $values { "str" "a new " { $link string } } }
{ $description "Parses the line until a quote (\"), interpreting escape codes along the way." } { $description "Parses the line until a quote (\"), interpreting escape codes along the way." }
{ $errors "Throws an " { $link bad-escape } " if the string contains an invalid escape sequence." } { $errors "Throws an error if the string contains an invalid escape sequence." }
$parsing-note ; $parsing-note ;
HELP: still-parsing? HELP: still-parsing?

43
core/parser/parser.factor
View File

@ -119,22 +119,43 @@ M: bad-escape summary drop "Bad escape code" ;
{ CHAR: \" CHAR: \" } { CHAR: \" CHAR: \" }
} at [ bad-escape ] unless* ; } at [ bad-escape ] unless* ;
: next-escape ( m str -- n ch ) SYMBOL: name>char-hook
2dup nth CHAR: u =
[ >r 1+ dup 6 + tuck r> subseq hex> ]
[ over 1+ -rot nth escape ] if ;
: next-char ( m str -- n ch ) name>char-hook global [
2dup nth CHAR: \\ = [ "Unicode support not available" throw ] or
[ >r 1+ r> next-escape ] [ over 1+ -rot nth ] if ; ] change-at
: (parse-string) ( m str -- n ) : unicode-escape ( str -- ch str' )
2dup nth CHAR: " = "{" ?head-slice [
[ drop 1+ ] [ [ next-char , ] keep (parse-string) ] if ; CHAR: } over index cut-slice
>r >string name>char-hook get call r>
1 tail-slice
] [
6 cut-slice >r hex> r>
] if ;
: next-escape ( str -- ch str' )
"u" ?head-slice [
unicode-escape
] [
unclip-slice escape swap
] if ;
: (parse-string) ( str -- m )
dup [ "\"\\" member? ] find dup [
>r cut-slice >r % r> 1 tail-slice r>
dup CHAR: " = [
drop slice-from
] [
drop next-escape >r , r> (parse-string)
] if
] [
"Unterminated string" throw
] if ;
: parse-string ( -- str ) : parse-string ( -- str )
lexer get [ lexer get [
[ (parse-string) ] "" make swap [ swap tail-slice (parse-string) ] "" make swap
] change-column ; ] change-column ;
TUPLE: parse-error file line col text ; TUPLE: parse-error file line col text ;

2
core/sequences/sequences.factor
View File

@ -257,7 +257,7 @@ INSTANCE: repetition immutable-sequence
: check-copy ( src n dst -- ) : check-copy ( src n dst -- )
over 0 < [ bounds-error ] when over 0 < [ bounds-error ] when
>r swap length + r> lengthen ; >r swap length + r> lengthen ; inline
PRIVATE> PRIVATE>

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

@ -100,13 +100,9 @@ ARTICLE: "escape" "Character escape codes"
{ { $snippet "\\0" } "a null byte (ASCII 0)" } { { $snippet "\\0" } "a null byte (ASCII 0)" }
{ { $snippet "\\e" } "escape (ASCII 27)" } { { $snippet "\\e" } "escape (ASCII 27)" }
{ { $snippet "\\\"" } { $snippet "\"" } } { { $snippet "\\\"" } { $snippet "\"" } }
} { { $snippet "\\u" { $emphasis "xxxxxx" } } { "The Unicode code point with hexadecimal number " { $snippet { $emphasis "xxxxxx" } } } }
"A Unicode character can be specified by its code number by writing " { $snippet "\\u" } " followed by a six-digit hexadecimal number. That is, the following two expressions are equivalent:" { { $snippet "\\u{" { $emphasis "name" } "}" } { "The Unicode code point named " { $snippet { $emphasis "name" } } } }
{ $code } ;
"CHAR: \\u000078"
"78"
}
"While not useful for single characters, this syntax is also permitted inside strings." ;
ARTICLE: "syntax-strings" "Character and string syntax" ARTICLE: "syntax-strings" "Character and string syntax"
"Factor has no distinct character type, however Unicode character value integers can be read by specifying a literal character, or an escaped representation thereof." "Factor has no distinct character type, however Unicode character value integers can be read by specifying a literal character, or an escaped representation thereof."
@ -412,8 +408,17 @@ HELP: IN:
HELP: CHAR: HELP: CHAR:
{ $syntax "CHAR: token" } { $syntax "CHAR: token" }
{ $values { "token" "a literal character or escape code" } } { $values { "token" "a literal character, escape code, or Unicode character name" } }
{ $description "Adds the Unicode code point of the character represented by the token to the parse tree." } ; { $description "Adds a Unicode code point to the parse tree." }
{ $examples
{ $code
"CHAR: x"
"CHAR: \\u000032"
"CHAR: \\u{exclamation-mark}"
"CHAR: exclamation-mark"
"CHAR: ugaritic-letter-samka"
}
} ;
HELP: " HELP: "
{ $syntax "\"string...\"" } { $syntax "\"string...\"" }

12
core/syntax/syntax.factor
View File

@ -5,7 +5,8 @@ byte-vectors definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting tuples generic.standard quotations io assocs splitting tuples generic.standard
generic.math classes io.files vocabs float-arrays float-vectors generic.math classes io.files vocabs float-arrays float-vectors
classes.union classes.mixin classes.predicate compiler.units ; classes.union classes.mixin classes.predicate compiler.units
combinators ;
IN: bootstrap.syntax IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with ! These words are defined as a top-level form, instead of with
@ -56,7 +57,14 @@ IN: bootstrap.syntax
"f" [ f parsed ] define-syntax "f" [ f parsed ] define-syntax
"t" "syntax" lookup define-symbol "t" "syntax" lookup define-symbol
"CHAR:" [ 0 scan next-char nip parsed ] define-syntax "CHAR:" [
scan {
{ [ dup length 1 = ] [ first ] }
{ [ "\\" ?head ] [ next-escape drop ] }
{ [ t ] [ name>char-hook get call ] }
} cond parsed
] define-syntax
"\"" [ parse-string parsed ] define-syntax "\"" [ parse-string parsed ] define-syntax
"SBUF\"" [ "SBUF\"" [

4
core/threads/threads-docs.factor Normal file → Executable file
View File

@ -9,6 +9,7 @@ $nl
{ $subsection in-thread } { $subsection in-thread }
{ $subsection yield } { $subsection yield }
{ $subsection sleep } { $subsection sleep }
"Threads stop either when the quotation given to " { $link in-thread } " returns, or when the following word is called:"
{ $subsection stop } { $subsection stop }
"Continuations can be added to the run queue directly:" "Continuations can be added to the run queue directly:"
{ $subsection schedule-thread } { $subsection schedule-thread }
@ -21,7 +22,8 @@ ABOUT: "threads"
HELP: run-queue HELP: run-queue
{ $values { "queue" dlist } } { $values { "queue" dlist } }
{ $description "Outputs the runnable thread queue. By convention, continuations are queued with " { $link push-front } " and dequeued with " { $link pop-back } "." } ; { $description "Outputs the runnable thread queue. By convention, continuations are queued with " { $link push-front }
" and dequeued with " { $link pop-back } "." } ;
HELP: schedule-thread HELP: schedule-thread
{ $values { "continuation" "a continuation reified by " { $link callcc0 } } } { $values { "continuation" "a continuation reified by " { $link callcc0 } } }

12
core/vocabs/loader/loader.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov. ! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces splitting sequences io.files kernel assocs USING: namespaces sequences io.files kernel assocs words vocabs
words vocabs definitions parser continuations inspector debugger definitions parser continuations inspector debugger io io.styles
io io.styles io.streams.lines hashtables sorting prettyprint io.streams.lines hashtables sorting prettyprint source-files
source-files arrays combinators strings system math.parser arrays combinators strings system math.parser compiler.errors
compiler.errors ; splitting ;
IN: vocabs.loader IN: vocabs.loader
SYMBOL: vocab-roots SYMBOL: vocab-roots
@ -16,7 +16,7 @@ V{
} clone vocab-roots set-global } clone vocab-roots set-global
: vocab-dir ( vocab -- dir ) : vocab-dir ( vocab -- dir )
vocab-name "." split "/" join ; vocab-name { { CHAR: . CHAR: / } } substitute ;
: vocab-dir+ ( vocab str/f -- path ) : vocab-dir+ ( vocab str/f -- path )
>r vocab-name "." split r> >r vocab-name "." split r>

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

@ -245,8 +245,8 @@ HELP: remove-word-prop
{ $description "Removes a word property, so future lookups will output " { $link f } " until it is set again. Word property names are conventionally strings." } { $description "Removes a word property, so future lookups will output " { $link f } " until it is set again. Word property names are conventionally strings." }
{ $side-effects "word" } ; { $side-effects "word" } ;
HELP: word-xt HELP: word-xt ( word -- start end )
{ $values { "word" word } { "xt" "an execution token integer" } } { $values { "word" word } { "start" "the word's start address" } { "end" "the word's end address" } }
{ $description "Outputs the machine code address of the word's definition." } ; { $description "Outputs the machine code address of the word's definition." } ;
HELP: define-symbol HELP: define-symbol

15
extra/benchmark/sockets/sockets.factor
View File

@ -22,7 +22,7 @@ IN: benchmark.sockets
CHAR: x write1 CHAR: x write1
] with-stream ; ] with-stream ;
: socket-benchmark ( n -- ) : clients ( n -- )
dup pprint " clients: " write dup pprint " clients: " write
[ [
[ simple-server ] in-thread [ simple-server ] in-thread
@ -33,11 +33,12 @@ IN: benchmark.sockets
] time ; ] time ;
: socket-benchmarks : socket-benchmarks
10 socket-benchmark 10 clients
20 socket-benchmark 20 clients
40 socket-benchmark 40 clients
80 socket-benchmark 80 clients
160 socket-benchmark 160 clients
320 socket-benchmark ; 320 clients
640 clients ;
MAIN: socket-benchmarks MAIN: socket-benchmarks

3
extra/bootstrap/handbook/handbook.factor Executable file
View File

@ -0,0 +1,3 @@
USING: vocabs.loader vocabs kernel ;
"bootstrap.help" vocab [ "help.handbook" require ] when

4
extra/bootstrap/help/help.factor
View File

@ -14,8 +14,6 @@ IN: bootstrap.help
[ vocab-root ] subset [ vocab-root ] subset
[ vocab-source-loaded? ] subset [ vocab-source-loaded? ] subset
[ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each [ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each
] with-variable ] with-variable ;
"help.handbook" require ;
load-help load-help

3
extra/bootstrap/tools/tools.factor
View File

@ -4,10 +4,11 @@ USING: vocabs.loader sequences ;
"bootstrap.image" "bootstrap.image"
"tools.annotations" "tools.annotations"
"tools.crossref" "tools.crossref"
! "tools.deploy" "tools.deploy"
"tools.memory" "tools.memory"
"tools.profiler" "tools.profiler"
"tools.test" "tools.test"
"tools.time" "tools.time"
"tools.disassembler"
"editors" "editors"
} [ require ] each } [ require ] each

196
extra/builder/builder.factor
View File

@ -3,73 +3,43 @@ USING: kernel parser io io.files io.launcher io.sockets hashtables math threads
arrays system continuations namespaces sequences splitting math.parser arrays system continuations namespaces sequences splitting math.parser
prettyprint tools.time calendar bake vars http.client prettyprint tools.time calendar bake vars http.client
combinators bootstrap.image bootstrap.image.download combinators bootstrap.image bootstrap.image.download
combinators.cleave benchmark ; combinators.cleave benchmark
classes strings quotations words parser-combinators new-slots accessors
assocs.lib smtp builder.util ;
IN: builder IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: runtime ( quot -- time ) benchmark nip ; SYMBOL: builds-dir
: minutes>ms ( min -- ms ) 60 * 1000 * ; : builds ( -- path )
builds-dir get
home "/builds" append
or ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: builder-recipients : prepare-build-machine ( -- )
builds make-directory
: host-name* ( -- name ) host-name "." split first ; builds cd
{ "git" "clone" "git://factorcode.org/git/factor.git" } run-process drop ;
: tag-subject ( str -- str ) `{ "builder@" ,[ host-name* ] ": " , } concat ;
: email-string ( subject -- )
`{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] }
[ ] with-process-stream drop ;
: email-file ( subject file -- )
`{
{ +stdin+ , }
{ +arguments+
{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] } }
}
>hashtable run-process drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; : builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
: factor-binary ( -- name ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
os
{ { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
{ "winnt" [ "./factor-nt.exe" ] }
[ drop "./factor" ] }
case ;
: git-pull ( -- desc )
{
"git"
"pull"
"--no-summary"
"git://factorcode.org/git/factor.git"
"master"
} ;
: git-clone ( -- desc ) { "git" "clone" "../factor" } ; : git-clone ( -- desc ) { "git" "clone" "../factor" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: datestamp ( -- string )
now `{ ,[ dup timestamp-year ]
,[ dup timestamp-month ]
,[ dup timestamp-day ]
,[ dup timestamp-hour ]
,[ timestamp-minute ] }
[ pad-00 ] map "-" join ;
VAR: stamp VAR: stamp
: enter-build-dir ( -- ) : enter-build-dir ( -- )
datestamp >stamp datestamp >stamp
"/builds" cd builds cd
stamp> make-directory stamp> make-directory
stamp> cd ; stamp> cd ;
@ -82,57 +52,59 @@ VAR: stamp
: make-clean ( -- desc ) { "make" "clean" } ; : make-clean ( -- desc ) { "make" "clean" } ;
: make-vm ( -- ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
`{
{ +arguments+ { "make" ,[ target ] } } : target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ;
{ +stdout+ "../compile-log" }
{ +stderr+ +stdout+ } : make-vm ( -- desc )
} <process*>
>hashtable ; { "make" target } to-strings >>arguments
"../compile-log" >>stdout
+stdout+ >>stderr
>desc ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: factor-binary ( -- name )
os
{ { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
{ "winnt" [ "./factor-nt.exe" ] }
[ drop "./factor" ] }
case ;
: bootstrap-cmd ( -- cmd )
{ factor-binary [ "-i=" my-boot-image-name append ] "-no-user-init" }
to-strings ;
: bootstrap ( -- desc ) : bootstrap ( -- desc )
`{ <process*>
{ +arguments+ { bootstrap-cmd >>arguments
,[ factor-binary ] +closed+ >>stdin
,[ "-i=" my-boot-image-name append ] "../boot-log" >>stdout
"-no-user-init" +stdout+ >>stderr
} } 20 minutes>ms >>timeout
{ +stdout+ "../boot-log" } >desc ;
{ +stderr+ +stdout+ }
{ +timeout+ ,[ 20 minutes>ms ] }
} ;
: builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ; : builder-test ( -- desc ) { factor-binary "-run=builder.test" } to-strings ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: build-status SYMBOL: build-status
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: milli-seconds>time ( n -- string )
1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
: eval-file ( file -- obj ) <file-reader> contents eval ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cat ( file -- ) <file-reader> contents print ;
: run-or-bail ( desc quot -- )
[ [ try-process ] curry ]
[ [ throw ] curry ]
bi*
recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (build) ( -- ) : (build) ( -- )
builds-check
build-status off
enter-build-dir enter-build-dir
"report" [ "report" [
"Build machine: " write host-name print "Build machine: " write host-name print
"Build directory: " write cwd print "CPU: " write cpu print
"OS: " write os print
"Build directory: " write cwd print nl
git-clone [ "git clone failed" print ] run-or-bail git-clone [ "git clone failed" print ] run-or-bail
@ -144,33 +116,17 @@ SYMBOL: build-status
make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail
[ my-arch download-image ] [ "Image download error" print throw ] recover [ retrieve-image ] [ "Image download error" print throw ] recover
! bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
! bootstrap
! <process-stream> dup dispose process-stream-process wait-for-process
! zero? not
! [ "Bootstrap error" print "../boot-log" cat "bootstrap error" throw ]
! when
[
bootstrap
<process-stream> dup dispose process-stream-process wait-for-process
zero? not
[ "bootstrap non-zero" throw ]
when
]
[ "Bootstrap error" print "../boot-log" cat "bootstrap" throw ]
recover
[ builder-test try-process ] [ builder-test try-process ]
[ "Builder test error" print throw ] [ "Builder test error" print throw ]
recover recover
"Boot time: " write "../boot-time" eval-file milli-seconds>time print "Boot time: " write "../boot-time" eval-file milli-seconds>time print
"Load time: " write "../load-time" eval-file milli-seconds>time print "Load time: " write "../load-time" eval-file milli-seconds>time print
"Test time: " write "../test-time" eval-file milli-seconds>time print "Test time: " write "../test-time" eval-file milli-seconds>time print nl
"Did not pass load-everything: " print "../load-everything-vocabs" cat "Did not pass load-everything: " print "../load-everything-vocabs" cat
"Did not pass test-all: " print "../test-all-vocabs" cat "Did not pass test-all: " print "../test-all-vocabs" cat
@ -178,14 +134,43 @@ SYMBOL: build-status
"Benchmarks: " print "Benchmarks: " print
"../benchmarks" [ stdio get contents eval ] with-file-in benchmarks. "../benchmarks" [ stdio get contents eval ] with-file-in benchmarks.
] with-file-out ; ] with-file-out
build-status on ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: builder-from
SYMBOL: builder-recipients
: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ;
: subject ( -- str ) build-status get [ "report" ] [ "error" ] if tag-subject ;
: send-builder-email ( -- )
<email>
builder-from get >>from
builder-recipients get >>to
subject >>subject
"../report" file>string >>body
send ;
: build ( -- ) : build ( -- )
[ (build) ] [ drop ] recover [ (build) ] [ drop ] recover
"report" "../report" email-file ; [ send-builder-email ] [ drop "not sending mail" . ] recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-pull ( -- desc )
{
"git"
"pull"
"--no-summary"
"git://factorcode.org/git/factor.git"
"master"
} ;
: updates-available? ( -- ? ) : updates-available? ( -- ? )
git-id git-id
git-pull run-process drop git-pull run-process drop
@ -193,8 +178,9 @@ SYMBOL: build-status
= not ; = not ;
: build-loop ( -- ) : build-loop ( -- )
builds-check
[ [
"/builds/factor" cd builds "/factor" append cd
updates-available? updates-available?
[ build ] [ build ]
when when

46
extra/builder/server/server.factor
View File

@ -41,28 +41,28 @@ IN: builder.server
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: build-server ( -- ) ! : build-server ( -- )
receive ! receive
{ ! {
{ ! {
"start" ! "start"
[ ! [
build-status get "idle" = ! build-status get "idle" =
build-status get f = ! build-status get f =
or ! or
[ ! [
[ [ build ] [ drop ] recover "idle" build-status set-global ] ! [ [ build ] [ drop ] recover "idle" build-status set-global ]
in-thread ! in-thread
] ! ]
when ! when
] ! ]
} ! }
{ ! {
{ ?from ?tag "status" } ! { ?from ?tag "status" }
[ `{ ?tag ,[ build-status get ] } ?from send ] ! [ `{ ?tag ,[ build-status get ] } ?from send ]
} ! }
} ! }
match-cond ! match-cond
build-server ; ! build-server ;

2
extra/builder/test/test.factor
View File

@ -6,7 +6,7 @@ USING: kernel namespaces sequences assocs builder continuations
prettyprint prettyprint
tools.browser tools.browser
tools.test tools.test
bootstrap.stage2 benchmark ; bootstrap.stage2 benchmark builder.util ;
IN: builder.test IN: builder.test

86
extra/builder/util/util.factor Normal file
View File

@ -0,0 +1,86 @@
USING: kernel words namespaces classes parser continuations
io io.files io.launcher io.sockets
math math.parser
combinators sequences splitting quotations arrays strings tools.time
parser-combinators accessors assocs.lib
combinators.cleave bake calendar new-slots ;
IN: builder.util
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: runtime ( quot -- time ) benchmark nip ;
: minutes>ms ( min -- ms ) 60 * 1000 * ;
: file>string ( file -- string ) [ stdio get contents ] with-file-in ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
DEFER: to-strings
: to-string ( obj -- str )
dup class
{
{ string [ ] }
{ quotation [ call ] }
{ word [ execute ] }
{ fixnum [ number>string ] }
{ array [ to-strings concat ] }
}
case ;
: to-strings ( seq -- str )
dup [ string? ] all?
[ ]
[ [ to-string ] map flatten ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: process* arguments stdin stdout stderr timeout ;
: <process*> process* construct-empty ;
: >desc ( process* -- desc )
H{ } clone
over arguments>> [ +arguments+ swap put-at ] when*
over stdin>> [ +stdin+ swap put-at ] when*
over stdout>> [ +stdout+ swap put-at ] when*
over stderr>> [ +stderr+ swap put-at ] when*
over timeout>> [ +timeout+ swap put-at ] when*
nip ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: host-name* ( -- name ) host-name "." split first ;
: datestamp ( -- string )
now `{ ,[ dup timestamp-year ]
,[ dup timestamp-month ]
,[ dup timestamp-day ]
,[ dup timestamp-hour ]
,[ timestamp-minute ] }
[ pad-00 ] map "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: milli-seconds>time ( n -- string )
1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
: eval-file ( file -- obj ) file-contents eval ;
: cat ( file -- ) file-contents print ;
: run-or-bail ( desc quot -- )
[ [ try-process ] curry ]
[ [ throw ] compose ]
bi*
recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: bootstrap.image bootstrap.image.download io.streams.null ;
: retrieve-image ( -- ) [ my-arch download-image ] with-null-stream ;

49
extra/db/db.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math USING: arrays assocs classes continuations kernel math
namespaces sequences sequences.lib tuples words ; namespaces sequences sequences.lib tuples words strings ;
IN: db IN: db
TUPLE: db handle insert-statements update-statements delete-statements select-statements ; TUPLE: db handle insert-statements update-statements delete-statements select-statements ;
@ -36,13 +36,17 @@ HOOK: <prepared-statement> db ( str -- statement )
GENERIC: prepare-statement ( statement -- ) GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( obj statement -- ) GENERIC: bind-statement* ( obj statement -- )
GENERIC: reset-statement ( statement -- ) GENERIC: reset-statement ( statement -- )
GENERIC: execute-statement* ( statement -- result-set ) GENERIC: insert-statement ( statement -- id )
HOOK: last-id db ( res -- id )
: execute-statement ( statement -- )
execute-statement* dispose ;
: execute-statement-last-id ( statement -- id ) TUPLE: result-set sql params handle n max ;
execute-statement* [ last-id ] with-disposal ; GENERIC: query-results ( query -- result-set )
GENERIC: #rows ( result-set -- n )
GENERIC: #columns ( result-set -- n )
GENERIC# row-column 1 ( result-set n -- obj )
GENERIC: advance-row ( result-set -- )
GENERIC: more-rows? ( result-set -- ? )
: execute-statement ( statement -- ) query-results dispose ;
: bind-statement ( obj statement -- ) : bind-statement ( obj statement -- )
dup statement-bound? [ dup reset-statement ] when dup statement-bound? [ dup reset-statement ] when
@ -50,17 +54,9 @@ HOOK: last-id db ( res -- id )
[ set-statement-params ] keep [ set-statement-params ] keep
t swap set-statement-bound? ; t swap set-statement-bound? ;
TUPLE: result-set sql params handle n max ;
GENERIC: query-results ( query -- result-set )
GENERIC: #rows ( result-set -- n )
GENERIC: #columns ( result-set -- n )
GENERIC# row-column 1 ( result-set n -- obj )
GENERIC: advance-row ( result-set -- ? )
: init-result-set ( result-set -- ) : init-result-set ( result-set -- )
dup #rows over set-result-set-max dup #rows over set-result-set-max
-1 swap set-result-set-n ; 0 swap set-result-set-n ;
: <result-set> ( query handle tuple -- result-set ) : <result-set> ( query handle tuple -- result-set )
>r >r { statement-sql statement-params } get-slots r> >r >r { statement-sql statement-params } get-slots r>
@ -74,10 +70,10 @@ GENERIC: advance-row ( result-set -- ? )
dup #columns [ row-column ] with map ; dup #columns [ row-column ] with map ;
: query-each ( statement quot -- ) : query-each ( statement quot -- )
over advance-row [ over more-rows? [
2drop [ call ] 2keep over advance-row query-each
] [ ] [
[ call ] 2keep query-each 2drop
] if ; inline ] if ; inline
: query-map ( statement quot -- seq ) : query-map ( statement quot -- seq )
@ -98,11 +94,6 @@ GENERIC: advance-row ( result-set -- ? )
: do-bound-command ( obj query -- ) : do-bound-command ( obj query -- )
[ bind-statement ] keep execute-statement ; [ bind-statement ] keep execute-statement ;
: sql-query ( sql -- rows )
<simple-statement> [ do-query ] with-disposal ;
: sql-command ( sql -- )
<simple-statement> [ execute-statement ] with-disposal ;
SYMBOL: in-transaction SYMBOL: in-transaction
HOOK: begin-transaction db ( -- ) HOOK: begin-transaction db ( -- )
@ -116,3 +107,13 @@ HOOK: rollback-transaction db ( -- )
begin-transaction begin-transaction
[ ] [ rollback-transaction ] cleanup commit-transaction [ ] [ rollback-transaction ] cleanup commit-transaction
] with-variable ; ] with-variable ;
: sql-query ( sql -- rows )
<simple-statement> [ do-query ] with-disposal ;
: sql-command ( sql -- )
dup string? [
<simple-statement> [ execute-statement ] with-disposal
] [
[ [ sql-command ] each ] with-transaction
] if ;

11
extra/db/postgresql/lib/lib.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays continuations db io kernel math namespaces USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types ; quotations sequences db.postgresql.ffi alien alien.c-types
db.types ;
IN: db.postgresql.lib IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f ) : postgresql-result-error-message ( res -- str/f )
@ -37,13 +38,9 @@ IN: db.postgresql.lib
>r db get db-handle r> >r db get db-handle r>
[ statement-sql ] keep [ statement-sql ] keep
[ statement-params length f ] keep [ statement-params length f ] keep
statement-params [ second malloc-char-string ] map >c-void*-array statement-params
[ first number>string* malloc-char-string ] map >c-void*-array
f f 0 PQexecParams f f 0 PQexecParams
dup postgresql-result-ok? [ dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw dup postgresql-result-error-message swap PQclear throw
] unless ; ] unless ;
: pq-oid-value ( res -- n )
PQoidValue dup InvalidOid = [
"postgresql returned an InvalidOid" throw
] when ;

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

@ -2,7 +2,7 @@
! Set username and password in the 'connect' word. ! Set username and password in the 'connect' word.
USING: kernel db.postgresql alien continuations io prettyprint USING: kernel db.postgresql alien continuations io prettyprint
sequences namespaces tools.test db ; sequences namespaces tools.test db db.types ;
IN: temporary IN: temporary
IN: scratchpad IN: scratchpad
@ -40,13 +40,13 @@ IN: temporary
test-db [ test-db [
"select * from person where name = $1 and country = $2" "select * from person where name = $1 and country = $2"
<simple-statement> [ <simple-statement> [
{ "Jane" "New Zealand" } { { "Jane" TEXT } { "New Zealand" TEXT } }
over do-bound-query over do-bound-query
{ { "Jane" "New Zealand" } } = { { "Jane" "New Zealand" } } =
[ "test fails" throw ] unless [ "test fails" throw ] unless
{ "John" "America" } { { "John" TEXT } { "America" TEXT } }
swap do-bound-query swap do-bound-query
] with-disposal ] with-disposal
] with-db ] with-db

162
extra/db/postgresql/postgresql.factor
View File

@ -3,7 +3,7 @@
USING: arrays assocs alien alien.syntax continuations io USING: arrays assocs alien alien.syntax continuations io
kernel math math.parser namespaces prettyprint quotations kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types ; db.tuples db.types tools.annotations math.ranges ;
IN: db.postgresql IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ; TUPLE: postgresql-db host port pgopts pgtty db user pass ;
@ -52,11 +52,11 @@ M: postgresql-result-set #columns ( result-set -- n )
M: postgresql-result-set row-column ( result-set n -- obj ) M: postgresql-result-set row-column ( result-set n -- obj )
>r dup result-set-handle swap result-set-n r> PQgetvalue ; >r dup result-set-handle swap result-set-n r> PQgetvalue ;
M: postgresql-statement execute-statement* ( statement -- obj ) M: postgresql-result-set row-column ( result-set n -- obj )
query-results ; >r dup result-set-handle swap result-set-n r> PQgetvalue ;
: increment-n ( result-set -- n ) M: postgresql-statement insert-statement ( statement -- id )
dup result-set-n 1+ dup rot set-result-set-n ; query-results [ break 0 row-column ] with-disposal ;
M: postgresql-statement query-results ( query -- result-set ) M: postgresql-statement query-results ( query -- result-set )
dup statement-params [ dup statement-params [
@ -68,8 +68,11 @@ M: postgresql-statement query-results ( query -- result-set )
postgresql-result-set <result-set> postgresql-result-set <result-set>
dup init-result-set ; dup init-result-set ;
M: postgresql-result-set advance-row ( result-set -- ? ) M: postgresql-result-set advance-row ( result-set -- )
dup increment-n swap result-set-max >= ; dup result-set-n 1+ swap set-result-set-n ;
M: postgresql-result-set more-rows? ( result-set -- ? )
dup result-set-n swap result-set-max < ;
M: postgresql-statement dispose ( query -- ) M: postgresql-statement dispose ( query -- )
dup statement-handle PQclear dup statement-handle PQclear
@ -105,36 +108,105 @@ M: postgresql-db commit-transaction ( -- )
M: postgresql-db rollback-transaction ( -- ) M: postgresql-db rollback-transaction ( -- )
"ROLLBACK" sql-command ; "ROLLBACK" sql-command ;
: postgresql-type-hash* ( -- assoc )
H{
{ SERIAL "serial" }
} ;
M: postgresql-db create-sql ( columns table -- sql ) : postgresql-type-hash ( -- assoc )
H{
{ INTEGER "integer" }
{ SERIAL "integer" }
{ TEXT "text" }
{ VARCHAR "varchar" }
{ DOUBLE "real" }
} ;
: enquote ( str -- newstr ) "(" swap ")" 3append ;
: postgresql-type ( str n/str -- newstr )
" " swap number>string* enquote 3append ;
: >sql-type* ( obj -- str )
dup pair? [
first2 >r >sql-type* r> postgresql-type
] [
dup postgresql-type-hash* at* [
nip
] [
drop >sql-type
] if
] if ;
M: postgresql-db >sql-type ( hash obj -- str )
dup pair? [
first2 >r >sql-type r> postgresql-type
] [
postgresql-type-hash at* [
no-sql-type
] unless
] if ;
: insert-function ( columns table -- sql )
[ [
"create table " % % >r remove-id r>
" (" % [ ", " % ] [ "create function add_" % dup %
dup second % " " % "(" %
dup third >sql-type % " " % over [ "," % ]
sql-modifiers " " join % [ third dup array? [ first ] when >sql-type % ] interleave
] interleave ")" % ")" %
] "" make ; " returns bigint as '" %
M: postgresql-db drop-sql ( table -- sql ) 2dup "insert into " %
[
"drop table " % %
] "" make ;
SYMBOL: postgresql-counter
M: postgresql-db insert-sql* ( columns table -- sql )
[
postgresql-counter off
"insert into " %
% %
"(" % "(" %
dup [ ", " % ] [ second % ] interleave dup [ ", " % ] [ second % ] interleave
") " % ") " %
" values (" % " values (" %
[ ", " % ] [ length [1,b] [ ", " % ] [ "$" % # ] interleave
drop "$" % postgresql-counter [ inc ] keep get # "); " %
] interleave
"select currval(''" % % "_id_seq'');' language sql;" %
drop
] "" make ;
: drop-function ( columns table -- sql )
[
>r remove-id r>
"drop function add_" % %
"(" %
[ "," % ] [ third >sql-type % ] interleave
")" %
] "" make ;
M: postgresql-db create-sql ( columns table -- seq )
[
[
2dup
"create table " % %
" (" % [ ", " % ] [
dup second % " " %
dup third >sql-type* % " " %
sql-modifiers " " join %
] interleave "); " %
] "" make ,
over native-id? [ insert-function , ] [ 2drop ] if
] { } make ;
M: postgresql-db drop-sql ( columns table -- seq )
[
[
dup "drop table " % % ";" %
] "" make ,
over native-id? [ drop-function , ] [ 2drop ] if
] { } make ;
M: postgresql-db insert-sql* ( columns table -- sql )
[
"select add_" % %
"(" %
length [1,b] [ ", " % ] [ "$" % # ] interleave
")" % ")" %
] "" make ; ] "" make ;
@ -144,9 +216,10 @@ M: postgresql-db update-sql* ( columns table -- sql )
% %
" set " % " set " %
dup remove-id dup remove-id
[ ", " % ] [ second dup % " = :" % % ] interleave dup length [1,b] swap 2array flip
[ ", " % ] [ first2 second % " = $" % # ] interleave
" where " % " where " %
[ primary-key? ] find nip second dup % " = :" % % [ primary-key? ] find nip second dup % " = $" % length 2 + #
] "" make ; ] "" make ;
M: postgresql-db delete-sql* ( columns table -- sql ) M: postgresql-db delete-sql* ( columns table -- sql )
@ -154,23 +227,19 @@ M: postgresql-db delete-sql* ( columns table -- sql )
"delete from " % "delete from " %
% %
" where " % " where " %
first second dup % " = :" % % first second % " = $1" %
] "" make ; ] "" make ;
M: postgresql-db select-sql* ( columns table -- sql ) M: postgresql-db select-sql* ( columns table -- sql )
drop ; drop ;
M: postgresql-db tuple>params ( columns tuple -- obj ) M: postgresql-db tuple>params ( columns tuple -- obj )
[ [ >r dup third swap first r> get-slot-named swap ]
>r dup first r> get-slot-named swap third curry { } map>assoc ;
] curry { } map>assoc ;
M: postgresql-db last-id ( res -- id )
pq-oid-value ;
: postgresql-db-modifiers ( -- hashtable ) : postgresql-db-modifiers ( -- hashtable )
H{ H{
{ +native-id+ "primary key" } { +native-id+ "not null primary key" }
{ +assigned-id+ "primary key" } { +assigned-id+ "primary key" }
{ +autoincrement+ "autoincrement" } { +autoincrement+ "autoincrement" }
{ +unique+ "unique" } { +unique+ "unique" }
@ -189,18 +258,3 @@ M: postgresql-db sql-modifiers* ( modifiers -- str )
swap at swap at
] if ] if
] with map [ ] subset ; ] with map [ ] subset ;
: postgresql-type-hash ( -- assoc )
H{
{ INTEGER "integer" }
{ TEXT "text" }
{ VARCHAR "text" }
{ DOUBLE "real" }
} ;
M: postgresql-db >sql-type ( obj -- str )
dup pair? [
first >sql-type
] [
postgresql-type-hash at* [ T{ no-sql-type } throw ] unless
] if ;

11
extra/db/sqlite/lib/lib.factor
View File

@ -74,10 +74,11 @@ IN: db.sqlite.lib
dup array? [ first ] when dup array? [ first ] when
{ {
{ INTEGER [ sqlite-bind-int-by-name ] } { INTEGER [ sqlite-bind-int-by-name ] }
{ BIG_INTEGER [ sqlite-bind-int-by-name ] } { BIG_INTEGER [ sqlite-bind-int64-by-name ] }
{ TEXT [ sqlite-bind-text-by-name ] } { TEXT [ sqlite-bind-text-by-name ] }
{ VARCHAR [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] }
{ DOUBLE [ sqlite-bind-double-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] }
{ SERIAL [ sqlite-bind-int-by-name ] }
! { NULL [ sqlite-bind-null-by-name ] } ! { NULL [ sqlite-bind-null-by-name ] }
[ no-sql-type ] [ no-sql-type ]
} case ; } case ;
@ -99,13 +100,13 @@ IN: db.sqlite.lib
: sqlite-row ( handle -- seq ) : sqlite-row ( handle -- seq )
dup sqlite-#columns [ sqlite-column ] with map ; dup sqlite-#columns [ sqlite-column ] with map ;
: step-complete? ( step-result -- bool ) : sqlite-step-has-more-rows? ( step-result -- bool )
dup SQLITE_ROW = [ dup SQLITE_ROW = [
drop f drop t
] [ ] [
dup SQLITE_DONE = dup SQLITE_DONE =
[ drop ] [ sqlite-check-result ] if t [ drop ] [ sqlite-check-result ] if f
] if ; ] if ;
: sqlite-next ( prepared -- ? ) : sqlite-next ( prepared -- ? )
sqlite3_step step-complete? ; sqlite3_step sqlite-step-has-more-rows? ;

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

@ -25,9 +25,7 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
TUPLE: sqlite-statement ; TUPLE: sqlite-statement ;
C: <sqlite-statement> sqlite-statement C: <sqlite-statement> sqlite-statement
TUPLE: sqlite-result-set advanced? ; TUPLE: sqlite-result-set has-more? ;
: <sqlite-result-set> ( query -- sqlite-result-set )
dup statement-handle sqlite-result-set <result-set> ;
M: sqlite-db <simple-statement> ( str -- obj ) M: sqlite-db <simple-statement> ( str -- obj )
<prepared-statement> ; <prepared-statement> ;
@ -40,13 +38,7 @@ M: sqlite-db <prepared-statement> ( str -- obj )
M: sqlite-statement dispose ( statement -- ) M: sqlite-statement dispose ( statement -- )
statement-handle sqlite-finalize ; statement-handle sqlite-finalize ;
: maybe-advance-row ( result-set -- result-set )
dup sqlite-result-set-advanced? [
dup advance-row drop
] unless ;
M: sqlite-result-set dispose ( result-set -- ) M: sqlite-result-set dispose ( result-set -- )
maybe-advance-row
f swap set-result-set-handle ; f swap set-result-set-handle ;
: sqlite-bind ( triples handle -- ) : sqlite-bind ( triples handle -- )
@ -58,8 +50,12 @@ M: sqlite-statement bind-statement* ( triples statement -- )
M: sqlite-statement reset-statement ( statement -- ) M: sqlite-statement reset-statement ( statement -- )
statement-handle sqlite-reset ; statement-handle sqlite-reset ;
M: sqlite-statement execute-statement* ( statement -- obj ) : last-insert-id ( -- id )
query-results ; db get db-handle sqlite3_last_insert_rowid
dup zero? [ "last-id failed" throw ] when ;
M: sqlite-statement insert-statement ( statement -- id )
execute-statement last-insert-id ;
M: sqlite-result-set #columns ( result-set -- n ) M: sqlite-result-set #columns ( result-set -- n )
result-set-handle sqlite-#columns ; result-set-handle sqlite-#columns ;
@ -67,12 +63,16 @@ M: sqlite-result-set #columns ( result-set -- n )
M: sqlite-result-set row-column ( result-set n -- obj ) M: sqlite-result-set row-column ( result-set n -- obj )
>r result-set-handle r> sqlite-column ; >r result-set-handle r> sqlite-column ;
M: sqlite-result-set advance-row ( result-set -- handle ? ) M: sqlite-result-set advance-row ( result-set -- )
[ result-set-handle sqlite-next ] keep [ result-set-handle sqlite-next ] keep
t swap set-sqlite-result-set-advanced? ; set-sqlite-result-set-has-more? ;
M: sqlite-result-set more-rows? ( result-set -- ? )
sqlite-result-set-has-more? ;
M: sqlite-statement query-results ( query -- result-set ) M: sqlite-statement query-results ( query -- result-set )
dup statement-handle sqlite-result-set <result-set> ; dup statement-handle sqlite-result-set <result-set>
dup advance-row ;
M: sqlite-db begin-transaction ( -- ) M: sqlite-db begin-transaction ( -- )
"BEGIN" sql-command ; "BEGIN" sql-command ;
@ -93,9 +93,10 @@ M: sqlite-db create-sql ( columns table -- sql )
] interleave ")" % ] interleave ")" %
] "" make ; ] "" make ;
M: sqlite-db drop-sql ( table -- sql ) M: sqlite-db drop-sql ( columns table -- sql )
[ [
"drop table " % % "drop table " % %
drop
] "" make ; ] "" make ;
M: sqlite-db insert-sql* ( columns table -- sql ) M: sqlite-db insert-sql* ( columns table -- sql )
@ -144,11 +145,6 @@ M: sqlite-db tuple>params ( columns tuple -- obj )
dupd >r first r> get-slot-named swap dupd >r first r> get-slot-named swap
third 3array third 3array
] curry map ; ] curry map ;
M: sqlite-db last-id ( result-set -- id )
maybe-advance-row drop
db get db-handle sqlite3_last_insert_rowid
dup zero? [ "last-id failed" throw ] when ;
: sqlite-db-modifiers ( -- hashtable ) : sqlite-db-modifiers ( -- hashtable )
H{ H{
@ -175,6 +171,7 @@ M: sqlite-db sql-modifiers* ( modifiers -- str )
: sqlite-type-hash ( -- assoc ) : sqlite-type-hash ( -- assoc )
H{ H{
{ INTEGER "integer" } { INTEGER "integer" }
{ SERIAL "integer" }
{ TEXT "text" } { TEXT "text" }
{ VARCHAR "text" } { VARCHAR "text" }
{ DOUBLE "real" } { DOUBLE "real" }
@ -190,4 +187,3 @@ M: sqlite-db >sql-type ( obj -- str )
! HOOK: get-column-value ( n result-set type -- ) ! HOOK: get-column-value ( n result-set type -- )
! M: sqlite get-column-value { { "TEXT" get-text-column } { ! M: sqlite get-column-value { { "TEXT" get-text-column } {
! "INTEGER" get-integer-column } ... } case ; ! "INTEGER" get-integer-column } ... } case ;

17
extra/db/tuples/tuples-tests.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel tools.test db db.sqlite db.tuples USING: io.files kernel tools.test db db.sqlite db.tuples
db.types continuations namespaces db.postgresql math db.types continuations namespaces db.postgresql math ;
tools.time ; ! tools.time ;
IN: temporary IN: temporary
TUPLE: person the-id the-name the-number real ; TUPLE: person the-id the-name the-number real ;
@ -30,7 +30,8 @@ SYMBOL: the-person
[ ] [ the-person get update-tuple ] unit-test [ ] [ the-person get update-tuple ] unit-test
[ ] [ the-person get delete-tuple ] unit-test ; [ ] [ the-person get delete-tuple ] unit-test
[ ] [ person drop-table ] unit-test ;
: test-sqlite ( -- ) : test-sqlite ( -- )
"tuples-test.db" resource-path <sqlite-db> [ "tuples-test.db" resource-path <sqlite-db> [
@ -44,7 +45,7 @@ SYMBOL: the-person
person "PERSON" person "PERSON"
{ {
{ "the-id" "ROWID" INTEGER +native-id+ } { "the-id" "ID" SERIAL +native-id+ }
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
{ "the-number" "AGE" INTEGER { +default+ 0 } } { "the-number" "AGE" INTEGER { +default+ 0 } }
{ "real" "REAL" DOUBLE { +default+ 0.3 } } { "real" "REAL" DOUBLE { +default+ 0.3 } }
@ -52,12 +53,12 @@ person "PERSON"
"billy" 10 3.14 <person> the-person set "billy" 10 3.14 <person> the-person set
test-sqlite ! test-sqlite
! test-postgresql test-postgresql
person "PERSON" person "PERSON"
{ {
{ "the-id" "ROWID" INTEGER +assigned-id+ } { "the-id" "ID" INTEGER +assigned-id+ }
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
{ "the-number" "AGE" INTEGER { +default+ 0 } } { "the-number" "AGE" INTEGER { +default+ 0 } }
{ "real" "REAL" DOUBLE { +default+ 0.3 } } { "real" "REAL" DOUBLE { +default+ 0.3 } }
@ -65,5 +66,5 @@ person "PERSON"
1 "billy" 20 6.28 <assigned-person> the-person set 1 "billy" 20 6.28 <assigned-person> the-person set
test-sqlite ! test-sqlite
! test-postgresql ! test-postgresql

9
extra/db/tuples/tuples.factor
View File

@ -38,8 +38,9 @@ TUPLE: no-slot-named ;
[ db-table dupd ] swap [ db-table dupd ] swap
[ <prepared-statement> ] 3compose cache nip ; inline [ <prepared-statement> ] 3compose cache nip ; inline
HOOK: create-sql db ( columns table -- sql ) HOOK: create-sql db ( columns table -- seq )
HOOK: drop-sql db ( table -- sql ) HOOK: drop-sql db ( columns table -- seq )
HOOK: insert-sql* db ( columns table -- sql ) HOOK: insert-sql* db ( columns table -- sql )
HOOK: update-sql* db ( columns table -- sql ) HOOK: update-sql* db ( columns table -- sql )
HOOK: delete-sql* db ( columns table -- sql ) HOOK: delete-sql* db ( columns table -- sql )
@ -75,12 +76,12 @@ HOOK: tuple>params db ( columns tuple -- obj )
dup db-columns swap db-table create-sql sql-command ; dup db-columns swap db-table create-sql sql-command ;
: drop-table ( class -- ) : drop-table ( class -- )
db-table drop-sql sql-command ; dup db-columns swap db-table drop-sql sql-command ;
: insert-tuple ( tuple -- ) : insert-tuple ( tuple -- )
[ [
[ maybe-remove-id ] [ insert-sql ] [ maybe-remove-id ] [ insert-sql ]
make-tuple-statement execute-statement-last-id make-tuple-statement insert-statement
] keep set-primary-key ; ] keep set-primary-key ;
: update-tuple ( tuple -- ) : update-tuple ( tuple -- )

7
extra/db/types/types.factor
View File

@ -11,6 +11,12 @@ SYMBOL: +assigned-id+
: primary-key? ( spec -- ? ) : primary-key? ( spec -- ? )
[ { +native-id+ +assigned-id+ } member? ] contains? ; [ { +native-id+ +assigned-id+ } member? ] contains? ;
: contains-id? ( columns id -- ? )
swap [ member? ] with contains? ;
: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ;
: native-id? ( columns -- ? ) +native-id+ contains-id? ;
! Same concept, SQLite has autoincrement, PostgreSQL has serial ! Same concept, SQLite has autoincrement, PostgreSQL has serial
SYMBOL: +autoincrement+ SYMBOL: +autoincrement+
SYMBOL: +serial+ SYMBOL: +serial+
@ -22,6 +28,7 @@ SYMBOL: +not-null+
SYMBOL: +has-many+ SYMBOL: +has-many+
SYMBOL: SERIAL
SYMBOL: INTEGER SYMBOL: INTEGER
SYMBOL: DOUBLE SYMBOL: DOUBLE
SYMBOL: BOOLEAN SYMBOL: BOOLEAN

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

@ -1,8 +1,8 @@
USING: help help.markup help.syntax help.topics USING: help help.markup help.syntax help.definitions help.topics
namespaces words sequences classes assocs vocabs kernel namespaces words sequences classes assocs vocabs kernel arrays
arrays prettyprint.backend kernel.private io tools.browser prettyprint.backend kernel.private io generic math system
generic math tools.profiler system ui strings sbufs vectors strings sbufs vectors byte-arrays bit-arrays float-arrays
byte-arrays bit-arrays float-arrays quotations help.lint ; quotations ;
IN: help.handbook IN: help.handbook
ARTICLE: "conventions" "Conventions" ARTICLE: "conventions" "Conventions"
@ -161,15 +161,20 @@ ARTICLE: "io" "Input and output"
{ $subsection "io.timeouts" } ; { $subsection "io.timeouts" } ;
ARTICLE: "tools" "Developer tools" ARTICLE: "tools" "Developer tools"
{ $subsection "tools.annotations" } "Exploratory tools:"
{ $subsection "tools.crossref" }
{ $subsection "editor" } { $subsection "editor" }
{ $subsection "tools.crossref" }
{ $subsection "inspector" } { $subsection "inspector" }
"Debugging tools:"
{ $subsection "tools.annotations" }
{ $subsection "tools.test" }
{ $subsection "meta-interpreter" } { $subsection "meta-interpreter" }
"Performance tools:"
{ $subsection "tools.memory" } { $subsection "tools.memory" }
{ $subsection "profiling" } { $subsection "profiling" }
{ $subsection "tools.test" }
{ $subsection "timing" } { $subsection "timing" }
{ $subsection "tools.disassembler" }
"Deployment tools:"
{ $subsection "tools.deploy" } ; { $subsection "tools.deploy" } ;
ARTICLE: "article-index" "Article index" ARTICLE: "article-index" "Article index"
@ -201,7 +206,6 @@ ARTICLE: "handbook" "Factor documentation"
{ $subsection "cookbook" } { $subsection "cookbook" }
{ $subsection "first-program" } { $subsection "first-program" }
{ $subsection "vocab-index" } { $subsection "vocab-index" }
{ $subsection "changes" }
{ $heading "Language reference" } { $heading "Language reference" }
{ $subsection "conventions" } { $subsection "conventions" }
{ $subsection "syntax" } { $subsection "syntax" }
@ -231,137 +235,6 @@ ARTICLE: "handbook" "Factor documentation"
{ $subsection "type-index" } { $subsection "type-index" }
{ $subsection "class-index" } ; { $subsection "class-index" } ;
USING: io.files io.sockets float-arrays inference ;
ARTICLE: "changes" "Changes in the latest release"
{ $heading "Factor 0.91" }
{ $subheading "Performance" }
{ $list
{ "Continuations are now supported by the static stack effect system. This means that the " { $link infer } " word and the optimizing compiler now both support code which uses continuations." }
{ "Many words which previously ran in the interpreter, such as error handling and I/O, are now compiled to optimized machine code." }
{ "A non-optimizing, just-in-time compiler replaces the interpreter with no loss in functionality or introspective ability." }
{ "The non-optimizing compiler compiles quotations the first time they are called, generating a series of stack pushes and subroutine calls. It offers a 33%-50% performance increase over the interpreter." }
{ "The optimizing compiler now performs some more representation inference. Alien pointers are unboxed where possible. This improves performance of the " { $vocab-link "ogg.player" } " Ogg Theora video player." }
{ "The queue of sleeping tasks is now a sorted priority queue. This reduces overhead for workloads involving large numbers of sleeping threads (Doug Coleman)" }
{ "Improved hash code algorithm for sequences" }
{ "New, efficient implementations of " { $link bit? } " and " { $link log2 } " runs in constant time for large bignums" }
{ "New " { $link big-random } " word for generating large random numbers quickly" }
{ "Improved profiler no longer has to be explicitly enabled and disabled with a full recompile; instead, the " { $link profile } " word can be used at any time, and it dynamically patches words to increment call counts. There is no overhead when the profiler is not in use." }
{ "Calls to " { $link member? } " with a literal sequence are now open-coded. If there are four or fewer elements, a series of conditionals are generated; if there are more than four elements, there is a hash dispatch followed by conditionals in each branch." }
}
{ $subheading "IO" }
{ $list
{ "More robust Windows CE native I/O" }
{ "New " { $link os-envs } " word to get the current set of environment variables" }
{ "Redesigned " { $vocab-link "io.launcher" } " supports passing environment variables to the child process" }
{ { $link <process-stream> } " implemented on Windows (Doug Coleman)" }
{ "Updated " { $vocab-link "io.mmap" } " for new module system, now supports Windows CE (Doug Coleman)" }
{ { $vocab-link "io.sniffer" } " - packet sniffer library (Doug Coleman, Elie Chaftari)" }
{ { $vocab-link "io.server" } " - improved logging support, logs to a file by default" }
{ { $vocab-link "io.files" } " - several new file system manipulation words added" }
{ { $vocab-link "tar" } " - tar file extraction in pure Factor (Doug Coleman)" }
{ { $vocab-link "unix.linux" } ", " { $vocab-link "raptor" } " - ``Raptor Linux'', a set of alien bindings to low-level Linux features, such as network interface configuration, file system mounting/unmounting, etc, together with experimental boot scripts intended to entirely replace " { $snippet "/sbin/init" } ", " { $snippet "/etc/inittab" } " and " { $snippet "/etc/init.d/" } " (Eduardo Cavazos)." }
}
{ $subheading "Tools" }
{ $list
{ "Graphical deploy tool added - see " { $link "ui.tools.deploy" } }
{ "The deploy tool now supports Windows" }
{ { $vocab-link "network-clipboard" } " - clipboard synchronization with a simple TCP/IP protocol" }
}
{ $subheading "UI" }
{ $list
{ { $vocab-link "cairo" } " - updated for new module system, new features (Sampo Vuori)" }
{ { $vocab-link "springies" } " - physics simulation UI demo (Eduardo Cavazos)" }
{ { $vocab-link "ui.gadgets.buttons" } " - added check box and radio button gadgets" }
{ "Double- and triple-click-drag now supported in the editor gadget to select words or lines at a time" }
{ "Windows can be closed on request now using " { $link close-window } }
{ "New icons (Elie Chaftari)" }
}
{ $subheading "Libraries" }
{ $list
{ "The " { $snippet "queues" } " vocabulary has been removed because its functionality is a subset of " { $vocab-link "dlists" } }
{ "The " { $vocab-link "webapps.cgi" } " vocabulary implements CGI support for the Factor HTTP server." }
{ "The optimizing compiler no longer depends on the number tower and it is possible to bootstrap a minimal image by just passing " { $snippet "-include=compiler" } " to stage 2 bootstrap." }
{ { $vocab-link "benchmark.knucleotide" } " - new benchmark (Eric Mertens)" }
{ { $vocab-link "channels" } " - concurrent message passing over message channels" }
{ { $vocab-link "destructors" } " - deterministic scope-based resource deallocation (Doug Coleman)" }
{ { $vocab-link "dlists" } " - various updates (Doug Coleman)" }
{ { $vocab-link "editors.emeditor" } " - EmEditor integration (Doug Coleman)" }
{ { $vocab-link "editors.editplus" } " - EditPlus integration (Aaron Schaefer)" }
{ { $vocab-link "editors.notepadpp" } " - Notepad++ integration (Doug Coleman)" }
{ { $vocab-link "editors.ted-notepad" } " - TED Notepad integration (Doug Coleman)" }
{ { $vocab-link "editors.ultraedit" } " - UltraEdit integration (Doug Coleman)" }
{ { $vocab-link "globs" } " - simple Unix shell-style glob patterns" }
{ { $vocab-link "heaps" } " - updated for new module system and cleaned up (Doug Coleman)" }
{ { $vocab-link "peg" } " - Parser Expression Grammars, a new appoach to parser construction, similar to parser combinators (Chris Double)" }
{ { $vocab-link "regexp" } " - revived from " { $snippet "unmaintained/" } " and completely redesigned (Doug Coleman)" }
{ { $vocab-link "rss" } " - add Atom feed generation (Daniel Ehrenberg)" }
{ { $vocab-link "tuples.lib" } " - some utility words for working with tuples (Doug Coleman)" }
{ { $vocab-link "webapps.pastebin" } " - improved appearance, add Atom feed generation, add syntax highlighting using " { $vocab-link "xmode" } }
{ { $vocab-link "webapps.planet" } " - add Atom feed generation" }
}
{ $heading "Factor 0.90" }
{ $subheading "Core" }
{ $list
{ "New module system; see " { $link "vocabs.loader" } ". (Eduardo Cavazos)" }
{ "Tuple constructors are defined differently now; see " { $link "tuple-constructors" } "." }
{ "Mixin classes implemented; these are essentially extensible unions. See " { $link "mixins" } "." }
{ "New " { $link float-array } " data type implements a space-efficient sequence of floats." }
{ "Moved " { $link <file-appender> } ", " { $link delete-file } ", " { $link make-directory } ", " { $link delete-directory } " words from " { $snippet "libs/io" } " into the core, and fixed them to work on more platforms." }
{ "New " { $link host-name } " word." }
{ "The " { $link directory } " word now outputs an array of pairs, with the second element of each pair indicating if that entry is a subdirectory. This saves an unnecessary " { $link stat } " call when traversing directory hierarchies, which speeds things up." }
{ "IPv6 is now supported, along with Unix domain sockets (the latter on Unix systems only). The stack effects of " { $link <client> } " and " { $link <server> } " have changed, since they now take generic address specifiers; see " { $link "network-streams" } "." }
{ "The stage 2 bootstrap process is more flexible, and various subsystems such as help, tools and the UI can be omitted by supplying command line switches; see " { $link "bootstrap-cli-args" } "." }
{ "The " { $snippet "-shell" } " command line switch has been replaced by a " { $snippet "-run" } " command line switch; see " { $link "standard-cli-args" } "." }
{ "Variable usage inference has been removed; the " { $link infer } " word no longer reports this information." }
}
{ $subheading "Tools" }
{ $list
{ "Stand-alone image deployment; see " { $link "tools.deploy" } "." }
{ "Stand-alone application bundle deployment on Mac OS X; see " { $vocab-link "tools.deploy.app" } "." }
{ "New vocabulary browser tool in the UI." }
{ "New profiler tool in the UI." }
}
{ $subheading "Extras" }
"Most existing libraries were improved when ported to the new module system; the most notable changes include:"
{ $list
{ { $vocab-link "asn1" } ": ASN1 parser and writer. (Elie Chaftari)" }
{ { $vocab-link "benchmark" } ": new set of benchmarks." }
{ { $vocab-link "cfdg" } ": Context-free design grammar implementation; see " { $url "http://www.chriscoyne.com/cfdg/" } ". (Eduardo Cavazos)" }
{ { $vocab-link "cryptlib" } ": Cryptlib library binding. (Elie Chaftari)" }
{ { $vocab-link "cryptlib.streams" } ": Streams which perform SSL encryption and decryption. (Matthew Willis)" }
{ { $vocab-link "hints" } ": Give type specialization hints to the compiler." }
{ { $vocab-link "inverse" } ": Invertible computation and concatenative pattern matching. (Daniel Ehrenberg)" }
{ { $vocab-link "ldap" } ": OpenLDAP library binding. (Elie Chaftari)" }
{ { $vocab-link "locals" } ": Efficient lexically scoped locals, closures, and local words." }
{ { $vocab-link "mortar" } ": Experimental message-passing object system. (Eduardo Cavazos)" }
{ { $vocab-link "openssl" } ": OpenSSL library binding. (Elie Chaftari)" }
{ { $vocab-link "pack" } ": Utility for reading and writing binary data. (Doug Coleman)" }
{ { $vocab-link "pdf" } ": Haru PDF library binding. (Elie Chaftari)" }
{ { $vocab-link "qualified" } ": Refer to words from another vocabulary without adding the entire vocabulary to the search path. (Daniel Ehrenberg)" }
{ { $vocab-link "roman" } ": Reading and writing Roman numerals. (Doug Coleman)" }
{ { $vocab-link "scite" } ": SciTE editor integration. (Clemens Hofreither)" }
{ { $vocab-link "smtp" } ": SMTP client with support for CRAM-MD5 authentication. (Elie Chaftari, Dirk Vleugels)" }
{ { $vocab-link "tuple-arrays" } ": Space-efficient packed tuple arrays. (Daniel Ehrenberg)" }
{ { $vocab-link "unicode" } ": major new functionality added. (Daniel Ehrenberg)" }
}
{ $subheading "Performance" }
{ $list
{ "The " { $link curry } " word now runs in constant time, and curried quotations can be called from compiled code; this allows for abstractions and idioms which were previously impractical due to performance issues. In particular, words such as " { $snippet "each-with" } " and " { $snippet "map-with" } " are gone; " { $snippet "each-with" } " can now be written as " { $snippet "with each" } ", and similarly for other " { $snippet "-with" } " combinators." }
"Improved generational promotion strategy in garbage collector reduces the amount of junk which makes its way into tenured space, which in turn reduces the frequency of full garbage collections."
"Faster generic word dispatch and union membership testing."
{ "Alien memory accessors (" { $link "reading-writing-memory" } ") are compiled as intrinsics where possible, which improves performance in code which iteroperates with C libraries." }
}
{ $subheading "Platforms" }
{ $list
"Networking support added for Windows CE. (Doug Coleman)"
"UDP/IP networking support added for all Windows platforms. (Doug Coleman)"
"Solaris/x86 fixes. (Samuel Tardieu)"
"Linux/AMD64 port works again."
} ;
{ <array> <string> <sbuf> <vector> <byte-array> <bit-array> <float-array> } { <array> <string> <sbuf> <vector> <byte-array> <bit-array> <float-array> }
related-words related-words

2
extra/http/http.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2007 Slava Pestov. ! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: hashtables io kernel math namespaces math.parser assocs USING: hashtables io kernel math namespaces math.parser assocs
sequences strings splitting ascii io.utf8 assocs.lib sequences strings splitting ascii io.encodings.utf8 assocs.lib
namespaces unicode.case ; namespaces unicode.case ;
IN: http IN: http

29
extra/icfp/2006/2006.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Gavin Harrison ! Copyright (C) 2007 Gavin Harrison
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences kernel.private namespaces arrays io io.files USING: kernel math sequences kernel.private namespaces arrays io
splitting io.binary math.functions vectors quotations sequences.private ; io.files splitting io.binary math.functions vectors quotations
combinators ;
IN: icfp.2006 IN: icfp.2006
SYMBOL: regs SYMBOL: regs
@ -9,10 +10,6 @@ SYMBOL: arrays
SYMBOL: finger SYMBOL: finger
SYMBOL: open-arrays SYMBOL: open-arrays
: call-nth ( n array -- )
>r >fixnum r> 2dup nth quotation?
[ dispatch ] [ "Not a quotation" throw ] if ; inline
: reg-val ( m -- n ) regs get nth ; : reg-val ( m -- n ) regs get nth ;
: set-reg ( val n -- ) regs get set-nth ; : set-reg ( val n -- ) regs get set-nth ;
@ -117,11 +114,21 @@ SYMBOL: open-arrays
: run-op ( -- bool ) : run-op ( -- bool )
advance advance
{ {
[ op0 ] [ op1 ] [ op2 ] [ op3 ] { 0 [ op0 ] }
[ op4 ] [ op5 ] [ op6 ] [ drop t ] { 1 [ op1 ] }
[ op8 ] [ op9 ] [ op10 ] [ op11 ] { 2 [ op2 ] }
[ op12 ] [ op13 ] { 3 [ op3 ] }
} call-nth ; { 4 [ op4 ] }
{ 5 [ op5 ] }
{ 6 [ op6 ] }
{ 7 [ drop t ] }
{ 8 [ op8 ] }
{ 9 [ op9 ] }
{ 10 [ op10 ] }
{ 11 [ op11 ] }
{ 12 [ op12 ] }
{ 13 [ op13 ] }
} case ;
: exec-loop ( bool -- ) : exec-loop ( bool -- )
[ run-op exec-loop ] unless ; [ run-op exec-loop ] unless ;

6
extra/io/launcher/launcher-docs.factor
View File

@ -90,6 +90,10 @@ HELP: get-environment
{ $values { "env" "an association" } } { $values { "env" "an association" } }
{ $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ; { $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ;
HELP: current-process-handle
{ $values { "handle" "a process handle" } }
{ $description "Returns the handle of the current process." } ;
HELP: run-process* HELP: run-process*
{ $values { "desc" "a launch descriptor" } { "handle" "a process handle" } } { $values { "desc" "a launch descriptor" } { "handle" "a process handle" } }
{ $contract "Launches a process using the launch descriptor." } { $contract "Launches a process using the launch descriptor." }
@ -186,6 +190,8 @@ ARTICLE: "io.launcher" "Launching OS processes"
{ $subsection try-process } { $subsection try-process }
"Stopping processes:" "Stopping processes:"
{ $subsection kill-process } { $subsection kill-process }
"Finding the current process handle:"
{ $subsection current-process-handle }
"Redirecting standard input and output to a pipe:" "Redirecting standard input and output to a pipe:"
{ $subsection <process-stream> } { $subsection <process-stream> }
{ $subsection with-process-stream } { $subsection with-process-stream }

6
extra/io/launcher/launcher.factor
View File

@ -76,6 +76,8 @@ SYMBOL: +append-environment+
{ [ dup assoc? ] [ >hashtable ] } { [ dup assoc? ] [ >hashtable ] }
} cond ; } cond ;
HOOK: current-process-handle io-backend ( -- handle )
HOOK: run-process* io-backend ( desc -- handle ) HOOK: run-process* io-backend ( desc -- handle )
: wait-for-process ( process -- status ) : wait-for-process ( process -- status )
@ -119,7 +121,9 @@ HOOK: process-stream* io-backend ( desc -- stream process )
TUPLE: process-stream process ; TUPLE: process-stream process ;
: <process-stream> ( desc -- stream ) : <process-stream> ( desc -- stream )
>descriptor process-stream* >descriptor
[ process-stream* ] keep
+timeout+ swap at [ over set-timeout ] when*
{ set-delegate set-process-stream-process } { set-delegate set-process-stream-process }
process-stream construct ; process-stream construct ;

13
extra/io/unix/launcher/launcher.factor
View File

@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.unix.backend io.unix.files
io.nonblocking sequences kernel namespaces math system io.nonblocking sequences kernel namespaces math system
alien.c-types debugger continuations arrays assocs alien.c-types debugger continuations arrays assocs
combinators unix.process parser-combinators memoize combinators unix.process parser-combinators memoize
promises strings threads ; promises strings threads unix ;
IN: io.unix.launcher IN: io.unix.launcher
! Search unix first ! Search unix first
@ -50,15 +50,16 @@ MEMO: 'arguments' ( -- parser )
: redirect ( obj mode fd -- ) : redirect ( obj mode fd -- )
{ {
{ [ pick not ] [ 2nip F_SETFL 0 fcntl io-error ] } { [ pick not ] [ 2nip F_SETFL 0 fcntl io-error ] }
{ [ pick +closed+ eq? ] [ close 2drop ] }
{ [ pick string? ] [ (redirect) ] } { [ pick string? ] [ (redirect) ] }
} cond ; } cond ;
: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
: setup-redirection ( -- ) : setup-redirection ( -- )
+stdin+ get read-flags 0 redirect +stdin+ get ?closed read-flags 0 redirect
+stdout+ get write-flags 1 redirect +stdout+ get ?closed write-flags 1 redirect
+stderr+ get dup +stdout+ eq? +stderr+ get dup +stdout+ eq?
[ drop 1 2 dup2 io-error ] [ write-flags 2 redirect ] if ; [ drop 1 2 dup2 io-error ] [ ?closed write-flags 2 redirect ] if ;
: spawn-process ( -- ) : spawn-process ( -- )
[ [
@ -70,6 +71,8 @@ MEMO: 'arguments' ( -- parser )
io-error io-error
] [ error. :c flush ] recover 1 exit ; ] [ error. :c flush ] recover 1 exit ;
M: unix-io current-process-handle ( -- handle ) getpid ;
M: unix-io run-process* ( desc -- pid ) M: unix-io run-process* ( desc -- pid )
[ [
[ spawn-process ] [ ] with-fork <process> [ spawn-process ] [ ] with-fork <process>

68
extra/io/windows/launcher/launcher.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations destructors io USING: alien alien.c-types arrays continuations destructors io
io.windows io.windows.pipes libc io.nonblocking io.windows io.windows.nt.pipes libc io.nonblocking
io.streams.duplex windows.types math windows.kernel32 windows io.streams.duplex windows.types math windows.kernel32 windows
namespaces io.launcher kernel sequences windows.errors assocs namespaces io.launcher kernel sequences windows.errors assocs
splitting system threads init strings combinators io.backend ; splitting system threads init strings combinators io.backend ;
@ -87,75 +87,29 @@ TUPLE: CreateProcess-args
over set-CreateProcess-args-lpEnvironment over set-CreateProcess-args-lpEnvironment
] when ; ] when ;
: (redirect) ( path access-mode create-mode -- handle )
>r >r
normalize-pathname
r> ! access-mode
share-mode
security-attributes-inherit
r> ! create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file
CreateFile dup invalid-handle? dup close-later ;
: redirect ( obj access-mode create-mode -- handle )
{
{ [ pick not ] [ 3drop f ] }
{ [ pick +closed+ eq? ] [ 3drop t ] }
{ [ pick string? ] [ (redirect) ] }
} cond ;
: ?closed or dup t eq? [ drop f ] when ;
: inherited-stdout ( args -- handle )
CreateProcess-args-stdout-pipe
[ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
: redirect-stdout ( args -- handle )
+stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stdout ?closed ;
: inherited-stderr ( args -- handle )
drop STD_ERROR_HANDLE GetStdHandle ;
: redirect-stderr ( args -- handle )
+stderr+ get
dup +stdout+ eq? [
drop
CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
] [
GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stderr ?closed
] if ;
: inherited-stdin ( args -- handle )
CreateProcess-args-stdin-pipe
[ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
: redirect-stdin ( args -- handle )
+stdin+ get GENERIC_READ OPEN_EXISTING redirect
swap inherited-stdin ?closed ;
: fill-startup-info : fill-startup-info
dup CreateProcess-args-lpStartupInfo dup CreateProcess-args-lpStartupInfo
STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags STARTF_USESTDHANDLES swap set-STARTUPINFO-dwFlags ;
over redirect-stdout over set-STARTUPINFO-hStdOutput HOOK: fill-redirection io-backend ( args -- args )
over redirect-stderr over set-STARTUPINFO-hStdError
over redirect-stdin over set-STARTUPINFO-hStdInput
drop ; M: windows-ce-io fill-redirection ;
: make-CreateProcess-args ( -- args ) : make-CreateProcess-args ( -- args )
default-CreateProcess-args default-CreateProcess-args
wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
fill-dwCreateFlags fill-dwCreateFlags
fill-lpEnvironment ; fill-lpEnvironment
fill-startup-info ;
M: windows-io current-process-handle ( -- handle )
GetCurrentProcessId ;
M: windows-io run-process* ( desc -- handle ) M: windows-io run-process* ( desc -- handle )
[ [
[ [
make-CreateProcess-args fill-startup-info make-CreateProcess-args
fill-redirection
dup call-CreateProcess dup call-CreateProcess
CreateProcess-args-lpProcessInformation <process> CreateProcess-args-lpProcessInformation <process>
] with-descriptor ] with-descriptor

4
extra/io/windows/nt/files/files.factor
View File

@ -2,7 +2,7 @@ USING: continuations destructors io.buffers io.files io.backend
io.timeouts io.nonblocking io.windows io.windows.nt.backend io.timeouts io.nonblocking io.windows io.windows.nt.backend
kernel libc math threads windows windows.kernel32 alien.c-types kernel libc math threads windows windows.kernel32 alien.c-types
alien.arrays sequences combinators combinators.lib sequences.lib alien.arrays sequences combinators combinators.lib sequences.lib
ascii splitting alien strings ; ascii splitting alien strings assocs ;
IN: io.windows.nt.files IN: io.windows.nt.files
M: windows-nt-io cwd M: windows-nt-io cwd
@ -60,7 +60,7 @@ M: windows-nt-io root-directory? ( path -- ? )
M: windows-nt-io normalize-pathname ( string -- string ) M: windows-nt-io normalize-pathname ( string -- string )
dup string? [ "pathname must be a string" throw ] unless dup string? [ "pathname must be a string" throw ] unless
"/" split "\\" join { { CHAR: / CHAR: \\ } } substitute
cwd swap windows-path+ cwd swap windows-path+
[ "/\\." member? ] right-trim [ "/\\." member? ] right-trim
dup peek CHAR: : = [ "\\" append ] when ; dup peek CHAR: : = [ "\\" append ] when ;

66
extra/io/windows/nt/launcher/launcher.factor
View File

@ -3,13 +3,63 @@
USING: alien alien.c-types arrays continuations destructors io USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.nonblocking io.streams.duplex windows.types io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system sequences windows.errors assocs splitting system strings
io.windows.launcher io.windows.pipes ; io.windows.launcher io.windows.nt.pipes io.backend
combinators ;
IN: io.windows.nt.launcher IN: io.windows.nt.launcher
! The below code is based on the example given in ! The below code is based on the example given in
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
: (redirect) ( path access-mode create-mode -- handle )
>r >r
normalize-pathname
r> ! access-mode
share-mode
security-attributes-inherit
r> ! create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file
CreateFile dup invalid-handle? dup close-later ;
: redirect ( obj access-mode create-mode -- handle )
{
{ [ pick not ] [ 3drop f ] }
{ [ pick +closed+ eq? ] [ drop nip null-pipe ] }
{ [ pick string? ] [ (redirect) ] }
} cond ;
: ?closed or dup t eq? [ drop f ] when ;
: inherited-stdout ( args -- handle )
CreateProcess-args-stdout-pipe
[ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
: redirect-stdout ( args -- handle )
+stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stdout ?closed ;
: inherited-stderr ( args -- handle )
drop STD_ERROR_HANDLE GetStdHandle ;
: redirect-stderr ( args -- handle )
+stderr+ get
dup +stdout+ eq? [
drop
CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
] [
GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stderr ?closed
] if ;
: inherited-stdin ( args -- handle )
CreateProcess-args-stdin-pipe
[ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
: redirect-stdin ( args -- handle )
+stdin+ get GENERIC_READ OPEN_EXISTING redirect
swap inherited-stdin ?closed ;
: set-inherit ( handle ? -- ) : set-inherit ( handle ? -- )
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
@ -30,14 +80,22 @@ IN: io.windows.nt.launcher
dup pipe-out f set-inherit dup pipe-out f set-inherit
over set-CreateProcess-args-stdin-pipe ; over set-CreateProcess-args-stdin-pipe ;
M: windows-io process-stream* M: windows-nt-io fill-redirection
dup CreateProcess-args-lpStartupInfo
over redirect-stdout over set-STARTUPINFO-hStdOutput
over redirect-stderr over set-STARTUPINFO-hStdError
over redirect-stdin over set-STARTUPINFO-hStdInput
drop ;
M: windows-nt-io process-stream*
[ [
[ [
make-CreateProcess-args make-CreateProcess-args
fill-stdout-pipe fill-stdout-pipe
fill-stdin-pipe fill-stdin-pipe
fill-startup-info
fill-redirection
dup call-CreateProcess dup call-CreateProcess

0
extra/io/windows/pipes/authors.txt → extra/io/windows/nt/pipes/authors.txt
View File

24
extra/io/windows/pipes/pipes.factor → extra/io/windows/nt/pipes/pipes.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2007 Doug Coleman, Slava Pestov. ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays destructors io io.windows libc USING: alien alien.c-types arrays destructors io io.windows libc
windows.types math windows.kernel32 windows namespaces kernel windows.types math windows.kernel32 windows namespaces kernel
sequences windows.errors assocs math.parser system random ; sequences windows.errors assocs math.parser system random
IN: io.windows.pipes combinators ;
IN: io.windows.nt.pipes
! This code is based on ! This code is based on
! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py ! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
@ -65,3 +66,20 @@ TUPLE: pipe in out ;
: <unique-outgoing-pipe> ( -- pipe ) : <unique-outgoing-pipe> ( -- pipe )
unique-pipe-name <outgoing-pipe> ; unique-pipe-name <outgoing-pipe> ;
! /dev/null simulation
: null-input ( -- pipe )
<unique-outgoing-pipe>
dup pipe-out CloseHandle drop
pipe-in ;
: null-output ( -- pipe )
<unique-incoming-pipe>
dup pipe-in CloseHandle drop
pipe-out ;
: null-pipe ( mode -- pipe )
{
{ [ dup GENERIC_READ = ] [ drop null-input ] }
{ [ dup GENERIC_WRITE = ] [ drop null-output ] }
} cond ;

2
extra/math/analysis/analysis.factor Normal file → Executable file
View File

@ -1,5 +1,5 @@
USING: kernel math math.constants math.functions math.intervals USING: kernel math math.constants math.functions math.intervals
math.vectors namespaces sequences ; math.vectors namespaces sequences combinators.cleave ;
IN: math.analysis IN: math.analysis
<PRIVATE <PRIVATE

10
extra/optimizer/debugger/debugger.factor
View File

@ -4,7 +4,7 @@ USING: classes inference inference.dataflow io kernel
kernel.private math.parser namespaces optimizer prettyprint kernel.private math.parser namespaces optimizer prettyprint
prettyprint.backend sequences words arrays match macros prettyprint.backend sequences words arrays match macros
assocs sequences.private optimizer.specializers generic assocs sequences.private optimizer.specializers generic
combinators sorting math ; combinators sorting math quotations ;
IN: optimizer.debugger IN: optimizer.debugger
! A simple tool for turning dataflow IR into quotations, for ! A simple tool for turning dataflow IR into quotations, for
@ -67,7 +67,7 @@ M: #shuffle node>quot
[ , ] [ >r drop t r> ] if* [ , ] [ >r drop t r> ] if*
dup effect-str "#shuffle: " swap append comment, ; dup effect-str "#shuffle: " swap append comment, ;
: pushed-literals node-out-d [ value-literal ] map ; : pushed-literals node-out-d [ value-literal literalize ] map ;
M: #push node>quot nip pushed-literals % ; M: #push node>quot nip pushed-literals % ;
@ -82,7 +82,11 @@ M: #call node>quot #call>quot ;
M: #call-label node>quot #call>quot ; M: #call-label node>quot #call>quot ;
M: #label node>quot M: #label node>quot
[ "#label: " over node-param word-name append comment, ] 2keep [
dup node-param literalize ,
dup #label-loop? "#loop: " "#label: " ?
over node-param word-name append comment,
] 2keep
node-child swap dataflow>quot , \ call , ; node-child swap dataflow>quot , \ call , ;
M: #if node>quot M: #if node>quot

28
extra/optimizer/report/report.factor Executable file
View File

@ -0,0 +1,28 @@
IN: optimizer.report
USING: assocs words sequences arrays compiler tools.time
io.styles io prettyprint vocabs kernel sorting generator
optimizer ;
: count-optimization-passes ( nodes n -- n )
>r optimize-1
[ r> 1+ count-optimization-passes ] [ drop r> ] if ;
: word-table
[ [ second ] swap compose compare ] curry sort 20 tail*
print
standard-table-style
[
[ [ [ pprint-cell ] each ] with-row ] each
] tabular-output ;
: optimizer-report
all-words [ compiled? ] subset
[
dup [
word-dataflow nip 1 count-optimization-passes
] benchmark nip 2array
] { } map>assoc
[ first ] "Worst number of optimizer passes:" results
[ second ] "Worst compile times:" results ;
MAIN: optimizer-report

4
extra/smtp/server/server.factor
View File

@ -29,6 +29,7 @@
USING: combinators kernel prettyprint io io.timeouts io.server USING: combinators kernel prettyprint io io.timeouts io.server
sequences namespaces io.sockets continuations ; sequences namespaces io.sockets continuations ;
IN: smtp.server
SYMBOL: data-mode SYMBOL: data-mode
@ -55,7 +56,7 @@ SYMBOL: data-mode
data-mode off data-mode off
"220 OK\r\n" write flush t "220 OK\r\n" write flush t
] } ] }
{ [ data-mode get ] [ t ] } { [ data-mode get ] [ global [ print ] bind t ] }
{ [ t ] [ { [ t ] [
"500 ERROR\r\n" write flush t "500 ERROR\r\n" write flush t
] } ] }
@ -68,5 +69,6 @@ SYMBOL: data-mode
60000 stdio get set-timeout 60000 stdio get set-timeout
"220 hello\r\n" write flush "220 hello\r\n" write flush
process process
global [ flush ] bind
] with-stream ] with-stream
] with-disposal ; ] with-disposal ;

14
extra/smtp/smtp.factor
View File

@ -139,7 +139,7 @@ LOG: smtp-response DEBUG
: prepare-message ( body headers -- body' ) : prepare-message ( body headers -- body' )
[ [
prepare-headers prepare-headers
" " , "" ,
dup string? [ string-lines ] when % dup string? [ string-lines ] when %
] { } make ; ] { } make ;
@ -169,3 +169,15 @@ LOG: smtp-response DEBUG
! : cram-md5-auth ( key login -- ) ! : cram-md5-auth ( key login -- )
! "AUTH CRAM-MD5\r\n" get-ok ! "AUTH CRAM-MD5\r\n" get-ok
! (cram-md5-auth) "\r\n" append get-ok ; ! (cram-md5-auth) "\r\n" append get-ok ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USE: new-slots
TUPLE: email from to subject body ;
: <email> ( -- email ) email construct-empty ;
: send ( email -- )
{ email-body email-subject email-to email-from } get-slots
send-simple-message ;

2
extra/tools/browser/browser.factor
View File

@ -132,7 +132,7 @@ MEMO: all-vocabs-seq ( -- seq )
require-all ; require-all ;
: load-everything ( -- ) : load-everything ( -- )
try-everything drop ; try-everything load-failures. ;
: unrooted-child-vocabs ( prefix -- seq ) : unrooted-child-vocabs ( prefix -- seq )
dup empty? [ CHAR: . add ] unless dup empty? [ CHAR: . add ] unless

2
extra/tools/disassembler/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Slava Pestov
Jorge Acereda Macia

13
extra/tools/disassembler/disassembler-docs.factor Executable file
View File

@ -0,0 +1,13 @@
IN: tools.disassembler
USING: help.markup help.syntax sequences.private ;
HELP: disassemble
{ $values { "obj" "a word or a pair of addresses" } }
{ $description "Disassembles either a compiled word definition or an arbitrary memory range (in the case " { $snippet "obj" } " is a pair of integers) by attaching " { $snippet "gdb" } " to the Factor VM and capturing the output." }
{ $notes "In some cases the Factor compiler emits data inline with code, which can confuse " { $snippet "gdb" } ". This occurs in words which call " { $link dispatch } ", where the jump table addresses are compiled inline. Also on the ARM architecture, various pointers are often compiled inline, and the preceeding instruction jumps over the inline pinter." } ;
ARTICLE: "tools.disassembler" "Disassembling words"
"The " { $vocab-link "tools.disassembler" } " vocabulary integrates Factor with the GNU debugger (" { $snippet "gdb" } ") for viewing the assembly code generated by the compiler. It can be used on both Unix and Windows as long as a working copy of " { $snippet "gdb" } " is installed and available in the " { $snippet "PATH" } "."
{ $subsection disassemble } ;
ABOUT: "tools.disassembler"

38
extra/tools/disassembler/disassembler.factor Executable file
View File

@ -0,0 +1,38 @@
! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io words alien kernel math.parser alien.syntax
io.launcher system assocs arrays sequences namespaces qualified
system math windows.kernel32 generator.fixup ;
IN: tools.disassembler
: in-file "gdb-in.txt" resource-path ;
: out-file "gdb-out.txt" resource-path ;
GENERIC: make-disassemble-cmd ( obj -- )
M: word make-disassemble-cmd
word-xt code-format - 2array make-disassemble-cmd ;
M: pair make-disassemble-cmd
in-file [
"attach " write
current-process-handle number>string print
"disassemble " write
[ number>string write bl ] each
] with-file-out ;
: run-gdb ( -- lines )
[
+closed+ +stdin+ set
out-file +stdout+ set
[ "gdb" , "-x" , in-file , "-batch" , ] { } make +arguments+ set
] { } make-assoc run-process drop
out-file file-lines ;
: tabs>spaces ( str -- str' )
{ { CHAR: \t CHAR: \s } } substitute ;
: disassemble ( word -- )
make-disassemble-cmd run-gdb
[ tabs>spaces ] map [ print ] each ;

1
extra/tools/disassembler/summary.txt Normal file
View File

@ -0,0 +1 @@
Disassemble words using gdb

2
extra/tools/memory/memory-docs.factor Normal file → Executable file
View File

@ -17,7 +17,7 @@ ARTICLE: "tools.memory" "Object memory tools"
"The garbage collector can be invoked manually:" "The garbage collector can be invoked manually:"
{ $subsection data-gc } { $subsection data-gc }
{ $subsection code-gc } { $subsection code-gc }
{ $see-also "image" } ; { $see-also "images" } ;
ABOUT: "tools.memory" ABOUT: "tools.memory"

6
extra/tools/test/test.factor
View File

@ -53,12 +53,12 @@ SYMBOL: this-test
: (run-test) ( vocab -- ) : (run-test) ( vocab -- )
dup vocab-source-loaded? [ dup vocab-source-loaded? [
[ "temporary" forget-vocab ] with-compilation-unit vocab-tests
vocab-tests dup [ run-file ] each
[ [
dup [ forget-source ] each
"temporary" forget-vocab "temporary" forget-vocab
dup [ forget-source ] each
] with-compilation-unit ] with-compilation-unit
dup [ run-file ] each
] when drop ; ] when drop ;
: run-test ( vocab -- failures ) : run-test ( vocab -- failures )

2
extra/ui/commands/commands.factor
View File

@ -51,7 +51,7 @@ GENERIC: command-word ( command -- word )
update-gestures ; update-gestures ;
: (command-name) ( string -- newstring ) : (command-name) ( string -- newstring )
"-" split " " join >title ; { { CHAR: - CHAR: \s } } substitute >title ;
M: word command-name ( word -- str ) M: word command-name ( word -- str )
word-name word-name

12
extra/ui/x11/x11.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2005, 2007 Eduardo Cavazos and Slava Pestov ! Copyright (C) 2005, 2007 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays ui ui.gadgets ui.gestures ui.backend USING: alien alien.c-types arrays ui ui.gadgets ui.gestures
ui.clipboards ui.gadgets.worlds assocs kernel math namespaces ui.backend ui.clipboards ui.gadgets.worlds assocs kernel math
opengl sequences strings x11.xlib x11.events x11.xim x11.glx namespaces opengl sequences strings x11.xlib x11.events x11.xim
x11.clipboard x11.constants x11.windows io.utf8 combinators x11.glx x11.clipboard x11.constants x11.windows
debugger system command-line ui.render math.vectors tuples io.encodings.utf8 combinators debugger system command-line
opengl.gl threads ; ui.render math.vectors tuples opengl.gl threads ;
IN: ui.x11 IN: ui.x11
TUPLE: x11-ui-backend ; TUPLE: x11-ui-backend ;

11
extra/unicode/data/data.factor Normal file → Executable file
View File

@ -67,7 +67,7 @@ IN: unicode.data
: process-combining ( data -- hash ) : process-combining ( data -- hash )
3 swap (process-data) 3 swap (process-data)
[ string>number ] assoc-map [ string>number ] assoc-map
[ nip 0 = not ] assoc-subset [ nip zero? not ] assoc-subset
>hashtable ; >hashtable ;
: categories ( -- names ) : categories ( -- names )
@ -93,13 +93,10 @@ IN: unicode.data
: ascii-lower ( string -- lower ) : ascii-lower ( string -- lower )
[ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ] map ; [ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ] map ;
: replace ( seq old new -- newseq )
swap rot [ 2dup = [ drop over ] when ] map 2nip ;
: process-names ( data -- names-hash ) : process-names ( data -- names-hash )
1 swap (process-data) 1 swap (process-data) [
[ ascii-lower CHAR: \s CHAR: - replace swap ] assoc-map ascii-lower { { CHAR: \s CHAR: - } } substitute swap
>hashtable ; ] assoc-map >hashtable ;
: multihex ( hexstring -- string ) : multihex ( hexstring -- string )
" " split [ hex> ] map [ ] subset ; " " split [ hex> ] map [ ] subset ;

4
extra/unicode/syntax/syntax-tests.factor
View File

@ -1,4 +0,0 @@
USING: unicode.syntax tools.test ;
[ CHAR: ! ] [ UNICHAR: exclamation-mark ] unit-test
! Write a test for CATEGORY and CATEGORY-NOT

4
extra/unicode/syntax/syntax.factor Normal file → Executable file
View File

@ -46,7 +46,3 @@ IN: unicode.syntax
: CATEGORY-NOT: : CATEGORY-NOT:
CREATE ";" parse-tokens CREATE ";" parse-tokens
categories swap seq-minus define-category ; parsing categories swap seq-minus define-category ; parsing
: UNICHAR:
! This should be part of CHAR:. Also, name-map at ==> name>char
scan name>char [ parsed ] [ "Invalid character" throw ] if* ; parsing

8
extra/unicode/unicode.factor
View File

@ -1,5 +1,9 @@
USING: unicode.syntax unicode.data unicode.breaks unicode.normalize USING: unicode.syntax unicode.data unicode.breaks
unicode.case unicode.categories ; unicode.normalize unicode.case unicode.categories
parser kernel namespaces ;
IN: unicode IN: unicode
! For now: convenience to load all Unicode vocabs ! For now: convenience to load all Unicode vocabs
[ name>char [ "Invalid character" throw ] unless* ]
name>char-hook set-global

1
extra/unix/unix.factor
View File

@ -125,6 +125,7 @@ FUNCTION: int futimes ( int id, timeval[2] times ) ;
FUNCTION: char* gai_strerror ( int ecode ) ; FUNCTION: char* gai_strerror ( int ecode ) ;
FUNCTION: int getaddrinfo ( char* hostname, char* servname, addrinfo* hints, addrinfo** res ) ; FUNCTION: int getaddrinfo ( char* hostname, char* servname, addrinfo* hints, addrinfo** res ) ;
FUNCTION: char* getcwd ( char* buf, size_t size ) ; FUNCTION: char* getcwd ( char* buf, size_t size ) ;
FUNCTION: pid_t getpid ;
FUNCTION: int getdtablesize ; FUNCTION: int getdtablesize ;
FUNCTION: gid_t getegid ; FUNCTION: gid_t getegid ;
FUNCTION: uid_t geteuid ; FUNCTION: uid_t geteuid ;

2
extra/windows/kernel32/kernel32.factor
View File

@ -895,7 +895,7 @@ FUNCTION: DWORD GetConsoleTitleW ( LPWSTR lpConsoleTitle, DWORD nSize ) ;
FUNCTION: BOOL GetCurrentDirectoryW ( DWORD len, LPTSTR buf ) ; FUNCTION: BOOL GetCurrentDirectoryW ( DWORD len, LPTSTR buf ) ;
: GetCurrentDirectory GetCurrentDirectoryW ; inline : GetCurrentDirectory GetCurrentDirectoryW ; inline
FUNCTION: HANDLE GetCurrentProcess ( ) ; FUNCTION: HANDLE GetCurrentProcess ( ) ;
! FUNCTION: GetCurrentProcessId FUNCTION: DWORD GetCurrentProcessId ( ) ;
FUNCTION: HANDLE GetCurrentThread ( ) ; FUNCTION: HANDLE GetCurrentThread ( ) ;
! FUNCTION: GetCurrentThreadId ! FUNCTION: GetCurrentThreadId
! FUNCTION: GetDateFormatA ! FUNCTION: GetDateFormatA

2
extra/x11/clipboard/clipboard.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Slava Pestov ! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax arrays kernel math USING: alien alien.c-types alien.syntax arrays kernel math
namespaces sequences io.utf8 x11.xlib x11.constants ; namespaces sequences io.encodings.utf8 x11.xlib x11.constants ;
IN: x11.clipboard IN: x11.clipboard
! This code was based on by McCLIM's Backends/CLX/port.lisp ! This code was based on by McCLIM's Backends/CLX/port.lisp

8
vm/types.c
View File

@ -70,11 +70,13 @@ DEFINE_PRIMITIVE(word)
dpush(tag_object(allot_word(vocab,name))); dpush(tag_object(allot_word(vocab,name)));
} }
/* word-xt ( word -- xt ) */ /* word-xt ( word -- start end ) */
DEFINE_PRIMITIVE(word_xt) DEFINE_PRIMITIVE(word_xt)
{ {
F_WORD *word = untag_word(dpeek()); F_WORD *word = untag_word(dpop());
drepl(allot_cell((CELL)word->xt)); F_COMPILED *code = word->code;
dpush(allot_cell((CELL)code + sizeof(F_COMPILED)));
dpush(allot_cell((CELL)code + sizeof(F_COMPILED) + code->code_length));
} }
DEFINE_PRIMITIVE(wrapper) DEFINE_PRIMITIVE(wrapper)