diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor
index 54348e47f9..f68bdcf0a2 100755
--- a/core/alien/compiler/compiler.factor
+++ b/core/alien/compiler/compiler.factor
@@ -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 [
@@ -398,7 +398,7 @@ TUPLE: callback-context ;
callback-unwind %unwind ;
: generate-callback ( node -- )
- dup alien-callback-xt dup rot [
+ dup alien-callback-xt dup [
init-templates
%save-word-xt
%prologue-later
@@ -407,7 +407,7 @@ TUPLE: callback-context ;
dup wrap-callback-quot %alien-callback
%callback-return
] with-stack-frame
- ] generate-1 ;
+ ] with-generator ;
M: alien-callback generate-node
end-basic-block generate-callback iterate-next ;
diff --git a/core/alien/structs/structs-tests.factor b/core/alien/structs/structs-tests.factor
index b2da0e8392..b934cd56a3 100644
--- a/core/alien/structs/structs-tests.factor
+++ b/core/alien/structs/structs-tests.factor
@@ -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 ;
diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor
index 2eabe9b0bc..716ac64c9b 100755
--- a/core/assocs/assocs-docs.factor
+++ b/core/assocs/assocs-docs.factor
@@ -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." }
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index d8cf01e1bd..ff0938e001 100755
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -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 [
diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor
index ff9d5c5e1e..6d21504f8b 100755
--- a/core/bootstrap/compiler/compiler.factor
+++ b/core/bootstrap/compiler/compiler.factor
@@ -74,6 +74,12 @@ nl
malloc free memcpy
} compile
-[ compiled-usages recompile ] recompile-hook set-global
+: enable-compiler ( -- )
+ [ compiled-usages recompile ] recompile-hook set-global ;
+
+: disable-compiler ( -- )
+ [ [ f ] { } map>assoc modify-code-heap ] recompile-hook set-global ;
+
+enable-compiler
" done" print flush
diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor
index cd99796e7e..3bc82bbe6a 100755
--- a/core/bootstrap/stage2.factor
+++ b/core/bootstrap/stage2.factor
@@ -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
diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor
index d91c920def..5b87297b0c 100755
--- a/core/combinators/combinators-docs.factor
+++ b/core/combinators/combinators-docs.factor
@@ -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" } }
diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor
old mode 100644
new mode 100755
index 3cefda7f71..ce8e180867
--- a/core/combinators/combinators-tests.factor
+++ b/core/combinators/combinators-tests.factor
@@ -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
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index 0ba8b583be..ffd1576e6e 100755
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -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 ;
diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor
index 2674734483..f44e6c1387 100755
--- a/core/compiler/compiler.factor
+++ b/core/compiler/compiler.factor
@@ -30,7 +30,7 @@ IN: compiler
: compile-succeeded ( word -- effect dependencies )
[
- dup word-dataflow >r swap dup r> optimize generate
+ [ word-dataflow optimize ] keep dup generate
] computing-dependencies ;
: compile-failed ( word error -- )
diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor
index 1ed43120d3..6deed6c756 100755
--- a/core/compiler/tests/simple.factor
+++ b/core/compiler/tests/simple.factor
@@ -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
diff --git a/core/compiler/tests/stack-trace.factor b/core/compiler/tests/stack-trace.factor
index 71c95b1b61..137d86b489 100755
--- a/core/compiler/tests/stack-trace.factor
+++ b/core/compiler/tests/stack-trace.factor
@@ -1,7 +1,7 @@
IN: temporary
USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private
-words splitting ;
+words splitting sorting ;
: symbolic-stack-trace ( -- newseq )
error-continuation get continuation-call callstack>array
@@ -31,9 +31,9 @@ words splitting ;
\ > stack-trace-contains?
] unit-test
-: quux [ t [ "hi" throw ] when ] times ;
+: quux { 1 2 3 } [ "hi" throw ] sort ;
[ t ] [
[ 10 quux ] ignore-errors
- \ (each-integer) stack-trace-contains?
+ \ sort stack-trace-contains?
] unit-test
diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor
index e518d2de8a..13d834a489 100755
--- a/core/compiler/tests/templates-early.factor
+++ b/core/compiler/tests/templates-early.factor
@@ -44,7 +44,9 @@ words kernel math effects definitions compiler.units ;
[
[ ] [ init-templates ] unit-test
- [ ] [ init-generator ] unit-test
+ H{ } clone compiled set
+
+ [ ] [ gensym gensym begin-compiling ] unit-test
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor
index 74e5ab80a4..4be700f221 100755
--- a/core/compiler/tests/templates.factor
+++ b/core/compiler/tests/templates.factor
@@ -3,7 +3,7 @@ USING: arrays compiler kernel kernel.private math
hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts
-words definitions compiler.units ;
+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
diff --git a/core/debugger/debugger-tests.factor b/core/debugger/debugger-tests.factor
new file mode 100755
index 0000000000..31c3e8a762
--- /dev/null
+++ b/core/debugger/debugger-tests.factor
@@ -0,0 +1,4 @@
+IN: temporary
+USING: debugger kernel continuations tools.test ;
+
+[ ] [ [ drop ] [ error. ] recover ] unit-test
diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor
index 17c0c64bf1..25e2f8222b 100755
--- a/core/generator/fixup/fixup.factor
+++ b/core/generator/fixup/fixup.factor
@@ -140,17 +140,19 @@ SYMBOL: literal-table
V{ } clone relocation-table set
V{ } clone label-table set ;
-: generate-labels ( -- labels )
- label-table get [
+: resolve-labels ( labels -- labels' )
+ [
first3 label-offset
[ "Unresolved label" throw ] unless*
3array
] map concat ;
-: fixup ( code -- relocation-table label-table code )
+: fixup ( code -- literals relocation labels code )
[
init-fixup
dup stack-frame-size swap [ fixup* ] each drop
+
+ literal-table get >array
relocation-table get >array
- generate-labels
+ label-table get resolve-labels
] { } make ;
diff --git a/core/generator/generator-docs.factor b/core/generator/generator-docs.factor
index 029749180e..4473df7277 100755
--- a/core/generator/generator-docs.factor
+++ b/core/generator/generator-docs.factor
@@ -22,34 +22,35 @@ HELP: compiled
{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
HELP: compiling-word
-{ $var-description "The word currently being compiled, set by " { $link generate-1 } "." } ;
+{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
HELP: compiling-label
-{ $var-description "The label currently being compiled, set by " { $link generate-1 } "." } ;
+{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
HELP: compiled-stack-traces?
{ $values { "?" "a boolean" } }
{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
HELP: literal-table
-{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ;
+{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;
-HELP: init-generator
+HELP: begin-compiling
+{ $values { "word" word } { "label" word } }
{ $description "Prepares to generate machine code for a word." } ;
-HELP: generate-1
-{ $values { "word" word } { "label" word } { "node" "a dataflow node" } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
+HELP: with-generator
+{ $values { "node" "a dataflow node" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the dataflow node." } ;
HELP: generate-node
{ $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
{ $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
-{ $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ;
+{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
HELP: generate-nodes
{ $values { "node" "a dataflow node" } }
{ $description "Recursively generate machine code for a dataflow graph." }
-{ $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ;
+{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
HELP: generate
{ $values { "word" word } { "label" word } { "node" "a dataflow node" } }
diff --git a/core/generator/generator.factor b/core/generator/generator.factor
index d8164fdce7..3514947e3d 100755
--- a/core/generator/generator.factor
+++ b/core/generator/generator.factor
@@ -11,12 +11,6 @@ IN: generator
SYMBOL: compile-queue
SYMBOL: compiled
-: begin-compiling ( word -- )
- f swap compiled get set-at ;
-
-: finish-compiling ( word literals relocation labels code -- )
- 4array swap compiled get set-at ;
-
: queue-compile ( word -- )
{
{ [ dup compiled get key? ] [ drop ] }
@@ -32,24 +26,31 @@ SYMBOL: compiling-word
SYMBOL: compiling-label
+SYMBOL: compiling-loops
+
! Label of current word, after prologue, makes recursion faster
SYMBOL: current-label-start
: compiled-stack-traces? ( -- ? ) 36 getenv ;
-: init-generator ( -- )
+: begin-compiling ( word label -- )
+ H{ } clone compiling-loops set
+ compiling-label set
+ compiling-word set
compiled-stack-traces?
- compiling-word get f ?
- 1vector literal-table set ;
+ compiling-word get f ?
+ 1vector literal-table set
+ f compiling-word get compiled get set-at ;
-: generate-1 ( word label node quot -- )
- pick begin-compiling [
- roll compiling-word set
- pick compiling-label set
- init-generator
- call
- literal-table get >array
- ] { } make fixup finish-compiling ;
+: finish-compiling ( literals relocation labels code -- )
+ 4array compiling-label get compiled get set-at ;
+
+: with-generator ( node word label quot -- )
+ [
+ >r begin-compiling r>
+ { } make fixup
+ finish-compiling
+ ] with-scope ; inline
GENERIC: generate-node ( node -- next )
@@ -62,12 +63,12 @@ GENERIC: generate-node ( node -- next )
%prologue-later
current-label-start define-label
current-label-start resolve-label ;
-
-: generate ( word label node -- )
+
+: generate ( node word label -- )
[
init-generate-nodes
[ generate-nodes ] with-node-iterator
- ] generate-1 ;
+ ] with-generator ;
: word-dataflow ( word -- effect dataflow )
[
@@ -82,25 +83,6 @@ GENERIC: generate-node ( node -- next )
: if-intrinsics ( #call -- quot )
node-param "if-intrinsics" word-prop ;
-DEFER: #terminal?
-
-PREDICATE: #merge #terminal-merge node-successor #terminal? ;
-
-PREDICATE: #values #terminal-values node-successor #terminal? ;
-
-PREDICATE: #call #terminal-call
- dup node-successor #if?
- over node-successor node-successor #terminal? and
- swap if-intrinsics and ;
-
-UNION: #terminal
- POSTPONE: f #return #terminal-values #terminal-merge ;
-
-: tail-call? ( -- ? )
- node-stack get [
- dup #terminal-call? swap node-successor #terminal? or
- ] all? ;
-
! node
M: node generate-node drop iterate-next ;
@@ -112,20 +94,34 @@ M: node generate-node drop iterate-next ;
: generate-call ( label -- next )
dup maybe-compile
end-basic-block
- tail-call? [
- %jump f
+ dup compiling-loops get at [
+ %jump-label f
] [
- 0 frame-required
- %call
- iterate-next
- ] if ;
+ tail-call? [
+ %jump f
+ ] [
+ 0 frame-required
+ %call
+ iterate-next
+ ] if
+ ] ?if ;
! #label
M: #label generate-node
dup node-param generate-call >r
- dup #label-word over node-param rot node-child generate
+ dup node-child over #label-word rot node-param generate
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-loop
+ node-child generate-nodes
+ iterate-next ;
+
! #if
: end-false-branch ( label -- )
tail-call? [ %return drop ] [ %jump-label ] if ;
@@ -150,25 +146,18 @@ M: #if generate-node
! #dispatch
: dispatch-branch ( node word -- label )
gensym [
- rot [
+ [
copy-templates
%save-dispatch-xt
%prologue-later
[ generate-nodes ] with-node-iterator
- ] generate-1
+ ] 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 -- )
@@ -182,10 +171,10 @@ M: #dispatch generate-node
generate-dispatch iterate-next
] [
compiling-word get gensym [
- rot [
+ [
init-generate-nodes
generate-dispatch
- ] generate-1
+ ] with-generator
] keep generate-call
] if ;
@@ -224,10 +213,11 @@ M: #dispatch generate-node
: define-if-intrinsic ( word quot inputs -- )
2array 1array define-if-intrinsics ;
-: do-if-intrinsic ( #call pair -- next )
- <label> [ swap do-template ] keep
- >r node-successor r> generate-if
- node-successor ;
+: do-if-intrinsic ( pair -- next )
+ <label> [
+ swap do-template
+ node> node-successor dup >node
+ ] keep generate-if ;
: find-intrinsic ( #call -- pair/f )
intrinsics find-template ;
@@ -249,7 +239,7 @@ M: #call generate-node
] [
node-param generate-call
] ?if
- ] if* ;
+ ] ?if ;
! #call-label
M: #call-label generate-node node-param generate-call ;
@@ -274,4 +264,7 @@ M: #r> generate-node
iterate-next ;
! #return
-M: #return generate-node drop end-basic-block %return f ;
+M: #return generate-node
+ end-basic-block
+ node-param compiling-loops get key?
+ [ %return ] unless f ;
diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor
old mode 100644
new mode 100755
index 8dc9bd606f..307e3a99f1
--- a/core/generator/registers/registers.factor
+++ b/core/generator/registers/registers.factor
@@ -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 ;
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 2cc28ac0d1..0b2b9fcca3 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -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
diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor
index b24928a71e..8c935db859 100755
--- a/core/hashtables/hashtables.factor
+++ b/core/hashtables/hashtables.factor
@@ -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> ;
diff --git a/core/inference/dataflow/dataflow-docs.factor b/core/inference/dataflow/dataflow-docs.factor
index 0f809fa2bd..66b3590253 100755
--- a/core/inference/dataflow/dataflow-docs.factor
+++ b/core/inference/dataflow/dataflow-docs.factor
@@ -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 } } }
diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor
index 71cb0eef65..23b5343c9c 100755
--- a/core/inference/dataflow/dataflow.factor
+++ b/core/inference/dataflow/dataflow.factor
@@ -97,11 +97,13 @@ M: object flatten-curry , ;
: node-child node-children first ;
-TUPLE: #label word ;
+TUPLE: #label word loop? ;
: #label ( word label -- node )
\ #label param-node [ set-#label-word ] keep ;
+PREDICATE: #label #loop #label-loop? ;
+
TUPLE: #entry ;
: #entry ( -- node ) \ #entry all-out-node ;
@@ -304,3 +306,19 @@ SYMBOL: node-stack
node-children
[ last-node ] map
[ #terminate? not ] subset ;
+
+DEFER: #tail?
+
+PREDICATE: #merge #tail-merge node-successor #tail? ;
+
+PREDICATE: #values #tail-values node-successor #tail? ;
+
+UNION: #tail
+ POSTPONE: f #return #tail-values #tail-merge #terminate ;
+
+: tail-call? ( -- ? )
+ #! 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? ;
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index e6479d0c6a..9d0f959b68 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -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
diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor
index 7faeefc3d6..240f39218b 100755
--- a/core/inference/transforms/transforms.factor
+++ b/core/inference/transforms/transforms.factor
@@ -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
diff --git a/core/io/utf16/authors.txt b/core/io/encodings/binary/authors.txt
similarity index 100%
rename from core/io/utf16/authors.txt
rename to core/io/encodings/binary/authors.txt
diff --git a/core/io/encodings/binary/binary-docs.factor b/core/io/encodings/binary/binary-docs.factor
new file mode 100644
index 0000000000..f8be5054df
--- /dev/null
+++ b/core/io/encodings/binary/binary-docs.factor
@@ -0,0 +1,5 @@
+USING: help.syntax help.markup ;
+IN: io.encodings.binary
+
+HELP: binary
+{ $class-description "This is the encoding descriptor for binary I/O." } ;
diff --git a/core/io/encodings/binary/binary.factor b/core/io/encodings/binary/binary.factor
new file mode 100644
index 0000000000..b58f9836c0
--- /dev/null
+++ b/core/io/encodings/binary/binary.factor
@@ -0,0 +1,6 @@
+USING: kernel io.encodings ;
+
+TUPLE: binary ;
+
+M: binary init-decoding drop ;
+M: binary init-encoding drop ;
diff --git a/core/io/encodings/binary/summary.txt b/core/io/encodings/binary/summary.txt
new file mode 100644
index 0000000000..a1eb4bc664
--- /dev/null
+++ b/core/io/encodings/binary/summary.txt
@@ -0,0 +1 @@
+Dummy encoding for binary I/O
diff --git a/core/io/encodings/binary/tags.txt b/core/io/encodings/binary/tags.txt
new file mode 100644
index 0000000000..8e27be7d61
--- /dev/null
+++ b/core/io/encodings/binary/tags.txt
@@ -0,0 +1 @@
+text
diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor
index 767e9b266b..94a5bf8853 100755
--- a/core/io/encodings/encodings.factor
+++ b/core/io/encodings/encodings.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel sequences sbufs vectors
-namespaces unicode.syntax ;
+USING: math kernel sequences sbufs vectors io.streams.lines io.streams.plain
+namespaces unicode growable strings io classes io.streams.c
+continuations ;
IN: io.encodings
TUPLE: encode-error ;
@@ -18,11 +19,77 @@ 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 ;
-: decode ( seq quot -- str )
- >r [ length <sbuf> 0 begin ] keep r> each
+: start-decoding ( seq length -- buf ch state seq )
+ <sbuf> 0 begin roll ;
+
+GENERIC: decode-step ( buf byte ch state encoding -- buf ch state )
+
+: decode ( seq quot -- string )
+ >r dup length start-decoding r>
+ [ -rot ] swap compose each
finish-decoding ; inline
+
+: space ( resizable -- room-left )
+ dup underlying swap [ length ] 2apply - ;
+
+: full? ( resizable -- ? ) space zero? ;
+
+: end-read-loop ( buf ch state stream quot -- string/f )
+ 2drop 2drop >string f like ;
+
+: decode-read-loop ( buf ch state stream encoding -- string/f )
+ >r >r pick r> r> rot full? [ end-read-loop ] [
+ over stream-read1 [
+ -rot tuck >r >r >r -rot r> decode-step r> r> decode-read-loop
+ ] [ end-read-loop ] if*
+ ] if ;
+
+: decode-read ( length stream encoding -- string )
+ >r swap start-decoding r>
+ decode-read-loop ;
+
+GENERIC: init-decoding ( stream encoding -- decoded-stream )
+
+: <decoding> ( stream decoding-class -- decoded-stream )
+ construct-empty init-decoding <line-reader> ;
+
+GENERIC: init-encoding ( stream encoding -- encoded-stream )
+
+: <encoding> ( stream encoding-class -- encoded-stream )
+ construct-empty init-encoding <plain-writer> ;
+
+GENERIC: encode-string ( string encoding -- byte-array )
+M: tuple-class encode-string construct-empty encode-string ;
+
+MIXIN: encoding-stream
+
+M: encoding-stream init-decoding ( stream encoding-stream -- encoding-stream )
+ tuck set-delegate ;
+
+M: encoding-stream init-encoding ( stream encoding-stream -- encoding-stream )
+ tuck set-delegate ;
+
+M: encoding-stream stream-read1 1 swap stream-read ;
+
+M: encoding-stream stream-read
+ [ delegate ] keep decode-read ;
+
+M: encoding-stream stream-read-partial stream-read ;
+
+M: encoding-stream stream-read-until
+ ! Copied from { c-reader stream-read-until }!!!
+ [ swap read-until-loop ] "" make
+ swap over empty? over not and [ 2drop f f ] when ;
+
+M: encoding-stream stream-write1
+ >r 1string r> stream-write ;
+
+M: encoding-stream stream-write
+ [ encode-string ] keep delegate stream-write ;
+
+M: encoding-stream dispose delegate dispose ;
diff --git a/core/io/utf8/authors.txt b/core/io/encodings/latin1/authors.txt
similarity index 100%
rename from core/io/utf8/authors.txt
rename to core/io/encodings/latin1/authors.txt
diff --git a/core/io/encodings/latin1/latin1-docs.factor b/core/io/encodings/latin1/latin1-docs.factor
new file mode 100644
index 0000000000..5872b2bcfd
--- /dev/null
+++ b/core/io/encodings/latin1/latin1-docs.factor
@@ -0,0 +1,5 @@
+USING: help.syntax help.markup ;
+IN: io.encodings.latin1
+
+HELP: latin1
+{ $class-description "This class is used for Latin 1 (ISO 8859-1) encoding and decoding" } ;
diff --git a/core/io/encodings/latin1/latin1.factor b/core/io/encodings/latin1/latin1.factor
new file mode 100755
index 0000000000..468324316d
--- /dev/null
+++ b/core/io/encodings/latin1/latin1.factor
@@ -0,0 +1,19 @@
+USING: io io.encodings strings kernel ;
+IN: io.encodings.latin1
+
+TUPLE: latin1 stream ;
+
+M: latin1 init-decoding tuck set-latin1-stream ;
+M: latin1 init-encoding drop ;
+
+M: latin1 stream-read1
+ latin1-stream stream-read1 ;
+
+M: latin1 stream-read
+ latin1-stream stream-read >string ;
+
+M: latin1 stream-read-until
+ latin1-stream stream-read-until >string ;
+
+M: latin1 stream-readln
+ latin1-stream stream-readln >string ;
diff --git a/core/io/encodings/latin1/summary.txt b/core/io/encodings/latin1/summary.txt
new file mode 100644
index 0000000000..d40d628767
--- /dev/null
+++ b/core/io/encodings/latin1/summary.txt
@@ -0,0 +1 @@
+ISO 8859-1 encoding/decoding
diff --git a/core/io/encodings/latin1/tags.txt b/core/io/encodings/latin1/tags.txt
new file mode 100644
index 0000000000..8e27be7d61
--- /dev/null
+++ b/core/io/encodings/latin1/tags.txt
@@ -0,0 +1 @@
+text
diff --git a/core/io/encodings/utf16/.utf16.factor.swo b/core/io/encodings/utf16/.utf16.factor.swo
new file mode 100644
index 0000000000..01be8fdab2
Binary files /dev/null and b/core/io/encodings/utf16/.utf16.factor.swo differ
diff --git a/core/io/encodings/utf16/authors.txt b/core/io/encodings/utf16/authors.txt
new file mode 100644
index 0000000000..f990dd0ed2
--- /dev/null
+++ b/core/io/encodings/utf16/authors.txt
@@ -0,0 +1 @@
+Daniel Ehrenberg
diff --git a/core/io/utf16/summary.txt b/core/io/encodings/utf16/summary.txt
similarity index 100%
rename from core/io/utf16/summary.txt
rename to core/io/encodings/utf16/summary.txt
diff --git a/core/io/encodings/utf16/tags.txt b/core/io/encodings/utf16/tags.txt
new file mode 100644
index 0000000000..8e27be7d61
--- /dev/null
+++ b/core/io/encodings/utf16/tags.txt
@@ -0,0 +1 @@
+text
diff --git a/core/io/utf16/utf16-docs.factor b/core/io/encodings/utf16/utf16-docs.factor
similarity index 99%
rename from core/io/utf16/utf16-docs.factor
rename to core/io/encodings/utf16/utf16-docs.factor
index 6d24f54694..c49c030ef3 100644
--- a/core/io/utf16/utf16-docs.factor
+++ b/core/io/encodings/utf16/utf16-docs.factor
@@ -1,5 +1,5 @@
USING: help.markup help.syntax io.encodings strings ;
-IN: io.utf16
+IN: io.encodings.utf16
ARTICLE: "io.utf16" "Working with UTF16-encoded data"
"The UTF16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences."
diff --git a/core/io/utf16/utf16-tests.factor b/core/io/encodings/utf16/utf16-tests.factor
similarity index 50%
rename from core/io/utf16/utf16-tests.factor
rename to core/io/encodings/utf16/utf16-tests.factor
index 9800a9827d..d1817db1e8 100755
--- a/core/io/utf16/utf16-tests.factor
+++ b/core/io/encodings/utf16/utf16-tests.factor
@@ -1,15 +1,15 @@
-USING: tools.test io.utf16 arrays unicode.syntax ;
+USING: tools.test io.utf16 arrays unicode ;
[ { CHAR: x } ] [ { 0 CHAR: x } decode-utf16be >array ] unit-test
[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } decode-utf16be >array ] unit-test
-[ { UNICHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } decode-utf16be >array ] unit-test
-[ { UNICHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be >array ] unit-test
+[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } decode-utf16be >array ] unit-test
+[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be >array ] unit-test
[ B{ 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } encode-utf16be ] unit-test
[ { CHAR: x } ] [ { CHAR: x 0 } decode-utf16le >array ] unit-test
[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } decode-utf16le >array ] unit-test
-[ { UNICHAR: replacement-character } ] [ { 0 BIN: 11011111 } decode-utf16le >array ] unit-test
-[ { UNICHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } decode-utf16le >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } decode-utf16le >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } decode-utf16le >array ] unit-test
[ B{ 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } encode-utf16le ] unit-test
diff --git a/core/io/utf16/utf16.factor b/core/io/encodings/utf16/utf16.factor
similarity index 79%
rename from core/io/utf16/utf16.factor
rename to core/io/encodings/utf16/utf16.factor
index 19ebc1d43a..84017324ee 100755
--- a/core/io/utf16/utf16.factor
+++ b/core/io/encodings/utf16/utf16.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces io.binary
io.encodings combinators splitting ;
-IN: io.utf16
+IN: io.encodings.utf16
SYMBOL: double
SYMBOL: quad1
@@ -30,7 +30,7 @@ SYMBOL: ignore
>r 2 shift r> BIN: 11 bitand bitor quad3
] [ 2drop do-ignore ] if ;
-: (decode-utf16be) ( buf byte ch state -- buf ch state )
+: decode-utf16be-step ( buf byte ch state -- buf ch state )
{
{ begin [ drop begin-utf16be ] }
{ double [ end-multibyte ] }
@@ -41,7 +41,7 @@ SYMBOL: ignore
} case ;
: decode-utf16be ( seq -- str )
- [ -rot (decode-utf16be) ] decode ;
+ [ decode-utf16be-step ] decode ;
: handle-double ( buf byte ch -- buf ch state )
swap dup -3 shift BIN: 11011 = [
@@ -55,7 +55,7 @@ SYMBOL: ignore
BIN: 11 bitand append-nums HEX: 10000 + decoded
] [ 2drop push-replacement ] if ;
-: (decode-utf16le) ( buf byte ch state -- buf ch state )
+: decode-utf16le-step ( buf byte ch state -- buf ch state )
{
{ begin [ drop double ] }
{ double [ handle-double ] }
@@ -65,7 +65,7 @@ SYMBOL: ignore
} case ;
: decode-utf16le ( seq -- str )
- [ -rot (decode-utf16le) ] decode ;
+ [ decode-utf16le-step ] decode ;
: encode-first
-10 shift
@@ -104,13 +104,23 @@ SYMBOL: ignore
: encode-utf16 ( str -- seq )
encode-utf16le bom-le swap append ;
-: utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
-
-: utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
-
: decode-utf16 ( seq -- str )
{
- { [ utf16le? ] [ decode-utf16le ] }
- { [ utf16be? ] [ decode-utf16be ] }
+ { [ bom-le ?head ] [ decode-utf16le ] }
+ { [ bom-be ?head ] [ decode-utf16be ] }
{ [ t ] [ decode-error ] }
} cond ;
+
+TUPLE: utf16le ;
+: <utf16le> utf16le construct-delegate ;
+INSTANCE: utf16le encoding-stream
+
+M: utf16le encode-string drop encode-utf16le ;
+M: utf16le decode-step drop decode-utf16le-step ;
+
+TUPLE: utf16be ;
+: <utf16be> utf16be construct-delegate ;
+INSTANCE: utf16be encoding-stream
+
+M: utf16be encode-string drop encode-utf16be ;
+M: utf16be decode-step drop decode-utf16be-step ;
diff --git a/core/io/encodings/utf8/authors.txt b/core/io/encodings/utf8/authors.txt
new file mode 100644
index 0000000000..f990dd0ed2
--- /dev/null
+++ b/core/io/encodings/utf8/authors.txt
@@ -0,0 +1 @@
+Daniel Ehrenberg
diff --git a/core/io/utf8/summary.txt b/core/io/encodings/utf8/summary.txt
similarity index 100%
rename from core/io/utf8/summary.txt
rename to core/io/encodings/utf8/summary.txt
diff --git a/core/io/encodings/utf8/tags.txt b/core/io/encodings/utf8/tags.txt
new file mode 100644
index 0000000000..8e27be7d61
--- /dev/null
+++ b/core/io/encodings/utf8/tags.txt
@@ -0,0 +1 @@
+text
diff --git a/core/io/utf8/utf8-docs.factor b/core/io/encodings/utf8/utf8-docs.factor
old mode 100644
new mode 100755
similarity index 86%
rename from core/io/utf8/utf8-docs.factor
rename to core/io/encodings/utf8/utf8-docs.factor
index 28310b5d77..6e1923824f
--- a/core/io/utf8/utf8-docs.factor
+++ b/core/io/encodings/utf8/utf8-docs.factor
@@ -1,12 +1,12 @@
USING: help.markup help.syntax io.encodings strings ;
-IN: io.utf8
+IN: io.encodings.utf8
-ARTICLE: "io.utf8" "Working with UTF8-encoded data"
+ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data"
"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences."
{ $subsection encode-utf8 }
{ $subsection decode-utf8 } ;
-ABOUT: "io.utf8"
+ABOUT: "io.encodings.utf8"
HELP: decode-utf8
{ $values { "seq" "a sequence of bytes" } { "str" string } }
diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor
new file mode 100644
index 0000000000..ea7a238551
--- /dev/null
+++ b/core/io/encodings/utf8/utf8-tests.factor
@@ -0,0 +1,23 @@
+USING: io.encodings.utf8 tools.test sbufs kernel io
+sequences strings arrays unicode ;
+
+: decode-utf8-w/stream ( array -- newarray )
+ >sbuf dup reverse-here <utf8> contents >array ;
+
+: encode-utf8-w/stream ( array -- newarray )
+ SBUF" " clone tuck <utf8> write >array ;
+
+[ { 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
+
+[ "x" ] [ "x" decode-utf8-w/stream >string ] unit-test
+
+[ { BIN: 11111000000 } ] [ { BIN: 11011111 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
+
+[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
+[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } encode-utf8 ] unit-test
diff --git a/core/io/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor
similarity index 77%
rename from core/io/utf8/utf8.factor
rename to core/io/encodings/utf8/utf8.factor
index 213afb6eae..f681b18142 100644
--- a/core/io/utf8/utf8.factor
+++ b/core/io/encodings/utf8/utf8.factor
@@ -1,8 +1,10 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel sequences sbufs vectors
-namespaces io.encodings combinators ;
-IN: io.utf8
+USING: math kernel sequences sbufs vectors growable io continuations
+namespaces io.encodings combinators strings io.streams.c ;
+IN: io.encodings.utf8
+
+! Decoding UTF-8
SYMBOL: double
SYMBOL: triple
@@ -31,7 +33,7 @@ SYMBOL: quad3
: end-multibyte ( buf byte ch -- buf ch state )
f append-nums [ decoded ] unless* ;
-: (decode-utf8) ( buf byte ch state -- buf ch state )
+: decode-utf8-step ( buf byte ch state -- buf ch state )
{
{ begin [ drop begin-utf8 ] }
{ double [ end-multibyte ] }
@@ -43,7 +45,9 @@ SYMBOL: quad3
} case ;
: decode-utf8 ( seq -- str )
- [ -rot (decode-utf8) ] decode ;
+ [ decode-utf8-step ] decode ;
+
+! Encoding UTF-8
: encoded ( char -- )
BIN: 111111 bitand BIN: 10000000 bitor , ;
@@ -70,3 +74,13 @@ SYMBOL: quad3
: encode-utf8 ( str -- seq )
[ [ char>utf8 ] each ] B{ } make ;
+
+! Interface for streams
+
+TUPLE: utf8 ;
+: <utf8> utf8 construct-delegate ;
+INSTANCE: utf8 encoding-stream
+
+M: utf8 encode-string drop encode-utf8 ;
+M: utf8 decode-step drop decode-utf8-step ;
+! In the future, this should detect and ignore a BOM at the beginning
diff --git a/core/io/utf8/utf8-tests.factor b/core/io/utf8/utf8-tests.factor
deleted file mode 100644
index 3576471586..0000000000
--- a/core/io/utf8/utf8-tests.factor
+++ /dev/null
@@ -1,16 +0,0 @@
-USING: io.utf8 tools.test strings arrays unicode.syntax ;
-
-[ { UNICHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8 >array ] unit-test
-
-[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8 >array ] unit-test
-
-[ "x" ] [ "x" decode-utf8 >string ] unit-test
-
-[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8 >array ] unit-test
-
-[ { UNICHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8 >array ] unit-test
-
-[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8 >array ] unit-test
-
-[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
-[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } encode-utf8 ] unit-test
diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor
index c64d1fd010..1703bea5d4 100755
--- a/core/optimizer/backend/backend.factor
+++ b/core/optimizer/backend/backend.factor
@@ -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 -- )
@@ -68,8 +67,6 @@ DEFER: optimize-nodes
] if
] when ;
-M: f set-node-successor 2drop ;
-
: optimize-nodes ( node -- newnode )
[
class-substitutions [ clone ] change
@@ -78,19 +75,9 @@ M: f set-node-successor 2drop ;
optimizer-changed get
] with-scope optimizer-changed set ;
-! Generic nodes
M: node optimize-node* drop t f ;
-: cleanup-inlining ( node -- newnode changed? )
- node-successor [ node-successor t ] [ t f ] if* ;
-
-! #return
-M: #return optimize-node* cleanup-inlining ;
-
-! #values
-M: #values optimize-node* cleanup-inlining ;
-
-! Some utilities for splicing in dataflow IR subtrees
+! Post-inlining cleanup
: follow ( key assoc -- value )
2dup at* [ swap follow nip ] [ 2drop ] if ;
@@ -103,277 +90,30 @@ M: #values optimize-node* cleanup-inlining ;
#! Not very efficient.
dupd union* update ;
-: post-inline ( #call/#merge #return/#values -- assoc )
- >r node-out-d r> node-in-d 2array unify-lengths flip
+: compute-value-substitutions ( #return/#values #call/#merge -- assoc )
+ node-out-d swap node-in-d 2array unify-lengths flip
[ = not ] assoc-subset >hashtable ;
-: substitute-def-use ( node -- )
- #! As a first approximation, we take all the values used
- #! by the set of new nodes, and push a 't' on their
- #! def-use list here. We could perform a full graph
- #! substitution, but we don't need to, because the next
- #! optimizer iteration will do that. We just need a minimal
- #! degree of accuracy; the new values should be marked as
- #! having _some_ usage, so that flushing doesn't erronously
- #! flush them away.
- [ compute-def-use def-use get keys ] with-scope
- def-use get [ [ t swap ?push ] change-at ] curry each ;
+: cleanup-inlining ( #return/#values -- newnode changed? )
+ dup node-successor dup [
+ class-substitutions get pick node-classes update
+ literal-substitutions get pick node-literals update
+ tuck compute-value-substitutions value-substitutions get swap update*
+ node-successor t
+ ] [
+ 2drop t f
+ ] if ;
-: substitute-node ( old new -- )
- #! The last node of 'new' becomes 'old', then values are
- #! substituted. A subsequent optimizer phase kills the
- #! last node of 'new' and the first node of 'old'.
- dup substitute-def-use
- last-node
- class-substitutions get over node-classes update
- literal-substitutions get over node-literals update
- 2dup post-inline value-substitutions get swap update*
- set-node-successor ;
+! #return
+M: #return optimize-node* cleanup-inlining ;
-GENERIC: remember-method* ( method-spec node -- )
+! #values
+M: #values optimize-node* cleanup-inlining ;
-M: #call remember-method*
- [ node-history ?push ] keep set-node-history ;
+M: f set-node-successor 2drop ;
-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
- [ substitute-node ] keep ;
-
-: splice-quot ( #call quot -- node )
- over node-in-d dataflow-with
- [ swap infer-classes/node ] 2keep
- [ substitute-node ] keep ;
+: splice-node ( old new -- )
+ dup splice-def-use last-node set-node-successor ;
: 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 substitute-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 ;
-
-M: #if optimize-node*
- dup dup node-in-d first known-boolean-value? [
- over drop-inputs >r
- 0 1 ? fold-branch
- r> [ set-node-successor ] keep
- t
- ] [ 2drop t f ] if ;
-
-M: #dispatch optimize-node*
- dup dup node-in-d first 2dup node-literal? [
- "Optimizing #dispatch" print
- node-literal
- over drop-inputs >r fold-branch r> [ set-node-successor ] keep t
- ] [
- 3drop 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 ;
-
-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 ] }
- { [ t ] [ inline-method ] }
- } cond dup not ;
diff --git a/core/optimizer/control/control-tests.factor b/core/optimizer/control/control-tests.factor
new file mode 100755
index 0000000000..b5b52e0e0e
--- /dev/null
+++ b/core/optimizer/control/control-tests.factor
@@ -0,0 +1,181 @@
+IN: temporary
+USING: tools.test optimizer.control combinators kernel
+sequences inference.dataflow math inference classes strings
+optimizer ;
+
+: label-is-loop? ( node word -- ? )
+ [
+ {
+ { [ over #label? not ] [ 2drop f ] }
+ { [ over #label-word over eq? not ] [ 2drop f ] }
+ { [ over #label-loop? not ] [ 2drop f ] }
+ { [ t ] [ 2drop t ] }
+ } cond
+ ] curry node-exists? ;
+
+: label-is-not-loop? ( node word -- ? )
+ [
+ {
+ { [ over #label? not ] [ 2drop f ] }
+ { [ over #label-word over eq? not ] [ 2drop f ] }
+ { [ over #label-loop? ] [ 2drop f ] }
+ { [ t ] [ 2drop t ] }
+ } cond
+ ] curry node-exists? ;
+
+: loop-test-1 ( a -- )
+ dup [ 1+ loop-test-1 ] [ drop ] if ; inline
+
+[ t ] [
+ [ loop-test-1 ] dataflow dup detect-loops
+ \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+ [ loop-test-1 1 2 3 ] dataflow dup detect-loops
+ \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+ [ [ loop-test-1 ] each ] dataflow dup detect-loops
+ \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+ [ [ loop-test-1 ] each ] dataflow dup detect-loops
+ \ (each-integer) label-is-loop?
+] unit-test
+
+: loop-test-2 ( a -- )
+ dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline
+
+[ t ] [
+ [ loop-test-2 ] dataflow dup detect-loops
+ \ loop-test-2 label-is-not-loop?
+] unit-test
+
+: loop-test-3 ( a -- )
+ dup [ [ loop-test-3 ] each ] [ drop ] if ; inline
+
+[ t ] [
+ [ 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
diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor
new file mode 100755
index 0000000000..b04d4677ce
--- /dev/null
+++ b/core/optimizer/control/control.factor
@@ -0,0 +1,336 @@
+! 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 ;
+IN: optimizer.control
+
+! ! ! Rudimentary CFA
+
+! 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
+! |
+! ...
+
+! 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
+
+GENERIC: collect-label-info* ( node -- )
+
+M: #label collect-label-info*
+ [ V{ } clone node-stack get length 3array ] keep
+ node-param label-info get set-at ;
+
+USE: prettyprint
+
+M: #call-label collect-label-info*
+ node-param label-info get at
+ node-stack get over third tail
+ [ [ #label? ] subset [ node-param ] map ] keep
+ [ node-successor #tail? ] all? 2array
+ swap second push ;
+
+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 ;
diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor
index 9355b2bb70..df5c1e0aa4 100755
--- a/core/optimizer/def-use/def-use.factor
+++ b/core/optimizer/def-use/def-use.factor
@@ -70,20 +70,6 @@ M: #branch node-def-use
#! #values node.
dup branch-def-use (node-def-use) ;
-! : dead-literals ( -- values )
-! def-use get [ >r value? r> empty? and ] assoc-subset ;
-!
-! : kill-node* ( node values -- )
-! [ swap remove-all ] curry modify-values ;
-!
-! : kill-node ( node values -- )
-! dup assoc-empty?
-! [ 2drop ] [ [ kill-node* ] curry each-node ] if ;
-!
-! : kill-values ( node -- )
-! #! Remove literals which are not actually used anywhere.
-! dead-literals kill-node ;
-
: compute-dead-literals ( -- values )
def-use get [ >r value? r> empty? and ] assoc-subset ;
@@ -129,8 +115,18 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
dead-literals [ kill-nodes ] with-variable
] if ;
-!
-
: sole-consumer ( #call -- node/f )
node-out-d first used-by
dup length 1 = [ first ] [ drop f ] if ;
+
+: splice-def-use ( node -- )
+ #! As a first approximation, we take all the values used
+ #! by the set of new nodes, and push a 't' on their
+ #! def-use list here. We could perform a full graph
+ #! substitution, but we don't need to, because the next
+ #! optimizer iteration will do that. We just need a minimal
+ #! degree of accuracy; the new values should be marked as
+ #! having _some_ usage, so that flushing doesn't erronously
+ #! flush them away.
+ [ compute-def-use def-use get keys ] with-scope
+ def-use get [ [ t swap ?push ] change-at ] curry each ;
diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor
new file mode 100755
index 0000000000..a272d05b5d
--- /dev/null
+++ b/core/optimizer/inlining/inlining.factor
@@ -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 ;
diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor
index 8534f1f090..d725396e77 100755
--- a/core/optimizer/known-words/known-words.factor
+++ b/core/optimizer/known-words/known-words.factor
@@ -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
diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor
index e048e29f48..9bd1fe3250 100755
--- a/core/optimizer/math/math.factor
+++ b/core/optimizer/math/math.factor
@@ -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 ] }
diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor
index 8f30abd09f..7092797acc 100755
--- a/core/optimizer/optimizer-tests.factor
+++ b/core/optimizer/optimizer-tests.factor
@@ -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
diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor
index 1debf6c8cc..9e898450cc 100755
--- a/core/optimizer/optimizer.factor
+++ b/core/optimizer/optimizer.factor
@@ -1,7 +1,8 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces optimizer.backend optimizer.def-use
-optimizer.known-words optimizer.math inference.class ;
+optimizer.known-words optimizer.math optimizer.control
+optimizer.inlining inference.class ;
IN: optimizer
: optimize-1 ( node -- newnode ? )
@@ -11,6 +12,7 @@ IN: optimizer
H{ } clone value-substitutions set
dup compute-def-use
kill-values
+ dup detect-loops
dup infer-classes
optimizer-changed off
optimize-nodes
diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor
index a4f5aaab95..10a9fda3ea 100755
--- a/core/optimizer/specializers/specializers.factor
+++ b/core/optimizer/specializers/specializers.factor
@@ -24,7 +24,7 @@ IN: optimizer.specializers
\ dispatch ,
] [ ] make ;
-: specializer-methods ( word -- alist )
+: specializer-methods ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
[ declare ] curry pick append
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index ae38925c68..ce6a119e32 100755
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -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?
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 1bd7979a0c..c84c836390 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -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 ;
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 967fcbbdc8..ee38d30750 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -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>
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index 9ccfd2efcd..95a00f3801 100755
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -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...\"" }
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 67799b92ea..601c05d8d9 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -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\"" [
diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor
old mode 100644
new mode 100755
index 181979bfed..ece90d9a11
--- a/core/threads/threads-docs.factor
+++ b/core/threads/threads-docs.factor
@@ -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 } } }
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index 5e8a5630b2..a05cd2fa8c 100755
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -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>
diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor
index 62848e46b2..91b5295427 100755
--- a/core/words/words-docs.factor
+++ b/core/words/words-docs.factor
@@ -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
diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor
old mode 100644
new mode 100755
index 46ff9a1ada..d453ee60ca
--- a/extra/benchmark/benchmark.factor
+++ b/extra/benchmark/benchmark.factor
@@ -8,7 +8,7 @@ IN: benchmark
: run-benchmark ( vocab -- result )
"=== Benchmark " write dup print flush
dup require
- [ [ run ] benchmark ] [ error. f f ] recover 2array
+ [ [ run ] benchmark ] [ error. drop f f ] recover 2array
dup . ;
: run-benchmarks ( -- assoc )
diff --git a/extra/benchmark/bootstrap2/bootstrap2.factor b/extra/benchmark/bootstrap2/bootstrap2.factor
deleted file mode 100755
index f57e92e5e0..0000000000
--- a/extra/benchmark/bootstrap2/bootstrap2.factor
+++ /dev/null
@@ -1,14 +0,0 @@
-USING: io.files io.launcher system bootstrap.image
-namespaces sequences kernel ;
-IN: benchmark.bootstrap2
-
-: bootstrap-benchmark
- "." resource-path cd
- [
- vm ,
- "-i=" my-boot-image-name append ,
- "-output-image=foo.image" ,
- "-no-user-init" ,
- ] { } make try-process ;
-
-MAIN: bootstrap-benchmark
diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor
index e8efc11c32..f19a2127a5 100755
--- a/extra/benchmark/sockets/sockets.factor
+++ b/extra/benchmark/sockets/sockets.factor
@@ -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
diff --git a/extra/bootstrap/handbook/handbook.factor b/extra/bootstrap/handbook/handbook.factor
new file mode 100755
index 0000000000..2ffb77de7a
--- /dev/null
+++ b/extra/bootstrap/handbook/handbook.factor
@@ -0,0 +1,3 @@
+USING: vocabs.loader vocabs kernel ;
+
+"bootstrap.help" vocab [ "help.handbook" require ] when
diff --git a/extra/bootstrap/help/help.factor b/extra/bootstrap/help/help.factor
index ade60d4457..1680278fad 100755
--- a/extra/bootstrap/help/help.factor
+++ b/extra/bootstrap/help/help.factor
@@ -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
diff --git a/extra/bootstrap/tools/tools.factor b/extra/bootstrap/tools/tools.factor
index 7b909ea1f6..40d77e03be 100755
--- a/extra/bootstrap/tools/tools.factor
+++ b/extra/bootstrap/tools/tools.factor
@@ -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
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index a5411e6129..cd17a32255 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -3,71 +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 ;
+ 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
+
+: 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 ;
@@ -80,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+ }
- }
- >hashtable ;
+ <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
@@ -142,7 +116,7 @@ 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
@@ -152,20 +126,50 @@ SYMBOL: build-status
"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
- ] with-file-out ;
+ "Benchmarks: " print
+ "../benchmarks" [ stdio get contents eval ] with-file-in benchmarks.
-: build ( -- )
- [ (build) ] [ drop ] recover
- "report" "../report" email-file ;
+ ] with-file-out
+
+ build-status on ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: minutes>ms ( min -- ms ) 60 * 1000 * ;
+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
+ [ 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
@@ -174,8 +178,9 @@ SYMBOL: build-status
= not ;
: build-loop ( -- )
+ builds-check
[
- "/builds/factor" cd
+ builds "/factor" append cd
updates-available?
[ build ]
when
diff --git a/extra/builder/server/server.factor b/extra/builder/server/server.factor
index 672de1e47d..f3ec349557 100644
--- a/extra/builder/server/server.factor
+++ b/extra/builder/server/server.factor
@@ -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 ;
diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor
index f521af1b7c..7412dd9b36 100644
--- a/extra/builder/test/test.factor
+++ b/extra/builder/test/test.factor
@@ -6,7 +6,7 @@ USING: kernel namespaces sequences assocs builder continuations
prettyprint
tools.browser
tools.test
- bootstrap.stage2 ;
+ bootstrap.stage2 benchmark builder.util ;
IN: builder.test
@@ -16,9 +16,12 @@ IN: builder.test
: do-tests ( -- )
run-all-tests keys "../test-all-vocabs" [ . ] with-file-out ;
+: do-benchmarks ( -- ) run-benchmarks "../benchmarks" [ . ] with-file-out ;
+
: do-all ( -- )
bootstrap-time get "../boot-time" [ . ] with-file-out
[ do-load ] runtime "../load-time" [ . ] with-file-out
- [ do-tests ] runtime "../test-time" [ . ] with-file-out ;
+ [ do-tests ] runtime "../test-time" [ . ] with-file-out
+ do-benchmarks ;
MAIN: do-all
\ No newline at end of file
diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor
new file mode 100644
index 0000000000..f9f432a8f6
--- /dev/null
+++ b/extra/builder/util/util.factor
@@ -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 ;
\ No newline at end of file
diff --git a/extra/const/const.factor b/extra/const/const.factor
deleted file mode 100644
index 8efef7e372..0000000000
--- a/extra/const/const.factor
+++ /dev/null
@@ -1,24 +0,0 @@
-USING: kernel parser words sequences ;
-IN: const
-
-: define-const ( word value -- )
- [ parsed ] curry dupd define
- t "parsing" set-word-prop ;
-
-: CONST:
- CREATE scan-word dup parsing?
- [ execute dup pop ] when define-const ; parsing
-
-: define-enum ( words -- )
- dup length [ define-const ] 2each ;
-
-: ENUM:
- ";" parse-tokens [ create-in ] map define-enum ; parsing
-
-: define-value ( word -- )
- { f } clone [ first ] curry define ;
-
-: VALUE: CREATE define-value ; parsing
-
-: set-value ( value word -- )
- word-def first set-first ;
diff --git a/extra/db/db.factor b/extra/db/db.factor
index 7bdb75af22..d88bbaee03 100755
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -1,32 +1,29 @@
! 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 ;
+TUPLE: db handle insert-statements update-statements delete-statements ;
: <db> ( handle -- obj )
- H{ } clone
- H{ } clone
- H{ } clone
- H{ } clone
+ H{ } clone H{ } clone H{ } clone
db construct-boa ;
GENERIC: db-open ( db -- )
HOOK: db-close db ( handle -- )
-: dispose-statements [ dispose drop ] assoc-each ;
+: dispose-statements ( seq -- )
+ [ dispose drop ] assoc-each ;
: dispose-db ( db -- )
dup db [
dup db-insert-statements dispose-statements
dup db-update-statements dispose-statements
dup db-delete-statements dispose-statements
- dup db-select-statements dispose-statements
db-handle db-close
] with-variable ;
-TUPLE: statement sql params handle bound? ;
+TUPLE: statement sql params handle bound? slot-names ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
@@ -35,7 +32,17 @@ HOOK: <prepared-statement> db ( str -- statement )
GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( obj statement -- )
GENERIC: reset-statement ( statement -- )
-GENERIC: execute-statement ( statement -- )
+GENERIC: insert-statement ( statement -- id )
+
+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
@@ -43,19 +50,9 @@ GENERIC: execute-statement ( statement -- )
[ 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 -- ? )
-
-HOOK: last-id db ( -- id )
-
: 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>
@@ -69,10 +66,10 @@ HOOK: last-id db ( -- id )
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 )
@@ -93,11 +90,6 @@ HOOK: last-id db ( -- id )
: 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 ( -- )
@@ -111,3 +103,15 @@ 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 ;
diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor
index 1ec6fc46f8..d14ec13ff8 100755
--- a/extra/db/postgresql/ffi/ffi.factor
+++ b/extra/db/postgresql/ffi/ffi.factor
@@ -50,6 +50,8 @@ IN: db.postgresql.ffi
: PQERRORS_DEFAULT HEX: 1 ; inline
: PQERRORS_VERBOSE HEX: 2 ; inline
+: InvalidOid 0 ; inline
+
TYPEDEF: int size_t
TYPEDEF: int ConnStatusType
TYPEDEF: int ExecStatusType
diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor
index a940a42ae4..c48eff964a 100644
--- a/extra/db/postgresql/lib/lib.factor
+++ b/extra/db/postgresql/lib/lib.factor
@@ -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,7 +38,8 @@ IN: db.postgresql.lib
>r db get db-handle r>
[ statement-sql ] keep
[ statement-params length f ] keep
- statement-params [ 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
diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor
index 8c6791c767..36b6fc829b 100644
--- a/extra/db/postgresql/postgresql-tests.factor
+++ b/extra/db/postgresql/postgresql-tests.factor
@@ -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
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index 92e3fa5489..03746bcaa0 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -1,8 +1,10 @@
! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs alien alien.syntax continuations io
-kernel math namespaces prettyprint quotations
-sequences debugger db db.postgresql.lib db.postgresql.ffi ;
+kernel math math.parser namespaces prettyprint quotations
+sequences debugger db db.postgresql.lib db.postgresql.ffi
+db.tuples db.types tools.annotations math.ranges
+combinators ;
IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
@@ -51,11 +53,19 @@ 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 -- )
- query-results dispose ;
+M: postgresql-result-set row-column-typed ( result-set n type -- obj )
+ >r row-column r> sql-type>factor-type ;
-: increment-n ( result-set -- n )
- dup result-set-n 1+ dup rot set-result-set-n ;
+M: postgresql-result-set sql-type>factor-type ( obj type -- newobj )
+ {
+ { INTEGER [ string>number ] }
+ { BIG_INTEGER [ string>number ] }
+ { DOUBLE [ string>number ] }
+ [ drop ]
+ } case ;
+
+M: postgresql-statement insert-statement ( statement -- id )
+ query-results [ 0 row-column ] with-disposal string>number ;
M: postgresql-statement query-results ( query -- result-set )
dup statement-params [
@@ -67,8 +77,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
@@ -103,3 +116,154 @@ M: postgresql-db commit-transaction ( -- )
M: postgresql-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
+
+: postgresql-type-hash* ( -- assoc )
+ H{
+ { SERIAL "serial" }
+ } ;
+
+: 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 )
+ [
+ >r remove-id r>
+ "create function add_" % dup %
+ "(" %
+ over [ "," % ]
+ [ third dup array? [ first ] when >sql-type % ] interleave
+ ")" %
+ " returns bigint as '" %
+
+ 2dup "insert into " %
+ %
+ "(" %
+ dup [ ", " % ] [ second % ] interleave
+ ") " %
+ " values (" %
+ 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 -- slot-names sql )
+ [
+ "select add_" % %
+ "(" %
+ length [1,b] [ ", " % ] [ "$" % # ] interleave
+ ")" %
+ ] "" make ;
+
+M: postgresql-db update-sql* ( columns table -- slot-names sql )
+ [
+ "update " %
+ %
+ " set " %
+ dup remove-id
+ dup length [1,b] swap 2array flip
+ [ ", " % ] [ first2 second % " = $" % # ] interleave
+ " where " %
+ [ primary-key? ] find nip second dup % " = $" % length 2 + #
+ ] "" make ;
+
+M: postgresql-db delete-sql* ( columns table -- slot-names sql )
+ [
+ "delete from " %
+ %
+ " where " %
+ first second % " = $1" %
+ ] "" make ;
+
+M: postgresql-db select-sql ( columns table -- slot-names sql )
+ drop ;
+
+M: postgresql-db tuple>params ( columns tuple -- obj )
+ [ >r dup third swap first r> get-slot-named swap ]
+ curry { } map>assoc ;
+
+: postgresql-db-modifiers ( -- hashtable )
+ H{
+ { +native-id+ "not null primary key" }
+ { +assigned-id+ "primary key" }
+ { +autoincrement+ "autoincrement" }
+ { +unique+ "unique" }
+ { +default+ "default" }
+ { +null+ "null" }
+ { +not-null+ "not null" }
+ } ;
+
+M: postgresql-db sql-modifiers* ( modifiers -- str )
+ postgresql-db-modifiers swap [
+ dup array? [
+ first2
+ >r swap at r> number>string*
+ " " swap 3append
+ ] [
+ swap at
+ ] if
+ ] with map [ ] subset ;
diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor
index 9ffe797248..8c957108e1 100755
--- a/extra/db/sqlite/ffi/ffi.factor
+++ b/extra/db/sqlite/ffi/ffi.factor
@@ -108,7 +108,7 @@ LIBRARY: sqlite
FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ;
-FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
+FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
@@ -125,6 +125,8 @@ FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;
diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor
index 1780cc4a2d..85aa671d4d 100755
--- a/extra/db/sqlite/lib/lib.factor
+++ b/extra/db/sqlite/lib/lib.factor
@@ -30,7 +30,7 @@ IN: db.sqlite.lib
: sqlite-prepare ( db sql -- handle )
dup length "void*" <c-object> "void*" <c-object>
- [ sqlite3_prepare_v2 sqlite-check-result ] 2keep
+ [ sqlite3_prepare sqlite-check-result ] 2keep
drop *void* ;
: sqlite-bind-parameter-index ( handle name -- index )
@@ -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 ;
@@ -95,17 +96,25 @@ IN: db.sqlite.lib
: sqlite-column ( handle index -- string )
sqlite3_column_text ;
+: sqlite-column-typed ( handle index type -- obj )
+ {
+ { INTEGER [ sqlite3_column_int ] }
+ { BIG_INTEGER [ sqlite3_column_int64 ] }
+ { TEXT [ sqlite3_column_text ] }
+ { DOUBLE [ sqlite3_column_double ] }
+ } case ;
+
! TODO
: 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? ;
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index ad3a43bae3..4eabfc2ecd 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -25,9 +25,7 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
TUPLE: sqlite-statement ;
C: <sqlite-statement> sqlite-statement
-TUPLE: sqlite-result-set ;
-: <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> ;
@@ -52,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 -- )
- statement-handle sqlite-next drop ;
+: 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 ;
@@ -61,11 +63,19 @@ 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 ? )
- result-set-handle sqlite-next ;
+M: sqlite-result-set row-column-typed ( result-set n type -- obj )
+ >r result-set-handle r> sqlite-column-typed ;
+
+M: sqlite-result-set advance-row ( result-set -- )
+ [ result-set-handle sqlite-next ] keep
+ 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 ;
@@ -86,9 +96,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 )
@@ -103,6 +114,10 @@ M: sqlite-db insert-sql* ( columns table -- sql )
")" %
] "" make ;
+: where-primary-key% ( columns -- )
+ " where " %
+ [ primary-key? ] find nip second dup % " = :" % % ;
+
M: sqlite-db update-sql* ( columns table -- sql )
[
"update " %
@@ -110,8 +125,7 @@ M: sqlite-db update-sql* ( columns table -- sql )
" set " %
dup remove-id
[ ", " % ] [ second dup % " = :" % % ] interleave
- " where " %
- [ primary-key? ] find nip second dup % " = :" % %
+ where-primary-key%
] "" make ;
M: sqlite-db delete-sql* ( columns table -- sql )
@@ -122,13 +136,18 @@ M: sqlite-db delete-sql* ( columns table -- sql )
first second dup % " = :" % %
] "" make ;
-M: sqlite-db select-sql* ( columns table -- sql )
+: select-interval ( interval name -- )
+ ;
+
+: select-sequence ( seq name -- )
+ ;
+
+M: sqlite-db select-sql ( columns table -- sql )
[
"select ROWID, " %
- swap [ ", " % ] [ second % ] interleave
- " from " %
- %
- " where ROWID = :ID" %
+ over [ ", " % ] [ second % ] interleave
+ " from " % %
+ " where " %
] "" make ;
M: sqlite-db tuple>params ( columns tuple -- obj )
@@ -137,10 +156,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 ( -- id )
- db get db-handle sqlite3_last_insert_rowid ;
-
: sqlite-db-modifiers ( -- hashtable )
H{
@@ -167,6 +182,7 @@ M: sqlite-db sql-modifiers* ( modifiers -- str )
: sqlite-type-hash ( -- assoc )
H{
{ INTEGER "integer" }
+ { SERIAL "integer" }
{ TEXT "text" }
{ VARCHAR "text" }
{ DOUBLE "real" }
@@ -182,4 +198,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 ;
-
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 474593ae3f..ea57193750 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -1,11 +1,12 @@
! 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.types continuations namespaces db.postgresql math ;
+! tools.time ;
IN: temporary
TUPLE: person the-id the-name the-number real ;
-: <person> ( name age -- person )
+: <person> ( name age real -- person )
{
set-person-the-name
set-person-the-number
@@ -29,21 +30,22 @@ SYMBOL: the-person
[ ] [ the-person get update-tuple ] unit-test
- [ ] [ the-person get delete-tuple ] unit-test ;
+ [ ] [ the-person get delete-tuple ] unit-test
+ ; ! 1 [ ] [ person drop-table ] unit-test ;
: test-sqlite ( -- )
"tuples-test.db" resource-path <sqlite-db> [
test-tuples
] with-db ;
-! : test-postgres ( -- )
- ! resource-path <postgresql-db> [
- ! test-tuples
- ! ] with-db ;
+: test-postgresql ( -- )
+ "localhost" "postgres" "" "factor-test" <postgresql-db> [
+ test-tuples
+ ] with-db ;
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 } }
@@ -51,18 +53,18 @@ person "PERSON"
"billy" 10 3.14 <person> the-person set
-test-sqlite
-! test-postgres
+! test-sqlite
+ test-postgresql
-person "PERSON"
-{
- { "the-id" "ROWID" INTEGER +assigned-id+ }
- { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
- { "the-number" "AGE" INTEGER { +default+ 0 } }
- { "real" "REAL" DOUBLE { +default+ 0.3 } }
-} define-persistent
+! person "PERSON"
+! {
+ ! { "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 } }
+! } define-persistent
-1 "billy" 20 6.28 <assigned-person> the-person set
+! 1 "billy" 20 6.28 <assigned-person> the-person set
-test-sqlite
-! test-postgres
+! test-sqlite
+! test-postgresql
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index 099326e4c1..be18f71e1b 100755
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -38,12 +38,28 @@ 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: insert-sql* db ( columns table -- sql )
-HOOK: update-sql* db ( columns table -- sql )
-HOOK: delete-sql* db ( columns table -- sql )
-HOOK: select-sql* db ( columns table -- sql )
+HOOK: create-sql db ( columns table -- seq )
+HOOK: drop-sql db ( columns table -- seq )
+
+HOOK: insert-sql* db ( columns table -- slot-names sql )
+HOOK: update-sql* db ( columns table -- slot-names sql )
+HOOK: delete-sql* db ( columns table -- slot-names sql )
+HOOK: select-sql db ( tuple -- statement )
+
+HOOK: row-column-typed db ( result-set n type -- sql )
+HOOK: sql-type>factor-type db ( obj type -- obj )
+HOOK: tuple>params db ( columns tuple -- obj )
+
+
+HOOK: make-slot-names* db ( quot -- seq )
+HOOK: column-slot-name% db ( spec -- )
+HOOK: column-bind-name% db ( spec -- )
+
+: make-slots-names ( quot -- seq str )
+ [ make-column-names ] "" make ; inline
+: slot-name% ( seq -- ) first % ;
+: column-name% ( seq -- ) second % ;
+: column-type% ( seq -- ) third % ;
: insert-sql ( columns class -- statement )
db get db-insert-statements [ insert-sql* ] cache-statement ;
@@ -54,30 +70,29 @@ HOOK: select-sql* db ( columns table -- sql )
: delete-sql ( columns class -- statement )
db get db-delete-statements [ delete-sql* ] cache-statement ;
-: select-sql ( columns class -- statement )
- db get db-select-statements [ select-sql* ] cache-statement ;
-
-HOOK: tuple>params db ( columns tuple -- obj )
: tuple-statement ( columns tuple quot -- statement )
>r [ tuple>params ] 2keep class r> call
2dup . .
[ bind-statement ] keep ;
-: do-tuple-statement ( tuple columns-quot statement-quot -- )
+: make-tuple-statement ( tuple columns-quot statement-quot -- statement )
>r [ class db-columns ] swap compose keep
- r> tuple-statement execute-statement ;
+ r> tuple-statement ;
+
+: do-tuple-statement ( tuple columns-quot statement-quot -- )
+ make-tuple-statement execute-statement ;
: create-table ( class -- )
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 ] do-tuple-statement
- last-id
+ [ maybe-remove-id ] [ insert-sql ]
+ make-tuple-statement insert-statement
] keep set-primary-key ;
: update-tuple ( tuple -- )
@@ -86,8 +101,8 @@ HOOK: tuple>params db ( columns tuple -- obj )
: delete-tuple ( tuple -- )
[ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ;
-! : select-tuple ( tuple -- )
- ! [ select-sql ] bind-tuple do-query ;
+: select-tuple ( tuple -- )
+ [ select-sql ] keep do-query ;
: persist ( tuple -- )
dup primary-key [ update-tuple ] [ insert-tuple ] if ;
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index b8c82524a8..7cacbcf861 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -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
diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor
index 37f3812d2d..f9b4c8648d 100755
--- a/extra/delegate/protocols/protocols.factor
+++ b/extra/delegate/protocols/protocols.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: delegate sequences.private sequences assocs prettyprint.sections
-io definitions kernel ;
+io definitions kernel continuations ;
IN: delegate.protocols
PROTOCOL: sequence-protocol
@@ -15,7 +15,7 @@ PROTOCOL: assoc-protocol
! everything should work, just slower (with >alist)
PROTOCOL: stream-protocol
- stream-read1 stream-read stream-read-until
+ stream-read1 stream-read stream-read-until dispose
stream-flush stream-write1 stream-write stream-format
stream-nl make-span-stream make-block-stream stream-readln
make-cell-stream stream-write-table ;
diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index 9472e1f519..90e780c1ad 100755
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -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
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 755f36a538..5c4dae94c7 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -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
diff --git a/extra/icfp/2006/2006.factor b/extra/icfp/2006/2006.factor
index 2a35ed08f8..ae0e058490 100755
--- a/extra/icfp/2006/2006.factor
+++ b/extra/icfp/2006/2006.factor
@@ -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 ;
diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor
index 4f5a85244b..3a557e9fd5 100755
--- a/extra/io/launcher/launcher-docs.factor
+++ b/extra/io/launcher/launcher-docs.factor
@@ -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 }
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index cbece818c9..dce893dcaf 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -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 ;
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index c0861788b6..5adf0d7453 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -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>
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index f3f78fbb88..cc3278dadc 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -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
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index ecc989530e..f2be11855b 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -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 ;
diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor
index c2f14c21bb..cd9bb9baef 100755
--- a/extra/io/windows/nt/launcher/launcher.factor
+++ b/extra/io/windows/nt/launcher/launcher.factor
@@ -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
diff --git a/extra/benchmark/bootstrap2/authors.txt b/extra/io/windows/nt/pipes/authors.txt
similarity index 100%
rename from extra/benchmark/bootstrap2/authors.txt
rename to extra/io/windows/nt/pipes/authors.txt
diff --git a/extra/io/windows/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor
similarity index 74%
rename from extra/io/windows/pipes/pipes.factor
rename to extra/io/windows/nt/pipes/pipes.factor
index 8c2acc4009..9591063609 100755
--- a/extra/io/windows/pipes/pipes.factor
+++ b/extra/io/windows/nt/pipes/pipes.factor
@@ -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 ;
diff --git a/extra/io/windows/pipes/authors.txt b/extra/io/windows/pipes/authors.txt
deleted file mode 100755
index 1901f27a24..0000000000
--- a/extra/io/windows/pipes/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor
index 1979819dd1..e3e7b14917 100644
--- a/extra/lazy-lists/lazy-lists.factor
+++ b/extra/lazy-lists/lazy-lists.factor
@@ -9,13 +9,10 @@ quotations promises combinators io ;
IN: lazy-lists
! Lazy List Protocol
+MIXIN: list
GENERIC: car ( cons -- car )
GENERIC: cdr ( cons -- cdr )
GENERIC: nil? ( cons -- ? )
-GENERIC: list? ( object -- ? )
-
-M: object list? ( object -- bool )
- drop f ;
M: promise car ( promise -- car )
force car ;
@@ -26,9 +23,6 @@ M: promise cdr ( promise -- cdr )
M: promise nil? ( cons -- bool )
force nil? ;
-M: promise list? ( object -- bool )
- drop t ;
-
TUPLE: cons car cdr ;
C: cons cons
@@ -45,9 +39,6 @@ M: cons cdr ( cons -- cdr )
M: cons nil? ( cons -- bool )
nil eq? ;
-M: cons list? ( object -- bool )
- drop t ;
-
: 1list ( obj -- cons )
nil cons ;
@@ -74,9 +65,6 @@ M: lazy-cons cdr ( lazy-cons -- cdr )
M: lazy-cons nil? ( lazy-cons -- bool )
nil eq? ;
-M: lazy-cons list? ( object -- bool )
- drop t ;
-
: 1lazy-list ( a -- lazy-cons )
[ nil ] lazy-cons ;
@@ -138,9 +126,6 @@ M: memoized-cons nil? ( memoized-cons -- bool )
memoized-cons-nil?
] if ;
-M: memoized-cons list? ( object -- bool )
- drop t ;
-
TUPLE: lazy-map cons quot ;
C: <lazy-map> lazy-map
@@ -159,9 +144,6 @@ M: lazy-map cdr ( lazy-map -- cdr )
M: lazy-map nil? ( lazy-map -- bool )
lazy-map-cons nil? ;
-M: lazy-map list? ( object -- bool )
- drop t ;
-
TUPLE: lazy-map-with value cons quot ;
C: <lazy-map-with> lazy-map-with
@@ -182,9 +164,6 @@ M: lazy-map-with cdr ( lazy-map-with -- cdr )
M: lazy-map-with nil? ( lazy-map-with -- bool )
lazy-map-with-cons nil? ;
-M: lazy-map-with list? ( object -- bool )
- drop t ;
-
TUPLE: lazy-take n cons ;
C: <lazy-take> lazy-take
@@ -206,9 +185,6 @@ M: lazy-take nil? ( lazy-take -- bool )
lazy-take-cons nil?
] if ;
-M: lazy-take list? ( object -- bool )
- drop t ;
-
TUPLE: lazy-until cons quot ;
C: <lazy-until> lazy-until
@@ -226,9 +202,6 @@ M: lazy-until cdr ( lazy-until -- cdr )
M: lazy-until nil? ( lazy-until -- bool )
drop f ;
-M: lazy-until list? ( lazy-until -- bool )
- drop t ;
-
TUPLE: lazy-while cons quot ;
C: <lazy-while> lazy-while
@@ -245,9 +218,6 @@ M: lazy-while cdr ( lazy-while -- cdr )
M: lazy-while nil? ( lazy-while -- bool )
[ car ] keep lazy-while-quot call not ;
-M: lazy-while list? ( lazy-while -- bool )
- drop t ;
-
TUPLE: lazy-subset cons quot ;
C: <lazy-subset> lazy-subset
@@ -285,9 +255,6 @@ M: lazy-subset nil? ( lazy-subset -- bool )
] if
] if ;
-M: lazy-subset list? ( object -- bool )
- drop t ;
-
: list>vector ( list -- vector )
[ [ , ] leach ] V{ } make ;
@@ -311,9 +278,6 @@ M: lazy-append cdr ( lazy-append -- cdr )
M: lazy-append nil? ( lazy-append -- bool )
drop f ;
-M: lazy-append list? ( object -- bool )
- drop t ;
-
TUPLE: lazy-from-by n quot ;
C: lfrom-by lazy-from-by ( n quot -- list )
@@ -331,9 +295,6 @@ M: lazy-from-by cdr ( lazy-from-by -- cdr )
M: lazy-from-by nil? ( lazy-from-by -- bool )
drop f ;
-M: lazy-from-by list? ( object -- bool )
- drop t ;
-
TUPLE: lazy-zip list1 list2 ;
C: <lazy-zip> lazy-zip
@@ -351,9 +312,6 @@ M: lazy-zip cdr ( lazy-zip -- cdr )
M: lazy-zip nil? ( lazy-zip -- bool )
drop f ;
-M: lazy-zip list? ( object -- bool )
- drop t ;
-
TUPLE: sequence-cons index seq ;
C: <sequence-cons> sequence-cons
@@ -376,9 +334,6 @@ M: sequence-cons cdr ( sequence-cons -- cdr )
M: sequence-cons nil? ( sequence-cons -- bool )
drop f ;
-M: sequence-cons list? ( object -- bool )
- drop t ;
-
: >list ( object -- list )
{
{ [ dup sequence? ] [ 0 swap seq>list ] }
@@ -419,9 +374,6 @@ M: lazy-concat nil? ( lazy-concat -- bool )
drop f
] if ;
-M: lazy-concat list? ( object -- bool )
- drop t ;
-
: lcartesian-product ( list1 list2 -- result )
swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ;
@@ -492,3 +444,20 @@ M: lazy-io cdr ( lazy-io -- cdr )
M: lazy-io nil? ( lazy-io -- bool )
car not ;
+
+INSTANCE: cons list
+INSTANCE: sequence-cons list
+INSTANCE: memoized-cons list
+INSTANCE: promise list
+INSTANCE: lazy-io list
+INSTANCE: lazy-concat list
+INSTANCE: lazy-cons list
+INSTANCE: lazy-map list
+INSTANCE: lazy-map-with list
+INSTANCE: lazy-take list
+INSTANCE: lazy-append list
+INSTANCE: lazy-from-by list
+INSTANCE: lazy-zip list
+INSTANCE: lazy-while list
+INSTANCE: lazy-until list
+INSTANCE: lazy-subset list
diff --git a/extra/math/analysis/analysis.factor b/extra/math/analysis/analysis.factor
old mode 100644
new mode 100755
index bde5cad7a0..0b4b14ce54
--- a/extra/math/analysis/analysis.factor
+++ b/extra/math/analysis/analysis.factor
@@ -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
@@ -108,3 +108,12 @@ PRIVATE>
swap -1.0 * exp
*
] if ;
+
+! James Stirling's approximation for N!:
+! http://www.csse.monash.edu.au/~lloyd/tildeAlgDS/Numerical/Stirling/
+
+: stirling-fact ( n -- fact )
+ [ pi 2 * * sqrt ]
+ [ dup e / swap ^ ]
+ [ 12 * recip 1 + ]
+ tri * * ;
diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor
index 4d777605cf..d32c11dd06 100755
--- a/extra/multiline/multiline.factor
+++ b/extra/multiline/multiline.factor
@@ -7,8 +7,11 @@ IN: multiline
lexer get dup next-line lexer-line-text ;
: (parse-here) ( -- )
- next-line-text dup ";" =
- [ drop lexer get next-line ] [ % "\n" % (parse-here) ] if ;
+ next-line-text [
+ dup ";" =
+ [ drop lexer get next-line ]
+ [ % "\n" % (parse-here) ] if
+ ] [ ";" unexpected-eof ] if* ;
: parse-here ( -- str )
[ (parse-here) ] "" make 1 head*
@@ -19,11 +22,13 @@ IN: multiline
parse-here 1quotation define-inline ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index )
- lexer get lexer-line-text 2dup start
- [ rot dupd >r >r swap subseq % r> r> length + ] [
- rot tail % "\n" % 0
- lexer get next-line swap (parse-multiline-string)
- ] if* ;
+ lexer get lexer-line-text [
+ 2dup start
+ [ rot dupd >r >r swap subseq % r> r> length + ] [
+ rot tail % "\n" % 0
+ lexer get next-line swap (parse-multiline-string)
+ ] if*
+ ] [ nip unexpected-eof ] if* ;
: parse-multiline-string ( end-text -- str )
[
diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor
index 729281e81b..3cbddf8296 100755
--- a/extra/optimizer/debugger/debugger.factor
+++ b/extra/optimizer/debugger/debugger.factor
@@ -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
@@ -95,14 +99,18 @@ M: #dispatch node>quot
node-children swap [ dataflow>quot ] curry map ,
\ dispatch , ;
-M: #return node>quot
- dup node-param unparse "#return " swap append comment, ;
-
M: #>r node>quot nip node-in-d length \ >r <array> % ;
M: #r> node>quot nip node-out-d length \ r> <array> % ;
-M: object node>quot dup class word-name comment, ;
+M: object node>quot
+ [
+ dup class word-name %
+ " " %
+ dup node-param unparse %
+ " " %
+ dup effect-str %
+ ] "" make comment, ;
: (dataflow>quot) ( ? node -- )
dup [
diff --git a/extra/optimizer/report/report.factor b/extra/optimizer/report/report.factor
new file mode 100755
index 0000000000..6655d9dcf3
--- /dev/null
+++ b/extra/optimizer/report/report.factor
@@ -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
diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor
index 275deee994..3ca1c72296 100755
--- a/extra/smtp/server/server.factor
+++ b/extra/smtp/server/server.factor
@@ -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 ;
diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor
index 27aac1202e..47bc16e029 100755
--- a/extra/smtp/smtp.factor
+++ b/extra/smtp/smtp.factor
@@ -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 ;
\ No newline at end of file
diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor
index b6c0ef3ecc..75ae377ea7 100755
--- a/extra/tools/browser/browser.factor
+++ b/extra/tools/browser/browser.factor
@@ -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
diff --git a/extra/tools/disassembler/authors.txt b/extra/tools/disassembler/authors.txt
new file mode 100644
index 0000000000..ef44eb9634
--- /dev/null
+++ b/extra/tools/disassembler/authors.txt
@@ -0,0 +1,2 @@
+Slava Pestov
+Jorge Acereda Macia
diff --git a/extra/tools/disassembler/disassembler-docs.factor b/extra/tools/disassembler/disassembler-docs.factor
new file mode 100755
index 0000000000..f03861a8ed
--- /dev/null
+++ b/extra/tools/disassembler/disassembler-docs.factor
@@ -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"
diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor
new file mode 100755
index 0000000000..8fe3b9bdf0
--- /dev/null
+++ b/extra/tools/disassembler/disassembler.factor
@@ -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 ;
diff --git a/extra/tools/disassembler/summary.txt b/extra/tools/disassembler/summary.txt
new file mode 100644
index 0000000000..f1a689c877
--- /dev/null
+++ b/extra/tools/disassembler/summary.txt
@@ -0,0 +1 @@
+Disassemble words using gdb
diff --git a/extra/tools/memory/memory-docs.factor b/extra/tools/memory/memory-docs.factor
old mode 100644
new mode 100755
index 939dda0cfc..11bb8d859b
--- a/extra/tools/memory/memory-docs.factor
+++ b/extra/tools/memory/memory-docs.factor
@@ -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"
diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor
index 62a4dab1eb..69093f18a6 100755
--- a/extra/tools/test/test.factor
+++ b/extra/tools/test/test.factor
@@ -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 )
diff --git a/extra/ui/commands/commands.factor b/extra/ui/commands/commands.factor
index 04f655853a..dbb838a5c5 100755
--- a/extra/ui/commands/commands.factor
+++ b/extra/ui/commands/commands.factor
@@ -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
diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor
index e4794452c7..082a27317a 100755
--- a/extra/ui/x11/x11.factor
+++ b/extra/ui/x11/x11.factor
@@ -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 ;
diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor
index 70a9c781a2..1014d3ad7e 100644
--- a/extra/unicode/breaks/breaks.factor
+++ b/extra/unicode/breaks/breaks.factor
@@ -1,7 +1,7 @@
USING: unicode.categories kernel math combinators splitting
sequences math.parser io.files io assocs arrays namespaces
combinators.lib assocs.lib math.ranges unicode.normalize
-unicode.syntax unicode.data compiler.units alien.syntax const ;
+unicode.syntax unicode.data compiler.units alien.syntax ;
IN: unicode.breaks
C-ENUM: Any L V T Extend Control CR LF graphemes ;
diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor
old mode 100644
new mode 100755
index c579d1fdfd..c3998a6132
--- a/extra/unicode/data/data.factor
+++ b/extra/unicode/data/data.factor
@@ -1,8 +1,16 @@
USING: assocs math kernel sequences io.files hashtables
quotations splitting arrays math.parser combinators.lib hash2
-byte-arrays words namespaces words compiler.units const ;
+byte-arrays words namespaces words compiler.units parser ;
IN: unicode.data
+<<
+: VALUE:
+ CREATE dup reset-generic { f } clone [ first ] curry define ; parsing
+
+: set-value ( value word -- )
+ word-def first set-first ;
+>>
+
! Convenience functions
: 1+* ( n/f _ -- n+1 )
drop [ 1+ ] [ 0 ] if* ;
@@ -59,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 )
@@ -85,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 ;
diff --git a/extra/unicode/syntax/syntax-tests.factor b/extra/unicode/syntax/syntax-tests.factor
deleted file mode 100644
index 1579e368c2..0000000000
--- a/extra/unicode/syntax/syntax-tests.factor
+++ /dev/null
@@ -1,4 +0,0 @@
-USING: unicode.syntax tools.test ;
-
-[ CHAR: ! ] [ UNICHAR: exclamation-mark ] unit-test
-! Write a test for CATEGORY and CATEGORY-NOT
diff --git a/extra/unicode/syntax/syntax.factor b/extra/unicode/syntax/syntax.factor
old mode 100644
new mode 100755
index 6c75a77c76..bd3fd4ae2a
--- a/extra/unicode/syntax/syntax.factor
+++ b/extra/unicode/syntax/syntax.factor
@@ -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
diff --git a/extra/unicode/unicode.factor b/extra/unicode/unicode.factor
index 12673c3bde..0c22bfab8f 100755
--- a/extra/unicode/unicode.factor
+++ b/extra/unicode/unicode.factor
@@ -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
diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor
index 59141c1940..9d5a6122a2 100755
--- a/extra/unix/unix.factor
+++ b/extra/unix/unix.factor
@@ -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 ;
diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor
index b8928c5820..3574df36db 100755
--- a/extra/windows/kernel32/kernel32.factor
+++ b/extra/windows/kernel32/kernel32.factor
@@ -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
diff --git a/extra/x11/clipboard/clipboard.factor b/extra/x11/clipboard/clipboard.factor
old mode 100644
new mode 100755
index 5978ee6f7f..eb4191ebb1
--- a/extra/x11/clipboard/clipboard.factor
+++ b/extra/x11/clipboard/clipboard.factor
@@ -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
diff --git a/misc/factor.sh b/misc/factor.sh
index 5d7e7d0b94..44feb329fb 100755
--- a/misc/factor.sh
+++ b/misc/factor.sh
@@ -14,16 +14,36 @@ NO_UI=
GIT_PROTOCOL=${GIT_PROTOCOL:="git"}
GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"}
+test_program_installed() {
+ if ! [[ -n `type -p $1` ]] ; then
+ return 0;
+ fi
+ return 1;
+}
ensure_program_installed() {
- echo -n "Checking for $1..."
- result=`type -p $1`
- if ! [[ -n $result ]] ; then
- echo "not found!"
- echo "Install $1 and try again."
- exit 1
- fi
- echo "found!"
+ installed=0;
+ for i in $* ;
+ do
+ echo -n "Checking for $i..."
+ test_program_installed $i
+ if [[ $? -eq 0 ]]; then
+ echo -n "not "
+ else
+ installed=$(( $installed + 1 ))
+ fi
+ echo "found!"
+ done
+ if [[ $installed -eq 0 ]] ; then
+ echo -n "Install "
+ if [[ $# -eq 1 ]] ; then
+ echo -n $1
+ else
+ echo -n "any of [ $* ]"
+ fi
+ echo " and try again."
+ exit 1
+ fi
}
check_ret() {
@@ -47,13 +67,33 @@ check_gcc_version() {
echo "ok."
}
+set_downloader() {
+ test_program_installed wget
+ if [[ $? -ne 0 ]] ; then
+ DOWNLOAD=wget
+ else
+ DOWNLOAD="curl -O"
+ fi
+}
+
+set_md5sum() {
+ test_program_installed md5sum
+ if [[ $? -ne 0 ]] ; then
+ MD5SUM=md5sum
+ else
+ MD5SUM="md5 -r"
+ fi
+}
+
check_installed_programs() {
ensure_program_installed chmod
ensure_program_installed uname
ensure_program_installed git
- ensure_program_installed wget
+ ensure_program_installed wget curl
ensure_program_installed gcc
ensure_program_installed make
+ ensure_program_installed md5sum md5
+ ensure_program_installed cut
case $OS in
netbsd) ensure_program_installed gmake;;
esac
@@ -234,36 +274,53 @@ make_factor() {
invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5
}
-delete_boot_images() {
+update_boot_images() {
echo "Deleting old images..."
- rm $BOOT_IMAGE > /dev/null 2>&1
+ rm checksums.txt* > /dev/null 2>&1
rm $BOOT_IMAGE.* > /dev/null 2>&1
- rm staging.*.image > /dev/null 2>&1
+ rm staging.*.image > /dev/null 2>&1
+ if [[ -f $BOOT_IMAGE ]] ; then
+ get_url http://factorcode.org/images/latest/checksums.txt
+ factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`;
+ set_md5sum
+ disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '`;
+ echo "Factorcode md5: $factorcode_md5";
+ echo "Disk md5: $disk_md5";
+ if [[ "$factorcode_md5" == "$disk_md5" ]] ; then
+ echo "Your disk boot image matches the one on factorcode.org."
+ else
+ rm $BOOT_IMAGE > /dev/null 2>&1
+ get_boot_image;
+ fi
+ else
+ get_boot_image
+ fi
}
get_boot_image() {
- wget http://factorcode.org/images/latest/$BOOT_IMAGE
- check_ret wget
+ echo "Downloading boot image $BOOT_IMAGE."
+ get_url http://factorcode.org/images/latest/$BOOT_IMAGE
+}
+
+get_url() {
+ if [[ $DOWNLOAD -eq "" ]] ; then
+ set_downloader;
+ fi
+ echo $DOWNLOAD $1 ;
+ $DOWNLOAD $1
+ check_ret $DOWNLOAD
}
maybe_download_dlls() {
if [[ $OS == winnt ]] ; then
- wget http://factorcode.org/dlls/freetype6.dll
- check_ret wget
- wget http://factorcode.org/dlls/zlib1.dll
- check_ret wget
- wget http://factorcode.org/dlls/OpenAL32.dll
- check_ret wget
- wget http://factorcode.org/dlls/alut.dll
- check_ret wget
- wget http://factorcode.org/dlls/ogg.dll
- check_ret wget
- wget http://factorcode.org/dlls/theora.dll
- check_ret wget
- wget http://factorcode.org/dlls/vorbis.dll
- check_ret wget
- wget http://factorcode.org/dlls/sqlite3.dll
- check_ret wget
+ get_url http://factorcode.org/dlls/freetype6.dll
+ get_url http://factorcode.org/dlls/zlib1.dll
+ get_url http://factorcode.org/dlls/OpenAL32.dll
+ get_url http://factorcode.org/dlls/alut.dll
+ get_url http://factorcode.org/dlls/ogg.dll
+ get_url http://factorcode.org/dlls/theora.dll
+ get_url http://factorcode.org/dlls/vorbis.dll
+ get_url http://factorcode.org/dlls/sqlite3.dll
chmod 777 *.dll
check_ret chmod
fi
@@ -299,8 +356,7 @@ update() {
}
update_bootstrap() {
- delete_boot_images
- get_boot_image
+ update_boot_images
bootstrap
}
@@ -321,7 +377,7 @@ install_libraries() {
}
usage() {
- echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|wget-bootstrap"
+ echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|net-bootstrap"
echo "If you are behind a firewall, invoke as:"
echo "env GIT_PROTOCOL=http $0 <command>"
}
@@ -333,6 +389,6 @@ case "$1" in
quick-update) update; refresh_image ;;
update) update; update_bootstrap ;;
bootstrap) get_config_info; bootstrap ;;
- wget-bootstrap) get_config_info; delete_boot_images; get_boot_image; bootstrap ;;
+ net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
*) usage ;;
esac
diff --git a/vm/types.c b/vm/types.c
index 78e74535b8..fb61213385 100755
--- a/vm/types.c
+++ b/vm/types.c
@@ -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)