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
core
alien
assocs
bootstrap
combinators
compiler/tests
debugger
generator
generic/math
hashtables
inference
io/encodings
optimizer
parser
sequences
syntax
threads
vocabs/loader
words
extra
benchmark/sockets
bootstrap
builder
db
help/handbook
http
icfp/2006
io
math/analysis
optimizer
smtp
tools
ui
unicode
unix
windows/kernel32
x11/clipboard

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." ;
: callback-bottom ( node -- )
alien-callback-xt [ word-xt <alien> ] curry
alien-callback-xt [ word-xt drop <alien> ] curry
recursive-state get infer-quot ;
\ alien-callback [

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

@ -9,18 +9,20 @@ C-STRUCT: bar
[ 36 ] [ "bar" heap-size ] unit-test
[ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
C-STRUCT: align-test
{ "int" "x" }
{ "double" "y" } ;
! This was actually only correct on Windows/x86:
[ 16 ] [ "align-test" heap-size ] unit-test
cell 4 = [
C-STRUCT: one
{ "long" "a" } { "double" "b" } { "int" "c" } ;
[ 24 ] [ "one" heap-size ] unit-test
] when
! C-STRUCT: align-test
! { "int" "x" }
! { "double" "y" } ;
!
! [ 16 ] [ "align-test" heap-size ] unit-test
!
! cell 4 = [
! C-STRUCT: one
! { "long" "a" } { "double" "b" } { "int" "c" } ;
!
! [ 24 ] [ "one" heap-size ] unit-test
! ] when
: 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 remove-all }
{ $subsection substitute }
{ $subsection substitute-here }
{ $see-also key? } ;
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." }
{ $side-effects "assoc" } ;
HELP: substitute
{ $values { "assoc" assoc } { "seq" "a mutable sequence" } }
{ $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." }
HELP: substitute-here
{ $values { "seq" "a mutable sequence" } { "assoc" assoc } }
{ $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" } "." }
{ $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
{ $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." }

10
core/assocs/assocs.factor
View File

@ -124,8 +124,14 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: remove-all ( assoc seq -- subseq )
swap [ key? not ] curry subset ;
: substitute ( assoc seq -- )
swap [ dupd at* [ nip ] [ drop ] if ] curry change-each ;
: (substitute)
[ 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 )
2over at [

2
core/bootstrap/stage2.factor
View File

@ -59,7 +59,7 @@ SYMBOL: bootstrap-time
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
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:"
{ $subsection cond>quot }
{ $subsection case>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 } ;
{ $subsection alist>quot } ;
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 } ":"
@ -104,19 +100,17 @@ HELP: case>quot
{ $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" } "."
$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
{ $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." }
{ $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." } ;
{ $notes "This word is used in the implemention of " { $link hash-case-quot } " and " { $link standard-combination } "." } ;
HELP: dispatch ( n array -- )
{ $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
[ "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.
IN: combinators
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 ;
@ -31,16 +32,24 @@ TUPLE: no-case ;
: recursive-hashcode ( n obj quot -- code )
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*
[ 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 )
[ rot \ if 3array append [ ] like ] assoc-each ;
: cond>quot ( assoc -- 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
alist>quot ;
@ -63,20 +72,50 @@ M: sequence hashcode*
: hash-case-table ( default assoc -- array )
V{ } [ 1array ] distribute-buckets
[ case>quot ] with map ;
[ linear-case-quot ] with map ;
: hash-dispatch-quot ( table -- quot )
[ length 1- [ fixnum-bitand ] curry ] keep
[ 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? [
drop
] [
dup length 4 <= [
case>quot
linear-case-quot
] [
hash-case-table hash-dispatch-quot
[ dup hashcode >fixnum ] swap append
dup keys contiguous-range? [
dispatch-case-quot
] [
2drop hash-case-quot
] 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 ] [ 3 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
sequences.private tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts
words definitions compiler.units ;
words definitions compiler.units io combinators ;
IN: temporary
! Oops!
@ -191,3 +191,18 @@ TUPLE: my-tuple ;
2 1
[ 2dup fixnum< [ >r die r> ] when ] compile-call
] 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-loop?
SYMBOL: compiling-loops
! Label of current word, after prologue, makes recursion faster
SYMBOL: current-label-start
@ -34,7 +34,7 @@ SYMBOL: current-label-start
: compiled-stack-traces? ( -- ? ) 36 getenv ;
: begin-compiling ( word label -- )
compiling-loop? off
H{ } clone compiling-loops set
compiling-label set
compiling-word set
compiled-stack-traces?
@ -94,8 +94,8 @@ M: node generate-node drop iterate-next ;
: generate-call ( label -- next )
dup maybe-compile
end-basic-block
dup compiling-label get eq? compiling-loop? get and [
drop current-label-start get %jump-label f
dup compiling-loops get at [
%jump-label f
] [
tail-call? [
%jump f
@ -104,7 +104,7 @@ M: node generate-node drop iterate-next ;
%call
iterate-next
] if
] if ;
] ?if ;
! #label
M: #label generate-node
@ -113,17 +113,13 @@ M: #label generate-node
r> ;
! #loop
: compiling-loop ( word -- )
<label> dup resolve-label swap compiling-loops get set-at ;
M: #loop generate-node
end-basic-block
[
dup node-param compiling-label set
current-label-start define-label
current-label-start resolve-label
compiling-loop? on
node-child generate-nodes
end-basic-block
] with-scope
init-templates
dup node-param compiling-loop
node-child generate-nodes
iterate-next ;
! #if
@ -158,17 +154,10 @@ M: #if generate-node
] with-generator
] 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 -- )
node-children [
dup tail-dispatch? [
node-param
] [
compiling-word get dispatch-branch
] if %dispatch-label
compiling-word get dispatch-branch
%dispatch-label
] each ;
: generate-dispatch ( node -- )
@ -276,5 +265,6 @@ M: #r> generate-node
! #return
M: #return generate-node
node-param compiling-label get eq? compiling-loop? get and
[ end-basic-block %return ] unless f ;
end-basic-block
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 -- )
[ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-subset >hashtable
[ swap substitute ] curry each-phantom ;
[ substitute-here ] curry each-phantom ;
: set-operand ( value var -- )
>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
] if ;
: math-vtable* ( picker max quot -- quot )
: math-vtable ( picker quot -- quot )
[
rot , \ tag ,
[ >r [ bootstrap-type>class ] map r> map % ] { } make ,
>r
, \ tag ,
num-tags get [ bootstrap-type>class ]
r> compose map ,
\ dispatch ,
] [ ] make ; inline
: math-vtable ( picker quot -- quot )
num-tags get swap math-vtable* ; inline
TUPLE: math-combination ;
M: math-combination make-default-method

18
core/hashtables/hashtables.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private slots.private math assocs
math.private sequences sequences.private vectors
combinators ;
math.private sequences sequences.private vectors ;
IN: hashtables
<PRIVATE
@ -161,17 +160,10 @@ M: hashtable clone
(clone) dup hash-array clone over set-hash-array ;
M: hashtable equal?
{
{ [ over hashtable? not ] [ 2drop f ] }
{ [ 2dup [ assoc-size ] 2apply number= not ] [ 2drop f ] }
{ [ t ] [ assoc= ] }
} cond ;
M: hashtable hashcode*
[
dup assoc-size 1 number=
[ assoc-hashcode ] [ nip assoc-size ] if
] recursive-hashcode ;
over hashtable? [
2dup [ assoc-size ] 2apply number=
[ assoc= ] [ 2drop f ] if
] [ 2drop f ] if ;
! Default method
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
{ $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 ;
: 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> make-flushable
\ word-xt { word } { integer } <effect> set-primitive-effect
\ word-xt { word } { integer integer } <effect> set-primitive-effect
\ word-xt make-flushable
\ 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*
] [
[ no-case ] swap
] if hash-case>quot
] if case>quot
] if
] 1 define-transform

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

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
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 ;
IN: io.encodings
@ -19,7 +19,7 @@ SYMBOL: begin
over push 0 begin ;
: push-replacement ( buf -- buf ch state )
UNICHAR: replacement-character decoded ;
CHAR: replacement-character decoded ;
: finish-decoding ( buf ch state -- str )
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
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 ;
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."
{ $subsection encode-utf8 }
{ $subsection decode-utf8 } ;
ABOUT: "io.utf8"
ABOUT: "io.encodings.utf8"
HELP: decode-utf8
{ $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
sequences strings arrays unicode.syntax ;
USING: io.encodings.utf8 tools.test sbufs kernel io
sequences strings arrays unicode ;
: decode-utf8-w/stream ( array -- newarray )
>sbuf dup reverse-here utf8 <decoding> contents ;
@ -7,7 +7,7 @@ sequences strings arrays unicode.syntax ;
: encode-utf8-w/stream ( array -- newarray )
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
@ -15,7 +15,7 @@ sequences strings arrays unicode.syntax ;
[ { 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

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

@ -3,8 +3,7 @@
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.pattern-match generic.standard optimizer.specializers ;
combinators classes optimizer.def-use ;
IN: optimizer.backend
SYMBOL: class-substitutions
@ -38,10 +37,10 @@ GENERIC: optimize-node* ( node -- node/t changed? )
over assoc-empty? [
2drop
] [
2dup node-in-d substitute
2dup node-in-r substitute
2dup node-out-d substitute
node-out-r substitute
2dup node-in-d swap substitute-here
2dup node-in-r swap substitute-here
2dup node-out-d swap substitute-here
node-out-r swap substitute-here
] if ;
: perform-substitutions ( node -- )
@ -76,7 +75,6 @@ DEFER: optimize-nodes
optimizer-changed get
] with-scope optimizer-changed set ;
! Generic nodes
M: node optimize-node* drop t f ;
! Post-inlining cleanup
@ -112,362 +110,10 @@ M: #return optimize-node* cleanup-inlining ;
! #values
M: #values optimize-node* cleanup-inlining ;
! Some utilities for splicing in dataflow IR subtrees
M: f set-node-successor 2drop ;
: splice-node ( old new -- )
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 )
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
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 -- ? )
[
@ -60,3 +61,121 @@ sequences inference.dataflow math inference ;
[ loop-test-3 ] dataflow dup detect-loops
\ loop-test-3 label-is-not-loop?
] 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.
USING: kernel inference.dataflow combinators sequences
namespaces math ;
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 ;
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 -- )
f swap set-#label-loop? ;
GENERIC: collect-label-info* ( node -- )
: tail-call? ( -- ? )
node-stack get
dup [ #label? ] find-last drop [ 1+ ] [ 0 ] if* tail
[ node-successor #tail? ] all? ;
M: #label collect-label-info*
[ V{ } clone node-stack get length 3array ] keep
node-param label-info get set-at ;
: detect-loop ( seen-other? label node -- seen-other? continue? )
#! 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 ;
USE: prettyprint
M: #call-label detect-loops*
f swap node-param node-stack get <reversed>
[ detect-loop ] with all? 2drop ;
M: #call-label collect-label-info*
node-param label-info get at
node-stack get over third tail
[ [ #label? ] subset [ node-param ] map ] keep
[ node-successor #tail? ] all? 2array
swap second push ;
: detect-loops ( node -- )
[ detect-loops* ] each-node ;
M: node collect-label-info*
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
math.floats.private tuples tuples.private classes
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
! 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
combinators splitting layouts math.parser classes generic.math
optimizer.pattern-match optimizer.backend optimizer.def-use
generic.standard system ;
optimizer.inlining generic.standard system ;
{ + bignum+ float+ fixnum+fast } {
{ { 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
strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private
continuations growable ;
continuations growable optimizer.inlining namespaces ;
IN: temporary
[ 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 ] [ \ growable \ 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.
USING: kernel namespaces optimizer.backend optimizer.def-use
optimizer.known-words optimizer.math optimizer.control
inference.class ;
optimizer.inlining inference.class ;
IN: optimizer
: 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." }
{ $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
{ $values { "str" "a new " { $link string } } }
{ $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 ;
HELP: still-parsing?

43
core/parser/parser.factor
View File

@ -119,22 +119,43 @@ M: bad-escape summary drop "Bad escape code" ;
{ CHAR: \" CHAR: \" }
} at [ bad-escape ] unless* ;
: next-escape ( m str -- n ch )
2dup nth CHAR: u =
[ >r 1+ dup 6 + tuck r> subseq hex> ]
[ over 1+ -rot nth escape ] if ;
SYMBOL: name>char-hook
: next-char ( m str -- n ch )
2dup nth CHAR: \\ =
[ >r 1+ r> next-escape ] [ over 1+ -rot nth ] if ;
name>char-hook global [
[ "Unicode support not available" throw ] or
] change-at
: (parse-string) ( m str -- n )
2dup nth CHAR: " =
[ drop 1+ ] [ [ next-char , ] keep (parse-string) ] if ;
: unicode-escape ( str -- ch str' )
"{" ?head-slice [
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 )
lexer get [
[ (parse-string) ] "" make swap
[ swap tail-slice (parse-string) ] "" make swap
] change-column ;
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 -- )
over 0 < [ bounds-error ] when
>r swap length + r> lengthen ;
>r swap length + r> lengthen ; inline
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 "\\e" } "escape (ASCII 27)" }
{ { $snippet "\\\"" } { $snippet "\"" } }
}
"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:"
{ $code
"CHAR: \\u000078"
"78"
}
"While not useful for single characters, this syntax is also permitted inside strings." ;
{ { $snippet "\\u" { $emphasis "xxxxxx" } } { "The Unicode code point with hexadecimal number " { $snippet { $emphasis "xxxxxx" } } } }
{ { $snippet "\\u{" { $emphasis "name" } "}" } { "The Unicode code point named " { $snippet { $emphasis "name" } } } }
} ;
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."
@ -412,8 +408,17 @@ HELP: IN:
HELP: CHAR:
{ $syntax "CHAR: token" }
{ $values { "token" "a literal character or escape code" } }
{ $description "Adds the Unicode code point of the character represented by the token to the parse tree." } ;
{ $values { "token" "a literal character, escape code, or Unicode character name" } }
{ $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: "
{ $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
quotations io assocs splitting tuples generic.standard
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
! These words are defined as a top-level form, instead of with
@ -56,7 +57,14 @@ IN: bootstrap.syntax
"f" [ f parsed ] define-syntax
"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
"SBUF\"" [

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

@ -9,6 +9,7 @@ $nl
{ $subsection in-thread }
{ $subsection yield }
{ $subsection sleep }
"Threads stop either when the quotation given to " { $link in-thread } " returns, or when the following word is called:"
{ $subsection stop }
"Continuations can be added to the run queue directly:"
{ $subsection schedule-thread }
@ -21,7 +22,8 @@ ABOUT: "threads"
HELP: run-queue
{ $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
{ $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.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces splitting sequences io.files kernel assocs
words vocabs definitions parser continuations inspector debugger
io io.styles io.streams.lines hashtables sorting prettyprint
source-files arrays combinators strings system math.parser
compiler.errors ;
USING: namespaces sequences io.files kernel assocs words vocabs
definitions parser continuations inspector debugger io io.styles
io.streams.lines hashtables sorting prettyprint source-files
arrays combinators strings system math.parser compiler.errors
splitting ;
IN: vocabs.loader
SYMBOL: vocab-roots
@ -16,7 +16,7 @@ V{
} clone vocab-roots set-global
: vocab-dir ( vocab -- dir )
vocab-name "." split "/" join ;
vocab-name { { CHAR: . CHAR: / } } substitute ;
: vocab-dir+ ( vocab str/f -- path )
>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." }
{ $side-effects "word" } ;
HELP: word-xt
{ $values { "word" word } { "xt" "an execution token integer" } }
HELP: word-xt ( word -- start end )
{ $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." } ;
HELP: define-symbol

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

@ -22,7 +22,7 @@ IN: benchmark.sockets
CHAR: x write1
] with-stream ;
: socket-benchmark ( n -- )
: clients ( n -- )
dup pprint " clients: " write
[
[ simple-server ] in-thread
@ -33,11 +33,12 @@ IN: benchmark.sockets
] time ;
: socket-benchmarks
10 socket-benchmark
20 socket-benchmark
40 socket-benchmark
80 socket-benchmark
160 socket-benchmark
320 socket-benchmark ;
10 clients
20 clients
40 clients
80 clients
160 clients
320 clients
640 clients ;
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-source-loaded? ] subset
[ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each
] with-variable
"help.handbook" require ;
] with-variable ;
load-help

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

@ -4,10 +4,11 @@ USING: vocabs.loader sequences ;
"bootstrap.image"
"tools.annotations"
"tools.crossref"
! "tools.deploy"
"tools.deploy"
"tools.memory"
"tools.profiler"
"tools.test"
"tools.time"
"tools.disassembler"
"editors"
} [ 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
prettyprint tools.time calendar bake vars http.client
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
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 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
: host-name* ( -- name ) host-name "." split first ;
: 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 ;
: prepare-build-machine ( -- )
builds make-directory
builds cd
{ "git" "clone" "git://factorcode.org/git/factor.git" } 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" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: datestamp ( -- string )
now `{ ,[ dup timestamp-year ]
,[ dup timestamp-month ]
,[ dup timestamp-day ]
,[ dup timestamp-hour ]
,[ timestamp-minute ] }
[ pad-00 ] map "-" join ;
VAR: stamp
: enter-build-dir ( -- )
datestamp >stamp
"/builds" cd
builds cd
stamp> make-directory
stamp> cd ;
@ -82,57 +52,59 @@ VAR: stamp
: make-clean ( -- desc ) { "make" "clean" } ;
: make-vm ( -- )
`{
{ +arguments+ { "make" ,[ target ] } }
{ +stdout+ "../compile-log" }
{ +stderr+ +stdout+ }
}
>hashtable ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ;
: make-vm ( -- desc )
<process*>
{ "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 )
`{
{ +arguments+ {
,[ factor-binary ]
,[ "-i=" my-boot-image-name append ]
"-no-user-init"
} }
{ +stdout+ "../boot-log" }
{ +stderr+ +stdout+ }
{ +timeout+ ,[ 20 minutes>ms ] }
} ;
<process*>
bootstrap-cmd >>arguments
+closed+ >>stdin
"../boot-log" >>stdout
+stdout+ >>stderr
20 minutes>ms >>timeout
>desc ;
: builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ;
: builder-test ( -- desc ) { factor-binary "-run=builder.test" } to-strings ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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) ( -- )
builds-check
build-status off
enter-build-dir
"report" [
"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
@ -144,33 +116,17 @@ SYMBOL: build-status
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 error" print throw ]
recover
"Boot time: " write "../boot-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 test-all: " print "../test-all-vocabs" cat
@ -178,14 +134,43 @@ SYMBOL: build-status
"Benchmarks: " print
"../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) ] [ 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? ( -- ? )
git-id
git-pull run-process drop
@ -193,8 +178,9 @@ SYMBOL: build-status
= not ;
: build-loop ( -- )
builds-check
[
"/builds/factor" cd
builds "/factor" append cd
updates-available?
[ build ]
when

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

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

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

@ -6,7 +6,7 @@ USING: kernel namespaces sequences assocs builder continuations
prettyprint
tools.browser
tools.test
bootstrap.stage2 benchmark ;
bootstrap.stage2 benchmark builder.util ;
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.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math
namespaces sequences sequences.lib tuples words ;
namespaces sequences sequences.lib tuples words strings ;
IN: db
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: bind-statement* ( obj statement -- )
GENERIC: reset-statement ( statement -- )
GENERIC: execute-statement* ( statement -- result-set )
HOOK: last-id db ( res -- id )
: execute-statement ( statement -- )
execute-statement* dispose ;
GENERIC: insert-statement ( statement -- id )
: execute-statement-last-id ( statement -- id )
execute-statement* [ last-id ] with-disposal ;
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 -- )
GENERIC: more-rows? ( result-set -- ? )
: execute-statement ( statement -- ) query-results dispose ;
: bind-statement ( obj statement -- )
dup statement-bound? [ dup reset-statement ] when
@ -50,17 +54,9 @@ HOOK: last-id db ( res -- id )
[ set-statement-params ] keep
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 -- )
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 )
>r >r { statement-sql statement-params } get-slots r>
@ -74,10 +70,10 @@ GENERIC: advance-row ( result-set -- ? )
dup #columns [ row-column ] with map ;
: query-each ( statement quot -- )
over advance-row [
2drop
over more-rows? [
[ call ] 2keep over advance-row query-each
] [
[ call ] 2keep query-each
2drop
] if ; inline
: query-map ( statement quot -- seq )
@ -98,11 +94,6 @@ GENERIC: advance-row ( result-set -- ? )
: do-bound-command ( obj query -- )
[ 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
HOOK: begin-transaction db ( -- )
@ -116,3 +107,13 @@ HOOK: rollback-transaction db ( -- )
begin-transaction
[ ] [ rollback-transaction ] cleanup commit-transaction
] 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.
! See http://factorcode.org/license.txt for BSD license.
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
: postgresql-result-error-message ( res -- str/f )
@ -37,13 +38,9 @@ IN: db.postgresql.lib
>r db get db-handle r>
[ statement-sql ] 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
dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw
] 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.
USING: kernel db.postgresql alien continuations io prettyprint
sequences namespaces tools.test db ;
sequences namespaces tools.test db db.types ;
IN: temporary
IN: scratchpad
@ -40,13 +40,13 @@ IN: temporary
test-db [
"select * from person where name = $1 and country = $2"
<simple-statement> [
{ "Jane" "New Zealand" }
{ { "Jane" TEXT } { "New Zealand" TEXT } }
over do-bound-query
{ { "Jane" "New Zealand" } } =
[ "test fails" throw ] unless
{ "John" "America" }
{ { "John" TEXT } { "America" TEXT } }
swap do-bound-query
] with-disposal
] with-db

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

@ -3,7 +3,7 @@
USING: arrays assocs alien alien.syntax continuations io
kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types ;
db.tuples db.types tools.annotations math.ranges ;
IN: db.postgresql
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 )
>r dup result-set-handle swap result-set-n r> PQgetvalue ;
M: postgresql-statement execute-statement* ( statement -- obj )
query-results ;
M: postgresql-result-set row-column ( result-set n -- obj )
>r dup result-set-handle swap result-set-n r> PQgetvalue ;
: increment-n ( result-set -- n )
dup result-set-n 1+ dup rot set-result-set-n ;
M: postgresql-statement insert-statement ( statement -- id )
query-results [ break 0 row-column ] with-disposal ;
M: postgresql-statement query-results ( query -- result-set )
dup statement-params [
@ -68,8 +68,11 @@ M: postgresql-statement query-results ( query -- result-set )
postgresql-result-set <result-set>
dup init-result-set ;
M: postgresql-result-set advance-row ( result-set -- ? )
dup increment-n swap result-set-max >= ;
M: postgresql-result-set advance-row ( result-set -- )
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 -- )
dup statement-handle PQclear
@ -105,36 +108,105 @@ M: postgresql-db commit-transaction ( -- )
M: postgresql-db rollback-transaction ( -- )
"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 " % %
" (" % [ ", " % ] [
dup second % " " %
dup third >sql-type % " " %
sql-modifiers " " join %
] interleave ")" %
] "" make ;
>r remove-id r>
"create function add_" % dup %
"(" %
over [ "," % ]
[ third dup array? [ first ] when >sql-type % ] interleave
")" %
" returns bigint as '" %
M: postgresql-db drop-sql ( table -- sql )
[
"drop table " % %
] "" make ;
SYMBOL: postgresql-counter
M: postgresql-db insert-sql* ( columns table -- sql )
[
postgresql-counter off
"insert into " %
2dup "insert into " %
%
"(" %
dup [ ", " % ] [ second % ] interleave
") " %
" values (" %
[ ", " % ] [
drop "$" % postgresql-counter [ inc ] keep get #
] interleave
length [1,b] [ ", " % ] [ "$" % # ] 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 ;
@ -144,9 +216,10 @@ M: postgresql-db update-sql* ( columns table -- sql )
%
" set " %
dup remove-id
[ ", " % ] [ second dup % " = :" % % ] interleave
dup length [1,b] swap 2array flip
[ ", " % ] [ first2 second % " = $" % # ] interleave
" where " %
[ primary-key? ] find nip second dup % " = :" % %
[ primary-key? ] find nip second dup % " = $" % length 2 + #
] "" make ;
M: postgresql-db delete-sql* ( columns table -- sql )
@ -154,23 +227,19 @@ M: postgresql-db delete-sql* ( columns table -- sql )
"delete from " %
%
" where " %
first second dup % " = :" % %
first second % " = $1" %
] "" make ;
M: postgresql-db select-sql* ( columns table -- sql )
drop ;
M: postgresql-db tuple>params ( columns tuple -- obj )
[
>r dup first r> get-slot-named swap third
] curry { } map>assoc ;
[ >r dup third swap first r> get-slot-named swap ]
curry { } map>assoc ;
M: postgresql-db last-id ( res -- id )
pq-oid-value ;
: postgresql-db-modifiers ( -- hashtable )
H{
{ +native-id+ "primary key" }
{ +native-id+ "not null primary key" }
{ +assigned-id+ "primary key" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
@ -189,18 +258,3 @@ M: postgresql-db sql-modifiers* ( modifiers -- str )
swap at
] if
] 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
{
{ 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 ] }
{ VARCHAR [ sqlite-bind-text-by-name ] }
{ DOUBLE [ sqlite-bind-double-by-name ] }
{ SERIAL [ sqlite-bind-int-by-name ] }
! { NULL [ sqlite-bind-null-by-name ] }
[ no-sql-type ]
} case ;
@ -99,13 +100,13 @@ IN: db.sqlite.lib
: sqlite-row ( handle -- seq )
dup sqlite-#columns [ sqlite-column ] with map ;
: step-complete? ( step-result -- bool )
: sqlite-step-has-more-rows? ( step-result -- bool )
dup SQLITE_ROW = [
drop f
drop t
] [
dup SQLITE_DONE =
[ drop ] [ sqlite-check-result ] if t
[ drop ] [ sqlite-check-result ] if f
] if ;
: 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 ;
C: <sqlite-statement> sqlite-statement
TUPLE: sqlite-result-set advanced? ;
: <sqlite-result-set> ( query -- sqlite-result-set )
dup statement-handle sqlite-result-set <result-set> ;
TUPLE: sqlite-result-set has-more? ;
M: sqlite-db <simple-statement> ( str -- obj )
<prepared-statement> ;
@ -40,13 +38,7 @@ M: sqlite-db <prepared-statement> ( str -- obj )
M: sqlite-statement dispose ( statement -- )
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 -- )
maybe-advance-row
f swap set-result-set-handle ;
: sqlite-bind ( triples handle -- )
@ -58,8 +50,12 @@ M: sqlite-statement bind-statement* ( triples statement -- )
M: sqlite-statement reset-statement ( statement -- )
statement-handle sqlite-reset ;
M: sqlite-statement execute-statement* ( statement -- obj )
query-results ;
: last-insert-id ( -- id )
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 )
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 )
>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
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 )
dup statement-handle sqlite-result-set <result-set> ;
dup statement-handle sqlite-result-set <result-set>
dup advance-row ;
M: sqlite-db begin-transaction ( -- )
"BEGIN" sql-command ;
@ -93,9 +93,10 @@ M: sqlite-db create-sql ( columns table -- sql )
] interleave ")" %
] "" make ;
M: sqlite-db drop-sql ( table -- sql )
M: sqlite-db drop-sql ( columns table -- sql )
[
"drop table " % %
drop
] "" make ;
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
third 3array
] 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 )
H{
@ -175,6 +171,7 @@ M: sqlite-db sql-modifiers* ( modifiers -- str )
: sqlite-type-hash ( -- assoc )
H{
{ INTEGER "integer" }
{ SERIAL "integer" }
{ TEXT "text" }
{ VARCHAR "text" }
{ DOUBLE "real" }
@ -190,4 +187,3 @@ M: sqlite-db >sql-type ( obj -- str )
! HOOK: get-column-value ( n result-set type -- )
! M: sqlite get-column-value { { "TEXT" get-text-column } {
! "INTEGER" get-integer-column } ... } case ;

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

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

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

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

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

@ -11,6 +11,12 @@ SYMBOL: +assigned-id+
: primary-key? ( spec -- ? )
[ { +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
SYMBOL: +autoincrement+
SYMBOL: +serial+
@ -22,6 +28,7 @@ SYMBOL: +not-null+
SYMBOL: +has-many+
SYMBOL: SERIAL
SYMBOL: INTEGER
SYMBOL: DOUBLE
SYMBOL: BOOLEAN

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

@ -1,8 +1,8 @@
USING: help help.markup help.syntax help.topics
namespaces words sequences classes assocs vocabs kernel
arrays prettyprint.backend kernel.private io tools.browser
generic math tools.profiler system ui strings sbufs vectors
byte-arrays bit-arrays float-arrays quotations help.lint ;
USING: help help.markup help.syntax help.definitions help.topics
namespaces words sequences classes assocs vocabs kernel arrays
prettyprint.backend kernel.private io generic math system
strings sbufs vectors byte-arrays bit-arrays float-arrays
quotations ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
@ -161,15 +161,20 @@ ARTICLE: "io" "Input and output"
{ $subsection "io.timeouts" } ;
ARTICLE: "tools" "Developer tools"
{ $subsection "tools.annotations" }
{ $subsection "tools.crossref" }
"Exploratory tools:"
{ $subsection "editor" }
{ $subsection "tools.crossref" }
{ $subsection "inspector" }
"Debugging tools:"
{ $subsection "tools.annotations" }
{ $subsection "tools.test" }
{ $subsection "meta-interpreter" }
"Performance tools:"
{ $subsection "tools.memory" }
{ $subsection "profiling" }
{ $subsection "tools.test" }
{ $subsection "timing" }
{ $subsection "tools.disassembler" }
"Deployment tools:"
{ $subsection "tools.deploy" } ;
ARTICLE: "article-index" "Article index"
@ -201,7 +206,6 @@ ARTICLE: "handbook" "Factor documentation"
{ $subsection "cookbook" }
{ $subsection "first-program" }
{ $subsection "vocab-index" }
{ $subsection "changes" }
{ $heading "Language reference" }
{ $subsection "conventions" }
{ $subsection "syntax" }
@ -231,137 +235,6 @@ ARTICLE: "handbook" "Factor documentation"
{ $subsection "type-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> }
related-words

2
extra/http/http.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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 ;
IN: http

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

@ -1,7 +1,8 @@
! Copyright (C) 2007 Gavin Harrison
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences kernel.private namespaces arrays io io.files
splitting io.binary math.functions vectors quotations sequences.private ;
USING: kernel math sequences kernel.private namespaces arrays io
io.files splitting io.binary math.functions vectors quotations
combinators ;
IN: icfp.2006
SYMBOL: regs
@ -9,10 +10,6 @@ SYMBOL: arrays
SYMBOL: finger
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 ;
: set-reg ( val n -- ) regs get set-nth ;
@ -117,11 +114,21 @@ SYMBOL: open-arrays
: run-op ( -- bool )
advance
{
[ op0 ] [ op1 ] [ op2 ] [ op3 ]
[ op4 ] [ op5 ] [ op6 ] [ drop t ]
[ op8 ] [ op9 ] [ op10 ] [ op11 ]
[ op12 ] [ op13 ]
} call-nth ;
{ 0 [ op0 ] }
{ 1 [ op1 ] }
{ 2 [ op2 ] }
{ 3 [ op3 ] }
{ 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 -- )
[ 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" } }
{ $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*
{ $values { "desc" "a launch descriptor" } { "handle" "a process handle" } }
{ $contract "Launches a process using the launch descriptor." }
@ -186,6 +190,8 @@ ARTICLE: "io.launcher" "Launching OS processes"
{ $subsection try-process }
"Stopping processes:"
{ $subsection kill-process }
"Finding the current process handle:"
{ $subsection current-process-handle }
"Redirecting standard input and output to a pipe:"
{ $subsection <process-stream> }
{ $subsection with-process-stream }

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

@ -76,6 +76,8 @@ SYMBOL: +append-environment+
{ [ dup assoc? ] [ >hashtable ] }
} cond ;
HOOK: current-process-handle io-backend ( -- handle )
HOOK: run-process* io-backend ( desc -- handle )
: wait-for-process ( process -- status )
@ -119,7 +121,9 @@ HOOK: process-stream* io-backend ( desc -- stream process )
TUPLE: process-stream process ;
: <process-stream> ( desc -- stream )
>descriptor process-stream*
>descriptor
[ process-stream* ] keep
+timeout+ swap at [ over set-timeout ] when*
{ set-delegate set-process-stream-process }
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
alien.c-types debugger continuations arrays assocs
combinators unix.process parser-combinators memoize
promises strings threads ;
promises strings threads unix ;
IN: io.unix.launcher
! Search unix first
@ -50,15 +50,16 @@ MEMO: 'arguments' ( -- parser )
: redirect ( obj mode fd -- )
{
{ [ pick not ] [ 2nip F_SETFL 0 fcntl io-error ] }
{ [ pick +closed+ eq? ] [ close 2drop ] }
{ [ pick string? ] [ (redirect) ] }
} cond ;
: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
: setup-redirection ( -- )
+stdin+ get read-flags 0 redirect
+stdout+ get write-flags 1 redirect
+stdin+ get ?closed read-flags 0 redirect
+stdout+ get ?closed write-flags 1 redirect
+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 ( -- )
[
@ -70,6 +71,8 @@ MEMO: 'arguments' ( -- parser )
io-error
] [ error. :c flush ] recover 1 exit ;
M: unix-io current-process-handle ( -- handle ) getpid ;
M: unix-io run-process* ( desc -- pid )
[
[ 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.
! See http://factorcode.org/license.txt for BSD license.
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
namespaces io.launcher kernel sequences windows.errors assocs
splitting system threads init strings combinators io.backend ;
@ -87,75 +87,29 @@ TUPLE: CreateProcess-args
over set-CreateProcess-args-lpEnvironment
] 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
dup CreateProcess-args-lpStartupInfo
STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
STARTF_USESTDHANDLES swap set-STARTUPINFO-dwFlags ;
over redirect-stdout over set-STARTUPINFO-hStdOutput
over redirect-stderr over set-STARTUPINFO-hStdError
over redirect-stdin over set-STARTUPINFO-hStdInput
HOOK: fill-redirection io-backend ( args -- args )
drop ;
M: windows-ce-io fill-redirection ;
: make-CreateProcess-args ( -- args )
default-CreateProcess-args
wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
fill-dwCreateFlags
fill-lpEnvironment ;
fill-lpEnvironment
fill-startup-info ;
M: windows-io current-process-handle ( -- handle )
GetCurrentProcessId ;
M: windows-io run-process* ( desc -- handle )
[
[
make-CreateProcess-args fill-startup-info
make-CreateProcess-args
fill-redirection
dup call-CreateProcess
CreateProcess-args-lpProcessInformation <process>
] 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
kernel libc math threads windows windows.kernel32 alien.c-types
alien.arrays sequences combinators combinators.lib sequences.lib
ascii splitting alien strings ;
ascii splitting alien strings assocs ;
IN: io.windows.nt.files
M: windows-nt-io cwd
@ -60,7 +60,7 @@ M: windows-nt-io root-directory? ( path -- ? )
M: windows-nt-io normalize-pathname ( string -- string )
dup string? [ "pathname must be a string" throw ] unless
"/" split "\\" join
{ { CHAR: / CHAR: \\ } } substitute
cwd swap windows-path+
[ "/\\." member? ] right-trim
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
io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system
io.windows.launcher io.windows.pipes ;
sequences windows.errors assocs splitting system strings
io.windows.launcher io.windows.nt.pipes io.backend
combinators ;
IN: io.windows.nt.launcher
! The below code is based on the example given in
! 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 ? -- )
>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
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
fill-stdout-pipe
fill-stdin-pipe
fill-startup-info
fill-redirection
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.
USING: alien alien.c-types arrays destructors io io.windows libc
windows.types math windows.kernel32 windows namespaces kernel
sequences windows.errors assocs math.parser system random ;
IN: io.windows.pipes
sequences windows.errors assocs math.parser system random
combinators ;
IN: io.windows.nt.pipes
! This code is based on
! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
@ -65,3 +66,20 @@ TUPLE: pipe in out ;
: <unique-outgoing-pipe> ( -- 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
math.vectors namespaces sequences ;
math.vectors namespaces sequences combinators.cleave ;
IN: math.analysis
<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
prettyprint.backend sequences words arrays match macros
assocs sequences.private optimizer.specializers generic
combinators sorting math ;
combinators sorting math quotations ;
IN: optimizer.debugger
! A simple tool for turning dataflow IR into quotations, for
@ -67,7 +67,7 @@ M: #shuffle node>quot
[ , ] [ >r drop t r> ] if*
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 % ;
@ -82,7 +82,11 @@ M: #call node>quot #call>quot ;
M: #call-label node>quot #call>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 , ;
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
sequences namespaces io.sockets continuations ;
IN: smtp.server
SYMBOL: data-mode
@ -55,7 +56,7 @@ SYMBOL: data-mode
data-mode off
"220 OK\r\n" write flush t
] }
{ [ data-mode get ] [ t ] }
{ [ data-mode get ] [ global [ print ] bind t ] }
{ [ t ] [
"500 ERROR\r\n" write flush t
] }
@ -68,5 +69,6 @@ SYMBOL: data-mode
60000 stdio get set-timeout
"220 hello\r\n" write flush
process
global [ flush ] bind
] with-stream
] with-disposal ;

14
extra/smtp/smtp.factor
View File

@ -139,7 +139,7 @@ LOG: smtp-response DEBUG
: prepare-message ( body headers -- body' )
[
prepare-headers
" " ,
"" ,
dup string? [ string-lines ] when %
] { } make ;
@ -169,3 +169,15 @@ LOG: smtp-response DEBUG
! : cram-md5-auth ( key login -- )
! "AUTH CRAM-MD5\r\n" 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 ;
: load-everything ( -- )
try-everything drop ;
try-everything load-failures. ;
: unrooted-child-vocabs ( prefix -- seq )
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:"
{ $subsection data-gc }
{ $subsection code-gc }
{ $see-also "image" } ;
{ $see-also "images" } ;
ABOUT: "tools.memory"

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

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

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

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

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

@ -1,11 +1,11 @@
! Copyright (C) 2005, 2007 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays ui ui.gadgets ui.gestures ui.backend
ui.clipboards ui.gadgets.worlds assocs kernel math namespaces
opengl sequences strings x11.xlib x11.events x11.xim x11.glx
x11.clipboard x11.constants x11.windows io.utf8 combinators
debugger system command-line ui.render math.vectors tuples
opengl.gl threads ;
USING: alien alien.c-types arrays ui ui.gadgets ui.gestures
ui.backend ui.clipboards ui.gadgets.worlds assocs kernel math
namespaces opengl sequences strings x11.xlib x11.events x11.xim
x11.glx x11.clipboard x11.constants x11.windows
io.encodings.utf8 combinators debugger system command-line
ui.render math.vectors tuples opengl.gl threads ;
IN: ui.x11
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 )
3 swap (process-data)
[ string>number ] assoc-map
[ nip 0 = not ] assoc-subset
[ nip zero? not ] assoc-subset
>hashtable ;
: categories ( -- names )
@ -93,13 +93,10 @@ IN: unicode.data
: ascii-lower ( string -- lower )
[ 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 )
1 swap (process-data)
[ ascii-lower CHAR: \s CHAR: - replace swap ] assoc-map
>hashtable ;
1 swap (process-data) [
ascii-lower { { CHAR: \s CHAR: - } } substitute swap
] assoc-map >hashtable ;
: multihex ( hexstring -- string )
" " 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:
CREATE ";" parse-tokens
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
unicode.case unicode.categories ;
USING: unicode.syntax unicode.data unicode.breaks
unicode.normalize unicode.case unicode.categories
parser kernel namespaces ;
IN: unicode
! 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: int getaddrinfo ( char* hostname, char* servname, addrinfo* hints, addrinfo** res ) ;
FUNCTION: char* getcwd ( char* buf, size_t size ) ;
FUNCTION: pid_t getpid ;
FUNCTION: int getdtablesize ;
FUNCTION: gid_t getegid ;
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 ) ;
: GetCurrentDirectory GetCurrentDirectoryW ; inline
FUNCTION: HANDLE GetCurrentProcess ( ) ;
! FUNCTION: GetCurrentProcessId
FUNCTION: DWORD GetCurrentProcessId ( ) ;
FUNCTION: HANDLE GetCurrentThread ( ) ;
! FUNCTION: GetCurrentThreadId
! FUNCTION: GetDateFormatA

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

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax arrays kernel math
namespaces sequences io.utf8 x11.xlib x11.constants ;
namespaces sequences io.encodings.utf8 x11.xlib x11.constants ;
IN: x11.clipboard
! 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)));
}
/* word-xt ( word -- xt ) */
/* word-xt ( word -- start end ) */
DEFINE_PRIMITIVE(word_xt)
{
F_WORD *word = untag_word(dpeek());
drepl(allot_cell((CELL)word->xt));
F_WORD *word = untag_word(dpop());
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)