Merge branch 'master' into unicode
Conflicts: core/io/encodings/utf16/utf16-tests.factor core/io/encodings/utf16/utf16.factor core/io/encodings/utf8/utf8-tests.factordb4
commit
2a2d7cf04e
|
@ -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 [
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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." }
|
||||
|
|
|
@ -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 [
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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" } }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -0,0 +1,4 @@
|
|||
IN: temporary
|
||||
USING: debugger kernel continuations tools.test ;
|
||||
|
||||
[ ] [ [ drop ] [ error. ] recover ] unit-test
|
|
@ -26,7 +26,7 @@ SYMBOL: compiling-word
|
|||
|
||||
SYMBOL: compiling-label
|
||||
|
||||
SYMBOL: compiling-loop?
|
||||
SYMBOL: compiling-loops
|
||||
|
||||
! Label of current word, after prologue, makes recursion faster
|
||||
SYMBOL: current-label-start
|
||||
|
@ -34,7 +34,7 @@ SYMBOL: current-label-start
|
|||
: compiled-stack-traces? ( -- ? ) 36 getenv ;
|
||||
|
||||
: begin-compiling ( word label -- )
|
||||
compiling-loop? off
|
||||
H{ } clone compiling-loops set
|
||||
compiling-label set
|
||||
compiling-word set
|
||||
compiled-stack-traces?
|
||||
|
@ -94,8 +94,8 @@ M: node generate-node drop iterate-next ;
|
|||
: generate-call ( label -- next )
|
||||
dup maybe-compile
|
||||
end-basic-block
|
||||
dup compiling-label get eq? compiling-loop? get and [
|
||||
drop current-label-start get %jump-label f
|
||||
dup compiling-loops get at [
|
||||
%jump-label f
|
||||
] [
|
||||
tail-call? [
|
||||
%jump f
|
||||
|
@ -104,7 +104,7 @@ M: node generate-node drop iterate-next ;
|
|||
%call
|
||||
iterate-next
|
||||
] if
|
||||
] if ;
|
||||
] ?if ;
|
||||
|
||||
! #label
|
||||
M: #label generate-node
|
||||
|
@ -113,17 +113,13 @@ M: #label generate-node
|
|||
r> ;
|
||||
|
||||
! #loop
|
||||
: compiling-loop ( word -- )
|
||||
<label> dup resolve-label swap compiling-loops get set-at ;
|
||||
|
||||
M: #loop generate-node
|
||||
end-basic-block
|
||||
[
|
||||
dup node-param compiling-label set
|
||||
current-label-start define-label
|
||||
current-label-start resolve-label
|
||||
compiling-loop? on
|
||||
node-child generate-nodes
|
||||
end-basic-block
|
||||
] with-scope
|
||||
init-templates
|
||||
dup node-param compiling-loop
|
||||
node-child generate-nodes
|
||||
iterate-next ;
|
||||
|
||||
! #if
|
||||
|
@ -158,17 +154,10 @@ M: #if generate-node
|
|||
] with-generator
|
||||
] keep ;
|
||||
|
||||
: tail-dispatch? ( node -- ? )
|
||||
#! Is the dispatch a jump to a tail call to a word?
|
||||
dup #call? swap node-successor #return? and ;
|
||||
|
||||
: dispatch-branches ( node -- )
|
||||
node-children [
|
||||
dup tail-dispatch? [
|
||||
node-param
|
||||
] [
|
||||
compiling-word get dispatch-branch
|
||||
] if %dispatch-label
|
||||
compiling-word get dispatch-branch
|
||||
%dispatch-label
|
||||
] each ;
|
||||
|
||||
: generate-dispatch ( node -- )
|
||||
|
@ -276,5 +265,6 @@ M: #r> generate-node
|
|||
|
||||
! #return
|
||||
M: #return generate-node
|
||||
node-param compiling-label get eq? compiling-loop? get and
|
||||
[ end-basic-block %return ] unless f ;
|
||||
end-basic-block
|
||||
node-param compiling-loops get key?
|
||||
[ %return ] unless f ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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> ;
|
||||
|
|
|
@ -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 } } }
|
||||
|
|
|
@ -317,4 +317,8 @@ UNION: #tail
|
|||
POSTPONE: f #return #tail-values #tail-merge #terminate ;
|
||||
|
||||
: tail-call? ( -- ? )
|
||||
node-stack get [ node-successor #tail? ] all? ;
|
||||
#! We don't consider calls which do non-local exits to be
|
||||
#! tail calls, because this gives better error traces.
|
||||
node-stack get [
|
||||
node-successor dup #tail? swap #terminate? not and
|
||||
] all? ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2007 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel sequences sbufs vectors io.streams.lines io.streams.plain
|
||||
namespaces unicode.syntax growable strings io classes io.streams.c
|
||||
namespaces unicode growable strings io classes io.streams.c
|
||||
continuations ;
|
||||
IN: io.encodings
|
||||
|
||||
|
@ -19,7 +19,7 @@ SYMBOL: begin
|
|||
over push 0 begin ;
|
||||
|
||||
: push-replacement ( buf -- buf ch state )
|
||||
UNICHAR: replacement-character decoded ;
|
||||
CHAR: replacement-character decoded ;
|
||||
|
||||
: finish-decoding ( buf ch state -- str )
|
||||
begin eq? [ decode-error ] unless drop "" like ;
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: io.encodings strings kernel ;
|
||||
USING: io io.encodings strings kernel ;
|
||||
IN: io.encodings.latin1
|
||||
|
||||
TUPLE: latin1 stream ;
|
||||
|
|
|
@ -1,12 +1,12 @@
|
|||
USING: help.markup help.syntax io.encodings strings ;
|
||||
IN: io.encodings.utf8
|
||||
|
||||
ARTICLE: "io.utf8" "Working with UTF8-encoded data"
|
||||
ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data"
|
||||
"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences."
|
||||
{ $subsection encode-utf8 }
|
||||
{ $subsection decode-utf8 } ;
|
||||
|
||||
ABOUT: "io.utf8"
|
||||
ABOUT: "io.encodings.utf8"
|
||||
|
||||
HELP: decode-utf8
|
||||
{ $values { "seq" "a sequence of bytes" } { "str" string } }
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: io.encodings.utf8 tools.test sbufs kernel io io.encodings
|
||||
sequences strings arrays unicode.syntax ;
|
||||
USING: io.encodings.utf8 tools.test sbufs kernel io
|
||||
sequences strings arrays unicode ;
|
||||
|
||||
: decode-utf8-w/stream ( array -- newarray )
|
||||
>sbuf dup reverse-here utf8 <decoding> contents ;
|
||||
|
@ -7,7 +7,7 @@ sequences strings arrays unicode.syntax ;
|
|||
: encode-utf8-w/stream ( array -- newarray )
|
||||
SBUF" " clone tuck utf8 <encoding> stream-write >array ;
|
||||
|
||||
[ { UNICHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test
|
||||
[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test
|
||||
|
||||
[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test
|
||||
|
||||
|
@ -15,7 +15,7 @@ sequences strings arrays unicode.syntax ;
|
|||
|
||||
[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
|
||||
|
||||
[ { UNICHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
|
||||
[ { CHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
|
||||
|
||||
[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test
|
||||
|
||||
|
|
|
@ -3,8 +3,7 @@
|
|||
USING: arrays generic assocs inference inference.class
|
||||
inference.dataflow inference.backend inference.state io kernel
|
||||
math namespaces sequences vectors words quotations hashtables
|
||||
combinators classes generic.math continuations optimizer.def-use
|
||||
optimizer.pattern-match generic.standard optimizer.specializers ;
|
||||
combinators classes optimizer.def-use ;
|
||||
IN: optimizer.backend
|
||||
|
||||
SYMBOL: class-substitutions
|
||||
|
@ -38,10 +37,10 @@ GENERIC: optimize-node* ( node -- node/t changed? )
|
|||
over assoc-empty? [
|
||||
2drop
|
||||
] [
|
||||
2dup node-in-d substitute
|
||||
2dup node-in-r substitute
|
||||
2dup node-out-d substitute
|
||||
node-out-r substitute
|
||||
2dup node-in-d swap substitute-here
|
||||
2dup node-in-r swap substitute-here
|
||||
2dup node-out-d swap substitute-here
|
||||
node-out-r swap substitute-here
|
||||
] if ;
|
||||
|
||||
: perform-substitutions ( node -- )
|
||||
|
@ -76,7 +75,6 @@ DEFER: optimize-nodes
|
|||
optimizer-changed get
|
||||
] with-scope optimizer-changed set ;
|
||||
|
||||
! Generic nodes
|
||||
M: node optimize-node* drop t f ;
|
||||
|
||||
! Post-inlining cleanup
|
||||
|
@ -112,362 +110,10 @@ M: #return optimize-node* cleanup-inlining ;
|
|||
! #values
|
||||
M: #values optimize-node* cleanup-inlining ;
|
||||
|
||||
! Some utilities for splicing in dataflow IR subtrees
|
||||
M: f set-node-successor 2drop ;
|
||||
|
||||
: splice-node ( old new -- )
|
||||
dup splice-def-use last-node set-node-successor ;
|
||||
|
||||
GENERIC: remember-method* ( method-spec node -- )
|
||||
|
||||
M: #call remember-method*
|
||||
[ node-history ?push ] keep set-node-history ;
|
||||
|
||||
M: node remember-method*
|
||||
2drop ;
|
||||
|
||||
: remember-method ( method-spec node -- )
|
||||
swap dup second +inlined+ depends-on
|
||||
[ swap remember-method* ] curry each-node ;
|
||||
|
||||
: (splice-method) ( #call method-spec quot -- node )
|
||||
#! Must remember the method before splicing in, otherwise
|
||||
#! the rest of the IR will also remember the method
|
||||
pick node-in-d dataflow-with
|
||||
[ remember-method ] keep
|
||||
[ swap infer-classes/node ] 2keep
|
||||
[ splice-node ] keep ;
|
||||
|
||||
: splice-quot ( #call quot -- node )
|
||||
over node-in-d dataflow-with
|
||||
[ swap infer-classes/node ] 2keep
|
||||
[ splice-node ] keep ;
|
||||
|
||||
: drop-inputs ( node -- #shuffle )
|
||||
node-in-d clone \ #shuffle in-node ;
|
||||
|
||||
! Constant branch folding
|
||||
: fold-branch ( node branch# -- node )
|
||||
over node-children nth
|
||||
swap node-successor over splice-node ;
|
||||
|
||||
! #if
|
||||
: known-boolean-value? ( node value -- value ? )
|
||||
2dup node-literal? [
|
||||
node-literal t
|
||||
] [
|
||||
node-class {
|
||||
{ [ dup null class< ] [ drop f f ] }
|
||||
{ [ dup general-t class< ] [ drop t t ] }
|
||||
{ [ dup \ f class< ] [ drop f t ] }
|
||||
{ [ t ] [ drop f f ] }
|
||||
} cond
|
||||
] if ;
|
||||
|
||||
: fold-if-branch? dup node-in-d first known-boolean-value? ;
|
||||
|
||||
: fold-if-branch ( node value -- node' )
|
||||
over drop-inputs >r
|
||||
0 1 ? fold-branch
|
||||
r> [ set-node-successor ] keep ;
|
||||
|
||||
: only-one ( seq -- elt/f )
|
||||
dup length 1 = [ first ] [ drop f ] if ;
|
||||
|
||||
: lift-throw-tail? ( #if -- tail/? )
|
||||
dup node-successor node-successor
|
||||
[ active-children only-one ] [ drop f ] if ;
|
||||
|
||||
: clone-node ( node -- newnode )
|
||||
clone dup [ clone ] modify-values ;
|
||||
|
||||
: detach-node-successor ( node -- successor )
|
||||
dup node-successor #terminate rot set-node-successor ;
|
||||
|
||||
: lift-branch ( #if node -- )
|
||||
>r detach-node-successor r> splice-node ;
|
||||
|
||||
M: #if optimize-node*
|
||||
dup fold-if-branch? [ fold-if-branch t ] [
|
||||
2drop t f
|
||||
! drop dup lift-throw-tail? dup [
|
||||
! dupd lift-branch t
|
||||
! ] [
|
||||
! 2drop t f
|
||||
! ] if
|
||||
] if ;
|
||||
|
||||
: fold-dispatch-branch? dup node-in-d first tuck node-literal? ;
|
||||
|
||||
: fold-dispatch-branch ( node value -- node' )
|
||||
dupd node-literal
|
||||
over drop-inputs >r fold-branch r>
|
||||
[ set-node-successor ] keep ;
|
||||
|
||||
M: #dispatch optimize-node*
|
||||
dup fold-dispatch-branch? [
|
||||
fold-dispatch-branch t
|
||||
] [
|
||||
2drop t f
|
||||
] if ;
|
||||
|
||||
! #loop
|
||||
|
||||
|
||||
! BEFORE:
|
||||
|
||||
! #label -> C -> #return 1
|
||||
! |
|
||||
! -> #if -> #merge -> #return 2
|
||||
! |
|
||||
! --------
|
||||
! | |
|
||||
! A B
|
||||
! | |
|
||||
! #values |
|
||||
! #call-label
|
||||
! |
|
||||
! |
|
||||
! #values
|
||||
|
||||
! AFTER:
|
||||
|
||||
! #label -> #terminate
|
||||
! |
|
||||
! -> #if -> #terminate
|
||||
! |
|
||||
! --------
|
||||
! | |
|
||||
! A B
|
||||
! | |
|
||||
! #values |
|
||||
! | #call-label
|
||||
! #merge |
|
||||
! | |
|
||||
! C #values
|
||||
! |
|
||||
! #return 1
|
||||
|
||||
: find-final-if ( node -- #if/f )
|
||||
dup [
|
||||
dup #if? [
|
||||
dup node-successor #tail? [
|
||||
node-successor find-final-if
|
||||
] unless
|
||||
] [
|
||||
node-successor find-final-if
|
||||
] if
|
||||
] when ;
|
||||
|
||||
: lift-loop-tail? ( #label -- tail/f )
|
||||
dup node-successor node-successor [
|
||||
dup node-param swap node-child find-final-if dup [
|
||||
node-children [ penultimate-node ] map
|
||||
[
|
||||
dup #call-label?
|
||||
[ node-param eq? not ] [ 2drop t ] if
|
||||
] with subset only-one
|
||||
] [ 2drop f ] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
! M: #loop optimize-node*
|
||||
! dup lift-loop-tail? dup [
|
||||
! last-node >r
|
||||
! dup detach-node-successor
|
||||
! over node-child find-final-if detach-node-successor
|
||||
! [ set-node-successor ] keep
|
||||
! r> set-node-successor
|
||||
! t
|
||||
! ] [
|
||||
! 2drop t f
|
||||
! ] if ;
|
||||
|
||||
! #call
|
||||
: splice-method ( #call method-spec/t quot/t -- node/t )
|
||||
#! t indicates failure
|
||||
{
|
||||
{ [ dup t eq? ] [ 3drop t ] }
|
||||
{ [ 2over swap node-history member? ] [ 3drop t ] }
|
||||
{ [ t ] [ (splice-method) ] }
|
||||
} cond ;
|
||||
|
||||
! Single dispatch method inlining optimization
|
||||
: already-inlined? ( node -- ? )
|
||||
#! Was this node inlined from definition of 'word'?
|
||||
dup node-param swap node-history memq? ;
|
||||
|
||||
: specific-method ( class word -- class ) order min-class ;
|
||||
|
||||
: node-class# ( node n -- class )
|
||||
over node-in-d <reversed> ?nth node-class ;
|
||||
|
||||
: dispatching-class ( node word -- class )
|
||||
[ dispatch# node-class# ] keep specific-method ;
|
||||
|
||||
! A heuristic to avoid excessive inlining
|
||||
DEFER: (flat-length)
|
||||
|
||||
: word-flat-length ( word -- n )
|
||||
dup get over inline? not or
|
||||
[ drop 1 ] [ dup dup set word-def (flat-length) ] if ;
|
||||
|
||||
: (flat-length) ( seq -- n )
|
||||
[
|
||||
{
|
||||
{ [ dup quotation? ] [ (flat-length) 1+ ] }
|
||||
{ [ dup array? ] [ (flat-length) ] }
|
||||
{ [ dup word? ] [ word-flat-length ] }
|
||||
{ [ t ] [ drop 1 ] }
|
||||
} cond
|
||||
] map sum ;
|
||||
|
||||
: flat-length ( seq -- n )
|
||||
[ word-def (flat-length) ] with-scope ;
|
||||
|
||||
: will-inline-method ( node word -- method-spec/t quot/t )
|
||||
#! t indicates failure
|
||||
tuck dispatching-class dup [
|
||||
swap [ 2array ] 2keep
|
||||
method method-word
|
||||
dup flat-length 10 >=
|
||||
[ 1quotation ] [ word-def ] if
|
||||
] [
|
||||
2drop t t
|
||||
] if ;
|
||||
|
||||
: inline-standard-method ( node word -- node )
|
||||
dupd will-inline-method splice-method ;
|
||||
|
||||
! Partial dispatch of math-generic words
|
||||
: math-both-known? ( word left right -- ? )
|
||||
math-class-max swap specific-method ;
|
||||
|
||||
: will-inline-math-method ( word left right -- method-spec/t quot/t )
|
||||
#! t indicates failure
|
||||
3dup math-both-known?
|
||||
[ [ 3array ] 3keep math-method ] [ 3drop t t ] if ;
|
||||
|
||||
: inline-math-method ( #call word -- node )
|
||||
over node-input-classes first2
|
||||
will-inline-math-method splice-method ;
|
||||
|
||||
: inline-method ( #call -- node )
|
||||
dup node-param {
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||
{ [ t ] [ 2drop t ] }
|
||||
} cond ;
|
||||
|
||||
! Resolve type checks at compile time where possible
|
||||
: comparable? ( actual testing -- ? )
|
||||
#! If actual is a subset of testing or if the two classes
|
||||
#! are disjoint, return t.
|
||||
2dup class< >r classes-intersect? not r> or ;
|
||||
|
||||
: optimize-predicate? ( #call -- ? )
|
||||
dup node-param "predicating" word-prop dup [
|
||||
>r node-class-first r> comparable?
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: literal-quot ( node literals -- quot )
|
||||
#! Outputs a quotation which drops the node's inputs, and
|
||||
#! pushes some literals.
|
||||
>r node-in-d length \ drop <repetition>
|
||||
r> [ literalize ] map append >quotation ;
|
||||
|
||||
: inline-literals ( node literals -- node )
|
||||
#! Make #shuffle -> #push -> #return -> successor
|
||||
dupd literal-quot splice-quot ;
|
||||
|
||||
: evaluate-predicate ( #call -- ? )
|
||||
dup node-param "predicating" word-prop >r
|
||||
node-class-first r> class< ;
|
||||
|
||||
: optimize-predicate ( #call -- node )
|
||||
dup evaluate-predicate swap
|
||||
dup node-successor #if? [
|
||||
dup drop-inputs >r
|
||||
node-successor swap 0 1 ? fold-branch
|
||||
r> [ set-node-successor ] keep
|
||||
] [
|
||||
swap 1array inline-literals
|
||||
] if ;
|
||||
|
||||
: optimizer-hooks ( node -- conditions )
|
||||
node-param "optimizer-hooks" word-prop ;
|
||||
|
||||
: optimizer-hook ( node -- pair/f )
|
||||
dup optimizer-hooks [ first call ] find 2nip ;
|
||||
|
||||
: optimize-hook ( node -- )
|
||||
dup optimizer-hook second call ;
|
||||
|
||||
: define-optimizers ( word optimizers -- )
|
||||
"optimizer-hooks" set-word-prop ;
|
||||
|
||||
: flush-eval? ( #call -- ? )
|
||||
dup node-param "flushable" word-prop [
|
||||
node-out-d [ unused? ] all?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: flush-eval ( #call -- node )
|
||||
dup node-param +inlined+ depends-on
|
||||
dup node-out-d length f <repetition> inline-literals ;
|
||||
|
||||
: partial-eval? ( #call -- ? )
|
||||
dup node-param "foldable" word-prop [
|
||||
dup node-in-d [ node-literal? ] with all?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: literal-in-d ( #call -- inputs )
|
||||
dup node-in-d [ node-literal ] with map ;
|
||||
|
||||
: partial-eval ( #call -- node )
|
||||
dup node-param +inlined+ depends-on
|
||||
dup literal-in-d over node-param 1quotation
|
||||
[ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
|
||||
|
||||
: define-identities ( words identities -- )
|
||||
[ "identities" set-word-prop ] curry each ;
|
||||
|
||||
: find-identity ( node -- quot )
|
||||
[ node-param "identities" word-prop ] keep
|
||||
[ swap first in-d-match? ] curry find
|
||||
nip dup [ second ] when ;
|
||||
|
||||
: apply-identities ( node -- node/f )
|
||||
dup find-identity dup [ splice-quot ] [ 2drop f ] if ;
|
||||
|
||||
: optimistic-inline? ( #call -- ? )
|
||||
dup node-param "specializer" word-prop dup [
|
||||
>r node-input-classes r> specialized-length tail*
|
||||
[ types length 1 = ] all?
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: optimistic-inline ( #call -- node )
|
||||
dup node-param dup +inlined+ depends-on
|
||||
word-def splice-quot ;
|
||||
|
||||
: method-body-inline? ( #call -- ? )
|
||||
node-param dup method-body?
|
||||
[ flat-length 8 <= ] [ drop f ] if ;
|
||||
|
||||
M: #call optimize-node*
|
||||
{
|
||||
{ [ dup flush-eval? ] [ flush-eval ] }
|
||||
{ [ dup partial-eval? ] [ partial-eval ] }
|
||||
{ [ dup find-identity ] [ apply-identities ] }
|
||||
{ [ dup optimizer-hook ] [ optimize-hook ] }
|
||||
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
|
||||
{ [ dup optimistic-inline? ] [ optimistic-inline ] }
|
||||
{ [ dup method-body-inline? ] [ optimistic-inline ] }
|
||||
{ [ t ] [ inline-method ] }
|
||||
} cond dup not ;
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
IN: temporary
|
||||
USING: tools.test optimizer.control combinators kernel
|
||||
sequences inference.dataflow math inference ;
|
||||
sequences inference.dataflow math inference classes strings
|
||||
optimizer ;
|
||||
|
||||
: label-is-loop? ( node word -- ? )
|
||||
[
|
||||
|
@ -60,3 +61,121 @@ sequences inference.dataflow math inference ;
|
|||
[ loop-test-3 ] dataflow dup detect-loops
|
||||
\ loop-test-3 label-is-not-loop?
|
||||
] unit-test
|
||||
|
||||
: loop-test-4 ( a -- )
|
||||
dup [
|
||||
loop-test-4
|
||||
] [
|
||||
drop
|
||||
] if ; inline
|
||||
|
||||
: find-label ( node -- label )
|
||||
dup #label? [ node-successor find-label ] unless ;
|
||||
|
||||
: test-loop-exits
|
||||
dataflow dup detect-loops find-label
|
||||
dup node-param swap
|
||||
[ node-child find-tail find-loop-exits [ class ] map ] keep
|
||||
#label-loop? ;
|
||||
|
||||
[ { #values } t ] [
|
||||
[ loop-test-4 ] test-loop-exits
|
||||
] unit-test
|
||||
|
||||
: loop-test-5 ( a -- )
|
||||
dup [
|
||||
dup string? [
|
||||
loop-test-5
|
||||
] [
|
||||
drop
|
||||
] if
|
||||
] [
|
||||
drop
|
||||
] if ; inline
|
||||
|
||||
[ { #values #values } t ] [
|
||||
[ loop-test-5 ] test-loop-exits
|
||||
] unit-test
|
||||
|
||||
: loop-test-6 ( a -- )
|
||||
dup [
|
||||
dup string? [
|
||||
loop-test-6
|
||||
] [
|
||||
3 throw
|
||||
] if
|
||||
] [
|
||||
drop
|
||||
] if ; inline
|
||||
|
||||
[ { #values } t ] [
|
||||
[ loop-test-6 ] test-loop-exits
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ [ [ ] map ] map ] dataflow dup detect-loops
|
||||
[ dup #label? swap #loop? not and ] node-exists?
|
||||
] unit-test
|
||||
|
||||
: blah f ;
|
||||
|
||||
DEFER: a
|
||||
|
||||
: b ( -- )
|
||||
blah [ b ] [ a ] if ; inline
|
||||
|
||||
: a ( -- )
|
||||
blah [ b ] [ a ] if ; inline
|
||||
|
||||
[ t ] [
|
||||
[ a ] dataflow dup detect-loops
|
||||
\ a label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ a ] dataflow dup detect-loops
|
||||
\ b label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ b ] dataflow dup detect-loops
|
||||
\ a label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ a ] dataflow dup detect-loops
|
||||
\ b label-is-loop?
|
||||
] unit-test
|
||||
|
||||
DEFER: a'
|
||||
|
||||
: b' ( -- )
|
||||
blah [ b' b' ] [ a' ] if ; inline
|
||||
|
||||
: a' ( -- )
|
||||
blah [ b' ] [ a' ] if ; inline
|
||||
|
||||
[ f ] [
|
||||
[ a' ] dataflow dup detect-loops
|
||||
\ a' label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ b' ] dataflow dup detect-loops
|
||||
\ b' label-is-loop?
|
||||
] unit-test
|
||||
|
||||
! I used to think this should be f, but doing this on pen and
|
||||
! paper almost convinced me that a loop conversion here is
|
||||
! sound. The loop analysis algorithm looks pretty solid -- its
|
||||
! a standard iterative dataflow problem after all -- so I'm
|
||||
! tempted to believe the computer here
|
||||
[ t ] [
|
||||
[ b' ] dataflow dup detect-loops
|
||||
\ a' label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ a' ] dataflow dup detect-loops
|
||||
\ b' label-is-loop?
|
||||
] unit-test
|
||||
|
|
|
@ -1,36 +1,336 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel inference.dataflow combinators sequences
|
||||
namespaces math ;
|
||||
USING: arrays generic assocs inference inference.class
|
||||
inference.dataflow inference.backend inference.state io kernel
|
||||
math namespaces sequences vectors words quotations hashtables
|
||||
combinators classes generic.math continuations optimizer.def-use
|
||||
optimizer.backend generic.standard ;
|
||||
IN: optimizer.control
|
||||
|
||||
GENERIC: detect-loops* ( node -- )
|
||||
! ! ! Rudimentary CFA
|
||||
|
||||
M: node detect-loops* drop ;
|
||||
! A LOOP
|
||||
!
|
||||
! #label A
|
||||
! |
|
||||
! #if ----> #merge ----> #return
|
||||
! |
|
||||
! -------------
|
||||
! | |
|
||||
! #call-label A |
|
||||
! | ...
|
||||
! #values
|
||||
!
|
||||
! NOT A LOOP (call to A not in tail position):
|
||||
!
|
||||
!
|
||||
! #label A
|
||||
! |
|
||||
! #if ----> ... ----> #merge ----> #return
|
||||
! |
|
||||
! -------------
|
||||
! | |
|
||||
! #call-label A |
|
||||
! | ...
|
||||
! ...
|
||||
! |
|
||||
! #values
|
||||
!
|
||||
! NOT A LOOP (call to A nested inside another label which is
|
||||
! not a loop):
|
||||
!
|
||||
!
|
||||
! #label A
|
||||
! |
|
||||
! #if ----> #merge ----> ... ----> #return
|
||||
! |
|
||||
! -------------
|
||||
! | |
|
||||
! ... #label B
|
||||
! |
|
||||
! #if -> ...
|
||||
! |
|
||||
! ---------
|
||||
! | |
|
||||
! #call-label A |
|
||||
! | |
|
||||
! #values |
|
||||
! #call-label B
|
||||
! |
|
||||
! ...
|
||||
|
||||
M: #label detect-loops* t swap set-#label-loop? ;
|
||||
! Mapping word => { node { nesting tail? }+ height }
|
||||
! We record all calls to a label, their control nesting and
|
||||
! whether it is a tail call or not
|
||||
SYMBOL: label-info
|
||||
|
||||
: not-a-loop ( #label -- )
|
||||
f swap set-#label-loop? ;
|
||||
GENERIC: collect-label-info* ( node -- )
|
||||
|
||||
: tail-call? ( -- ? )
|
||||
node-stack get
|
||||
dup [ #label? ] find-last drop [ 1+ ] [ 0 ] if* tail
|
||||
[ node-successor #tail? ] all? ;
|
||||
M: #label collect-label-info*
|
||||
[ V{ } clone node-stack get length 3array ] keep
|
||||
node-param label-info get set-at ;
|
||||
|
||||
: detect-loop ( seen-other? label node -- seen-other? continue? )
|
||||
#! seen-other?: have we seen another label?
|
||||
{
|
||||
{ [ dup #label? not ] [ 2drop t ] }
|
||||
{ [ 2dup node-param eq? not ] [ 3drop t t ] }
|
||||
{ [ tail-call? not ] [ not-a-loop drop f ] }
|
||||
{ [ pick ] [ not-a-loop drop f ] }
|
||||
{ [ t ] [ 2drop f ] }
|
||||
} cond ;
|
||||
USE: prettyprint
|
||||
|
||||
M: #call-label detect-loops*
|
||||
f swap node-param node-stack get <reversed>
|
||||
[ detect-loop ] with all? 2drop ;
|
||||
M: #call-label collect-label-info*
|
||||
node-param label-info get at
|
||||
node-stack get over third tail
|
||||
[ [ #label? ] subset [ node-param ] map ] keep
|
||||
[ node-successor #tail? ] all? 2array
|
||||
swap second push ;
|
||||
|
||||
: detect-loops ( node -- )
|
||||
[ detect-loops* ] each-node ;
|
||||
M: node collect-label-info*
|
||||
drop ;
|
||||
|
||||
: collect-label-info ( node -- )
|
||||
H{ } clone label-info set
|
||||
[ collect-label-info* ] each-node ;
|
||||
|
||||
! Mapping word => label
|
||||
SYMBOL: potential-loops
|
||||
|
||||
: remove-non-tail-calls ( -- )
|
||||
label-info get
|
||||
[ nip second [ second ] all? ] assoc-subset
|
||||
[ first ] assoc-map
|
||||
potential-loops set ;
|
||||
|
||||
: remove-non-loop-calls ( -- )
|
||||
! Boolean is set to t if something changed.
|
||||
! We recurse until a fixed point is reached.
|
||||
f label-info get [
|
||||
! If label X is called from within a label Y that is
|
||||
! no longer a potential loop, then X is no longer a
|
||||
! potential loop either.
|
||||
over potential-loops get key? [
|
||||
second [ first ] map concat
|
||||
potential-loops get [ key? ] curry all?
|
||||
[ drop ] [ potential-loops get delete-at t or ] if
|
||||
] [ 2drop ] if
|
||||
] assoc-each [ remove-non-loop-calls ] when ;
|
||||
|
||||
: detect-loops ( nodes -- )
|
||||
[
|
||||
collect-label-info
|
||||
remove-non-tail-calls
|
||||
remove-non-loop-calls
|
||||
potential-loops get [
|
||||
nip t swap set-#label-loop?
|
||||
] assoc-each
|
||||
] with-scope ;
|
||||
|
||||
! ! ! Constant branch folding
|
||||
!
|
||||
! BEFORE
|
||||
!
|
||||
! #if ----> #merge ----> C
|
||||
! |
|
||||
! ---------
|
||||
! | |
|
||||
! A B
|
||||
! | |
|
||||
! #values |
|
||||
! #values
|
||||
!
|
||||
! AFTER
|
||||
!
|
||||
! |
|
||||
! A
|
||||
! |
|
||||
! #values
|
||||
! |
|
||||
! #merge
|
||||
! |
|
||||
! C
|
||||
|
||||
: fold-branch ( node branch# -- node )
|
||||
over node-children nth
|
||||
swap node-successor over splice-node ;
|
||||
|
||||
! #if
|
||||
: known-boolean-value? ( node value -- value ? )
|
||||
2dup node-literal? [
|
||||
node-literal t
|
||||
] [
|
||||
node-class {
|
||||
{ [ dup null class< ] [ drop f f ] }
|
||||
{ [ dup general-t class< ] [ drop t t ] }
|
||||
{ [ dup \ f class< ] [ drop f t ] }
|
||||
{ [ t ] [ drop f f ] }
|
||||
} cond
|
||||
] if ;
|
||||
|
||||
: fold-if-branch? dup node-in-d first known-boolean-value? ;
|
||||
|
||||
: fold-if-branch ( node value -- node' )
|
||||
over drop-inputs >r
|
||||
0 1 ? fold-branch
|
||||
r> [ set-node-successor ] keep ;
|
||||
|
||||
! ! ! Lifting code after a conditional if one branch throws
|
||||
|
||||
! BEFORE
|
||||
!
|
||||
! #if ----> #merge ----> B ----> #return/#values
|
||||
! |
|
||||
! |
|
||||
! ---------
|
||||
! | |
|
||||
! | A
|
||||
! #terminate |
|
||||
! #values
|
||||
!
|
||||
! AFTER
|
||||
!
|
||||
! #if ----> #merge (*) ----> #return/#values (**)
|
||||
! |
|
||||
! |
|
||||
! ---------
|
||||
! | |
|
||||
! | A
|
||||
! #terminate |
|
||||
! #values
|
||||
! |
|
||||
! #merge (***)
|
||||
! |
|
||||
! B
|
||||
! |
|
||||
! #return/#values
|
||||
!
|
||||
! (*) has the same outputs as the inputs of (**), and it is not
|
||||
! the same node as (***)
|
||||
!
|
||||
! Note: if (**) is #return is is sound to put #terminate there,
|
||||
! but not if (**) is #
|
||||
|
||||
: only-one ( seq -- elt/f )
|
||||
dup length 1 = [ first ] [ drop f ] if ;
|
||||
|
||||
: lift-throw-tail? ( #if -- tail/? )
|
||||
dup node-successor #tail?
|
||||
[ drop f ] [ active-children only-one ] if ;
|
||||
|
||||
: clone-node ( node -- newnode )
|
||||
clone dup [ clone ] modify-values ;
|
||||
|
||||
: lift-branch
|
||||
over
|
||||
last-node clone-node
|
||||
dup node-in-d \ #merge out-node
|
||||
[ set-node-successor ] keep -rot
|
||||
>r dup node-successor r> splice-node
|
||||
set-node-successor ;
|
||||
|
||||
M: #if optimize-node*
|
||||
dup fold-if-branch? [ fold-if-branch t ] [
|
||||
drop dup lift-throw-tail? dup [
|
||||
dupd lift-branch t
|
||||
] [
|
||||
2drop t f
|
||||
] if
|
||||
] if ;
|
||||
|
||||
! Loop tail hoising: code after a loop can sometimes go in the
|
||||
! non-recursive branch of the loop
|
||||
|
||||
! BEFORE:
|
||||
|
||||
! #label -> C -> #return 1
|
||||
! |
|
||||
! -> #if -> #merge (*) -> #return 2
|
||||
! |
|
||||
! --------
|
||||
! | |
|
||||
! A B
|
||||
! | |
|
||||
! #values |
|
||||
! #call-label
|
||||
! |
|
||||
! |
|
||||
! #values
|
||||
|
||||
! AFTER:
|
||||
|
||||
! #label -> #return 1
|
||||
! |
|
||||
! -> #if -------> #merge (*) -> #return 2
|
||||
! | \-------------------/
|
||||
! ---------------- |
|
||||
! | | |
|
||||
! A B unreacachable code needed to
|
||||
! | | preserve invariants
|
||||
! #values |
|
||||
! | #call-label
|
||||
! #merge (*) |
|
||||
! | |
|
||||
! C #values
|
||||
! |
|
||||
! #return 1
|
||||
|
||||
: find-tail ( node -- tail )
|
||||
dup #terminate? [
|
||||
dup node-successor #tail? [
|
||||
node-successor find-tail
|
||||
] unless
|
||||
] unless ;
|
||||
|
||||
: child-tails ( node -- seq )
|
||||
node-children [ find-tail ] map ;
|
||||
|
||||
GENERIC: add-loop-exit* ( label node -- )
|
||||
|
||||
M: #branch add-loop-exit*
|
||||
child-tails [ add-loop-exit* ] with each ;
|
||||
|
||||
M: #call-label add-loop-exit*
|
||||
tuck node-param eq? [ drop ] [ node-successor , ] if ;
|
||||
|
||||
M: #terminate add-loop-exit*
|
||||
2drop ;
|
||||
|
||||
M: node add-loop-exit*
|
||||
nip node-successor dup #terminate? [ drop ] [ , ] if ;
|
||||
|
||||
: find-loop-exits ( label node -- seq )
|
||||
[ add-loop-exit* ] { } make ;
|
||||
|
||||
: find-final-if ( node -- #if/f )
|
||||
dup [
|
||||
dup #if? [
|
||||
dup node-successor #tail? [
|
||||
node-successor find-final-if
|
||||
] unless
|
||||
] [
|
||||
node-successor find-final-if
|
||||
] if
|
||||
] when ;
|
||||
|
||||
: detach-node-successor ( node -- successor )
|
||||
dup node-successor #terminate rot set-node-successor ;
|
||||
|
||||
: lift-loop-tail? ( #label -- tail/f )
|
||||
dup node-successor node-successor [
|
||||
dup node-param swap node-child find-final-if dup [
|
||||
find-loop-exits only-one
|
||||
] [ 2drop f ] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
M: #loop optimize-node*
|
||||
dup lift-loop-tail? dup [
|
||||
last-node "values" set
|
||||
|
||||
dup node-successor "tail" set
|
||||
dup node-successor last-node "return" set
|
||||
dup node-child find-final-if node-successor "merge" set
|
||||
|
||||
! #label -> #return
|
||||
"return" get clone-node over set-node-successor
|
||||
! #merge -> C
|
||||
"merge" get clone-node "tail" get over set-node-successor
|
||||
! #values -> #merge ->C
|
||||
"values" get set-node-successor
|
||||
|
||||
t
|
||||
] [
|
||||
2drop t f
|
||||
] if ;
|
||||
|
|
|
@ -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 ;
|
|
@ -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
|
||||
|
|
|
@ -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 ] }
|
||||
|
|
|
@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel
|
|||
kernel.private math optimizer prettyprint sequences sbufs
|
||||
strings tools.test vectors words sequences.private quotations
|
||||
optimizer.backend classes inference.dataflow tuples.private
|
||||
continuations growable ;
|
||||
continuations growable optimizer.inlining namespaces ;
|
||||
IN: temporary
|
||||
|
||||
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
|
||||
|
@ -301,3 +301,53 @@ TUPLE: silly-tuple a b ;
|
|||
[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
|
||||
[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
|
||||
[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
|
||||
|
||||
! Regression
|
||||
: lift-throw-tail-regression
|
||||
dup integer? [ "an integer" ] [
|
||||
dup string? [ "a string" ] [
|
||||
"error" throw
|
||||
] if
|
||||
] if ;
|
||||
|
||||
[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test
|
||||
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
|
||||
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
|
||||
|
||||
: lift-loop-tail-test-1 ( a quot -- )
|
||||
over even? [
|
||||
[ >r 3 - r> call ] keep lift-loop-tail-test-1
|
||||
] [
|
||||
over 0 < [
|
||||
2drop
|
||||
] [
|
||||
[ >r 2 - r> call ] keep lift-loop-tail-test-1
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
: lift-loop-tail-test-2
|
||||
10 [ ] lift-loop-tail-test-1 1 2 3 ;
|
||||
|
||||
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
|
||||
|
||||
! Make sure we don't lose
|
||||
GENERIC: generic-inline-test ( x -- y )
|
||||
M: integer generic-inline-test ;
|
||||
|
||||
: generic-inline-test-1
|
||||
1
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test ;
|
||||
|
||||
[ { t f } ] [
|
||||
\ generic-inline-test-1 word-def dataflow
|
||||
[ optimize-1 , optimize-1 , drop ] { } make
|
||||
] unit-test
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces optimizer.backend optimizer.def-use
|
||||
optimizer.known-words optimizer.math optimizer.control
|
||||
inference.class ;
|
||||
optimizer.inlining inference.class ;
|
||||
IN: optimizer
|
||||
|
||||
: optimize-1 ( node -- newnode ? )
|
||||
|
|
|
@ -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?
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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>
|
||||
|
||||
|
|
|
@ -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...\"" }
|
||||
|
|
|
@ -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\"" [
|
||||
|
|
|
@ -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 } } }
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -0,0 +1,3 @@
|
|||
USING: vocabs.loader vocabs kernel ;
|
||||
|
||||
"bootstrap.help" vocab [ "help.handbook" require ] when
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -3,73 +3,43 @@ USING: kernel parser io io.files io.launcher io.sockets hashtables math threads
|
|||
arrays system continuations namespaces sequences splitting math.parser
|
||||
prettyprint tools.time calendar bake vars http.client
|
||||
combinators bootstrap.image bootstrap.image.download
|
||||
combinators.cleave benchmark ;
|
||||
combinators.cleave benchmark
|
||||
classes strings quotations words parser-combinators new-slots accessors
|
||||
assocs.lib smtp builder.util ;
|
||||
|
||||
IN: builder
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: runtime ( quot -- time ) benchmark nip ;
|
||||
SYMBOL: builds-dir
|
||||
|
||||
: minutes>ms ( min -- ms ) 60 * 1000 * ;
|
||||
: builds ( -- path )
|
||||
builds-dir get
|
||||
home "/builds" append
|
||||
or ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: builder-recipients
|
||||
|
||||
: host-name* ( -- name ) host-name "." split first ;
|
||||
|
||||
: tag-subject ( str -- str ) `{ "builder@" ,[ host-name* ] ": " , } concat ;
|
||||
|
||||
: email-string ( subject -- )
|
||||
`{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] }
|
||||
[ ] with-process-stream drop ;
|
||||
|
||||
: email-file ( subject file -- )
|
||||
`{
|
||||
{ +stdin+ , }
|
||||
{ +arguments+
|
||||
{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] } }
|
||||
}
|
||||
>hashtable run-process drop ;
|
||||
: prepare-build-machine ( -- )
|
||||
builds make-directory
|
||||
builds cd
|
||||
{ "git" "clone" "git://factorcode.org/git/factor.git" } run-process drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ;
|
||||
: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
|
||||
|
||||
: factor-binary ( -- name )
|
||||
os
|
||||
{ { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
|
||||
{ "winnt" [ "./factor-nt.exe" ] }
|
||||
[ drop "./factor" ] }
|
||||
case ;
|
||||
|
||||
: git-pull ( -- desc )
|
||||
{
|
||||
"git"
|
||||
"pull"
|
||||
"--no-summary"
|
||||
"git://factorcode.org/git/factor.git"
|
||||
"master"
|
||||
} ;
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: git-clone ( -- desc ) { "git" "clone" "../factor" } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: datestamp ( -- string )
|
||||
now `{ ,[ dup timestamp-year ]
|
||||
,[ dup timestamp-month ]
|
||||
,[ dup timestamp-day ]
|
||||
,[ dup timestamp-hour ]
|
||||
,[ timestamp-minute ] }
|
||||
[ pad-00 ] map "-" join ;
|
||||
|
||||
VAR: stamp
|
||||
|
||||
: enter-build-dir ( -- )
|
||||
datestamp >stamp
|
||||
"/builds" cd
|
||||
builds cd
|
||||
stamp> make-directory
|
||||
stamp> cd ;
|
||||
|
||||
|
@ -82,57 +52,59 @@ VAR: stamp
|
|||
|
||||
: make-clean ( -- desc ) { "make" "clean" } ;
|
||||
|
||||
: make-vm ( -- )
|
||||
`{
|
||||
{ +arguments+ { "make" ,[ target ] } }
|
||||
{ +stdout+ "../compile-log" }
|
||||
{ +stderr+ +stdout+ }
|
||||
}
|
||||
>hashtable ;
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ;
|
||||
|
||||
: make-vm ( -- desc )
|
||||
<process*>
|
||||
{ "make" target } to-strings >>arguments
|
||||
"../compile-log" >>stdout
|
||||
+stdout+ >>stderr
|
||||
>desc ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: factor-binary ( -- name )
|
||||
os
|
||||
{ { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
|
||||
{ "winnt" [ "./factor-nt.exe" ] }
|
||||
[ drop "./factor" ] }
|
||||
case ;
|
||||
|
||||
: bootstrap-cmd ( -- cmd )
|
||||
{ factor-binary [ "-i=" my-boot-image-name append ] "-no-user-init" }
|
||||
to-strings ;
|
||||
|
||||
: bootstrap ( -- desc )
|
||||
`{
|
||||
{ +arguments+ {
|
||||
,[ factor-binary ]
|
||||
,[ "-i=" my-boot-image-name append ]
|
||||
"-no-user-init"
|
||||
} }
|
||||
{ +stdout+ "../boot-log" }
|
||||
{ +stderr+ +stdout+ }
|
||||
{ +timeout+ ,[ 20 minutes>ms ] }
|
||||
} ;
|
||||
<process*>
|
||||
bootstrap-cmd >>arguments
|
||||
+closed+ >>stdin
|
||||
"../boot-log" >>stdout
|
||||
+stdout+ >>stderr
|
||||
20 minutes>ms >>timeout
|
||||
>desc ;
|
||||
|
||||
: builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ;
|
||||
: builder-test ( -- desc ) { factor-binary "-run=builder.test" } to-strings ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: build-status
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: milli-seconds>time ( n -- string )
|
||||
1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
|
||||
|
||||
: eval-file ( file -- obj ) <file-reader> contents eval ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: cat ( file -- ) <file-reader> contents print ;
|
||||
|
||||
: run-or-bail ( desc quot -- )
|
||||
[ [ try-process ] curry ]
|
||||
[ [ throw ] curry ]
|
||||
bi*
|
||||
recover ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: (build) ( -- )
|
||||
|
||||
builds-check
|
||||
|
||||
build-status off
|
||||
|
||||
enter-build-dir
|
||||
|
||||
"report" [
|
||||
|
||||
"Build machine: " write host-name print
|
||||
"Build directory: " write cwd print
|
||||
"CPU: " write cpu print
|
||||
"OS: " write os print
|
||||
"Build directory: " write cwd print nl
|
||||
|
||||
git-clone [ "git clone failed" print ] run-or-bail
|
||||
|
||||
|
@ -144,33 +116,17 @@ SYMBOL: build-status
|
|||
|
||||
make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail
|
||||
|
||||
[ my-arch download-image ] [ "Image download error" print throw ] recover
|
||||
[ retrieve-image ] [ "Image download error" print throw ] recover
|
||||
|
||||
! bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
|
||||
bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
|
||||
|
||||
! bootstrap
|
||||
! <process-stream> dup dispose process-stream-process wait-for-process
|
||||
! zero? not
|
||||
! [ "Bootstrap error" print "../boot-log" cat "bootstrap error" throw ]
|
||||
! when
|
||||
|
||||
[
|
||||
bootstrap
|
||||
<process-stream> dup dispose process-stream-process wait-for-process
|
||||
zero? not
|
||||
[ "bootstrap non-zero" throw ]
|
||||
when
|
||||
]
|
||||
[ "Bootstrap error" print "../boot-log" cat "bootstrap" throw ]
|
||||
recover
|
||||
|
||||
[ builder-test try-process ]
|
||||
[ "Builder test error" print throw ]
|
||||
recover
|
||||
|
||||
"Boot time: " write "../boot-time" eval-file milli-seconds>time print
|
||||
"Load time: " write "../load-time" eval-file milli-seconds>time print
|
||||
"Test time: " write "../test-time" eval-file milli-seconds>time print
|
||||
"Test time: " write "../test-time" eval-file milli-seconds>time print nl
|
||||
|
||||
"Did not pass load-everything: " print "../load-everything-vocabs" cat
|
||||
"Did not pass test-all: " print "../test-all-vocabs" cat
|
||||
|
@ -178,14 +134,43 @@ SYMBOL: build-status
|
|||
"Benchmarks: " print
|
||||
"../benchmarks" [ stdio get contents eval ] with-file-in benchmarks.
|
||||
|
||||
] with-file-out ;
|
||||
] with-file-out
|
||||
|
||||
build-status on ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: builder-from
|
||||
|
||||
SYMBOL: builder-recipients
|
||||
|
||||
: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ;
|
||||
|
||||
: subject ( -- str ) build-status get [ "report" ] [ "error" ] if tag-subject ;
|
||||
|
||||
: send-builder-email ( -- )
|
||||
<email>
|
||||
builder-from get >>from
|
||||
builder-recipients get >>to
|
||||
subject >>subject
|
||||
"../report" file>string >>body
|
||||
send ;
|
||||
|
||||
: build ( -- )
|
||||
[ (build) ] [ drop ] recover
|
||||
"report" "../report" email-file ;
|
||||
[ send-builder-email ] [ drop "not sending mail" . ] recover ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: git-pull ( -- desc )
|
||||
{
|
||||
"git"
|
||||
"pull"
|
||||
"--no-summary"
|
||||
"git://factorcode.org/git/factor.git"
|
||||
"master"
|
||||
} ;
|
||||
|
||||
: updates-available? ( -- ? )
|
||||
git-id
|
||||
git-pull run-process drop
|
||||
|
@ -193,8 +178,9 @@ SYMBOL: build-status
|
|||
= not ;
|
||||
|
||||
: build-loop ( -- )
|
||||
builds-check
|
||||
[
|
||||
"/builds/factor" cd
|
||||
builds "/factor" append cd
|
||||
updates-available?
|
||||
[ build ]
|
||||
when
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -6,7 +6,7 @@ USING: kernel namespaces sequences assocs builder continuations
|
|||
prettyprint
|
||||
tools.browser
|
||||
tools.test
|
||||
bootstrap.stage2 benchmark ;
|
||||
bootstrap.stage2 benchmark builder.util ;
|
||||
|
||||
IN: builder.test
|
||||
|
||||
|
|
|
@ -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 ;
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs classes continuations kernel math
|
||||
namespaces sequences sequences.lib tuples words ;
|
||||
namespaces sequences sequences.lib tuples words strings ;
|
||||
IN: db
|
||||
|
||||
TUPLE: db handle insert-statements update-statements delete-statements select-statements ;
|
||||
|
@ -36,13 +36,17 @@ HOOK: <prepared-statement> db ( str -- statement )
|
|||
GENERIC: prepare-statement ( statement -- )
|
||||
GENERIC: bind-statement* ( obj statement -- )
|
||||
GENERIC: reset-statement ( statement -- )
|
||||
GENERIC: execute-statement* ( statement -- result-set )
|
||||
HOOK: last-id db ( res -- id )
|
||||
: execute-statement ( statement -- )
|
||||
execute-statement* dispose ;
|
||||
GENERIC: insert-statement ( statement -- id )
|
||||
|
||||
: execute-statement-last-id ( statement -- id )
|
||||
execute-statement* [ last-id ] with-disposal ;
|
||||
TUPLE: result-set sql params handle n max ;
|
||||
GENERIC: query-results ( query -- result-set )
|
||||
GENERIC: #rows ( result-set -- n )
|
||||
GENERIC: #columns ( result-set -- n )
|
||||
GENERIC# row-column 1 ( result-set n -- obj )
|
||||
GENERIC: advance-row ( result-set -- )
|
||||
GENERIC: more-rows? ( result-set -- ? )
|
||||
|
||||
: execute-statement ( statement -- ) query-results dispose ;
|
||||
|
||||
: bind-statement ( obj statement -- )
|
||||
dup statement-bound? [ dup reset-statement ] when
|
||||
|
@ -50,17 +54,9 @@ HOOK: last-id db ( res -- id )
|
|||
[ set-statement-params ] keep
|
||||
t swap set-statement-bound? ;
|
||||
|
||||
TUPLE: result-set sql params handle n max ;
|
||||
|
||||
GENERIC: query-results ( query -- result-set )
|
||||
GENERIC: #rows ( result-set -- n )
|
||||
GENERIC: #columns ( result-set -- n )
|
||||
GENERIC# row-column 1 ( result-set n -- obj )
|
||||
GENERIC: advance-row ( result-set -- ? )
|
||||
|
||||
: init-result-set ( result-set -- )
|
||||
dup #rows over set-result-set-max
|
||||
-1 swap set-result-set-n ;
|
||||
0 swap set-result-set-n ;
|
||||
|
||||
: <result-set> ( query handle tuple -- result-set )
|
||||
>r >r { statement-sql statement-params } get-slots r>
|
||||
|
@ -74,10 +70,10 @@ GENERIC: advance-row ( result-set -- ? )
|
|||
dup #columns [ row-column ] with map ;
|
||||
|
||||
: query-each ( statement quot -- )
|
||||
over advance-row [
|
||||
2drop
|
||||
over more-rows? [
|
||||
[ call ] 2keep over advance-row query-each
|
||||
] [
|
||||
[ call ] 2keep query-each
|
||||
2drop
|
||||
] if ; inline
|
||||
|
||||
: query-map ( statement quot -- seq )
|
||||
|
@ -98,11 +94,6 @@ GENERIC: advance-row ( result-set -- ? )
|
|||
: do-bound-command ( obj query -- )
|
||||
[ bind-statement ] keep execute-statement ;
|
||||
|
||||
: sql-query ( sql -- rows )
|
||||
<simple-statement> [ do-query ] with-disposal ;
|
||||
|
||||
: sql-command ( sql -- )
|
||||
<simple-statement> [ execute-statement ] with-disposal ;
|
||||
|
||||
SYMBOL: in-transaction
|
||||
HOOK: begin-transaction db ( -- )
|
||||
|
@ -116,3 +107,13 @@ HOOK: rollback-transaction db ( -- )
|
|||
begin-transaction
|
||||
[ ] [ rollback-transaction ] cleanup commit-transaction
|
||||
] with-variable ;
|
||||
|
||||
: sql-query ( sql -- rows )
|
||||
<simple-statement> [ do-query ] with-disposal ;
|
||||
|
||||
: sql-command ( sql -- )
|
||||
dup string? [
|
||||
<simple-statement> [ execute-statement ] with-disposal
|
||||
] [
|
||||
[ [ sql-command ] each ] with-transaction
|
||||
] if ;
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays continuations db io kernel math namespaces
|
||||
quotations sequences db.postgresql.ffi alien alien.c-types ;
|
||||
quotations sequences db.postgresql.ffi alien alien.c-types
|
||||
db.types ;
|
||||
IN: db.postgresql.lib
|
||||
|
||||
: postgresql-result-error-message ( res -- str/f )
|
||||
|
@ -37,13 +38,9 @@ IN: db.postgresql.lib
|
|||
>r db get db-handle r>
|
||||
[ statement-sql ] keep
|
||||
[ statement-params length f ] keep
|
||||
statement-params [ second malloc-char-string ] map >c-void*-array
|
||||
statement-params
|
||||
[ first number>string* malloc-char-string ] map >c-void*-array
|
||||
f f 0 PQexecParams
|
||||
dup postgresql-result-ok? [
|
||||
dup postgresql-result-error-message swap PQclear throw
|
||||
] unless ;
|
||||
|
||||
: pq-oid-value ( res -- n )
|
||||
PQoidValue dup InvalidOid = [
|
||||
"postgresql returned an InvalidOid" throw
|
||||
] when ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: arrays assocs alien alien.syntax continuations io
|
||||
kernel math math.parser namespaces prettyprint quotations
|
||||
sequences debugger db db.postgresql.lib db.postgresql.ffi
|
||||
db.tuples db.types ;
|
||||
db.tuples db.types tools.annotations math.ranges ;
|
||||
IN: db.postgresql
|
||||
|
||||
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
|
||||
|
@ -52,11 +52,11 @@ M: postgresql-result-set #columns ( result-set -- n )
|
|||
M: postgresql-result-set row-column ( result-set n -- obj )
|
||||
>r dup result-set-handle swap result-set-n r> PQgetvalue ;
|
||||
|
||||
M: postgresql-statement execute-statement* ( statement -- obj )
|
||||
query-results ;
|
||||
M: postgresql-result-set row-column ( result-set n -- obj )
|
||||
>r dup result-set-handle swap result-set-n r> PQgetvalue ;
|
||||
|
||||
: increment-n ( result-set -- n )
|
||||
dup result-set-n 1+ dup rot set-result-set-n ;
|
||||
M: postgresql-statement insert-statement ( statement -- id )
|
||||
query-results [ break 0 row-column ] with-disposal ;
|
||||
|
||||
M: postgresql-statement query-results ( query -- result-set )
|
||||
dup statement-params [
|
||||
|
@ -68,8 +68,11 @@ M: postgresql-statement query-results ( query -- result-set )
|
|||
postgresql-result-set <result-set>
|
||||
dup init-result-set ;
|
||||
|
||||
M: postgresql-result-set advance-row ( result-set -- ? )
|
||||
dup increment-n swap result-set-max >= ;
|
||||
M: postgresql-result-set advance-row ( result-set -- )
|
||||
dup result-set-n 1+ swap set-result-set-n ;
|
||||
|
||||
M: postgresql-result-set more-rows? ( result-set -- ? )
|
||||
dup result-set-n swap result-set-max < ;
|
||||
|
||||
M: postgresql-statement dispose ( query -- )
|
||||
dup statement-handle PQclear
|
||||
|
@ -105,36 +108,105 @@ M: postgresql-db commit-transaction ( -- )
|
|||
M: postgresql-db rollback-transaction ( -- )
|
||||
"ROLLBACK" sql-command ;
|
||||
|
||||
: postgresql-type-hash* ( -- assoc )
|
||||
H{
|
||||
{ SERIAL "serial" }
|
||||
} ;
|
||||
|
||||
M: postgresql-db create-sql ( columns table -- sql )
|
||||
: postgresql-type-hash ( -- assoc )
|
||||
H{
|
||||
{ INTEGER "integer" }
|
||||
{ SERIAL "integer" }
|
||||
{ TEXT "text" }
|
||||
{ VARCHAR "varchar" }
|
||||
{ DOUBLE "real" }
|
||||
} ;
|
||||
|
||||
: enquote ( str -- newstr ) "(" swap ")" 3append ;
|
||||
|
||||
: postgresql-type ( str n/str -- newstr )
|
||||
" " swap number>string* enquote 3append ;
|
||||
|
||||
: >sql-type* ( obj -- str )
|
||||
dup pair? [
|
||||
first2 >r >sql-type* r> postgresql-type
|
||||
] [
|
||||
dup postgresql-type-hash* at* [
|
||||
nip
|
||||
] [
|
||||
drop >sql-type
|
||||
] if
|
||||
] if ;
|
||||
|
||||
M: postgresql-db >sql-type ( hash obj -- str )
|
||||
dup pair? [
|
||||
first2 >r >sql-type r> postgresql-type
|
||||
] [
|
||||
postgresql-type-hash at* [
|
||||
no-sql-type
|
||||
] unless
|
||||
] if ;
|
||||
|
||||
: insert-function ( columns table -- sql )
|
||||
[
|
||||
"create table " % %
|
||||
" (" % [ ", " % ] [
|
||||
dup second % " " %
|
||||
dup third >sql-type % " " %
|
||||
sql-modifiers " " join %
|
||||
] interleave ")" %
|
||||
] "" make ;
|
||||
>r remove-id r>
|
||||
"create function add_" % dup %
|
||||
"(" %
|
||||
over [ "," % ]
|
||||
[ third dup array? [ first ] when >sql-type % ] interleave
|
||||
")" %
|
||||
" returns bigint as '" %
|
||||
|
||||
M: postgresql-db drop-sql ( table -- sql )
|
||||
[
|
||||
"drop table " % %
|
||||
] "" make ;
|
||||
|
||||
SYMBOL: postgresql-counter
|
||||
|
||||
M: postgresql-db insert-sql* ( columns table -- sql )
|
||||
[
|
||||
postgresql-counter off
|
||||
"insert into " %
|
||||
2dup "insert into " %
|
||||
%
|
||||
"(" %
|
||||
dup [ ", " % ] [ second % ] interleave
|
||||
") " %
|
||||
" values (" %
|
||||
[ ", " % ] [
|
||||
drop "$" % postgresql-counter [ inc ] keep get #
|
||||
] interleave
|
||||
length [1,b] [ ", " % ] [ "$" % # ] interleave
|
||||
"); " %
|
||||
|
||||
"select currval(''" % % "_id_seq'');' language sql;" %
|
||||
drop
|
||||
] "" make ;
|
||||
|
||||
: drop-function ( columns table -- sql )
|
||||
[
|
||||
>r remove-id r>
|
||||
"drop function add_" % %
|
||||
"(" %
|
||||
[ "," % ] [ third >sql-type % ] interleave
|
||||
")" %
|
||||
] "" make ;
|
||||
|
||||
M: postgresql-db create-sql ( columns table -- seq )
|
||||
[
|
||||
[
|
||||
2dup
|
||||
"create table " % %
|
||||
" (" % [ ", " % ] [
|
||||
dup second % " " %
|
||||
dup third >sql-type* % " " %
|
||||
sql-modifiers " " join %
|
||||
] interleave "); " %
|
||||
] "" make ,
|
||||
|
||||
over native-id? [ insert-function , ] [ 2drop ] if
|
||||
] { } make ;
|
||||
|
||||
M: postgresql-db drop-sql ( columns table -- seq )
|
||||
[
|
||||
[
|
||||
dup "drop table " % % ";" %
|
||||
] "" make ,
|
||||
over native-id? [ drop-function , ] [ 2drop ] if
|
||||
] { } make ;
|
||||
|
||||
M: postgresql-db insert-sql* ( columns table -- sql )
|
||||
[
|
||||
"select add_" % %
|
||||
"(" %
|
||||
length [1,b] [ ", " % ] [ "$" % # ] interleave
|
||||
")" %
|
||||
] "" make ;
|
||||
|
||||
|
@ -144,9 +216,10 @@ M: postgresql-db update-sql* ( columns table -- sql )
|
|||
%
|
||||
" set " %
|
||||
dup remove-id
|
||||
[ ", " % ] [ second dup % " = :" % % ] interleave
|
||||
dup length [1,b] swap 2array flip
|
||||
[ ", " % ] [ first2 second % " = $" % # ] interleave
|
||||
" where " %
|
||||
[ primary-key? ] find nip second dup % " = :" % %
|
||||
[ primary-key? ] find nip second dup % " = $" % length 2 + #
|
||||
] "" make ;
|
||||
|
||||
M: postgresql-db delete-sql* ( columns table -- sql )
|
||||
|
@ -154,23 +227,19 @@ M: postgresql-db delete-sql* ( columns table -- sql )
|
|||
"delete from " %
|
||||
%
|
||||
" where " %
|
||||
first second dup % " = :" % %
|
||||
first second % " = $1" %
|
||||
] "" make ;
|
||||
|
||||
M: postgresql-db select-sql* ( columns table -- sql )
|
||||
drop ;
|
||||
|
||||
M: postgresql-db tuple>params ( columns tuple -- obj )
|
||||
[
|
||||
>r dup first r> get-slot-named swap third
|
||||
] curry { } map>assoc ;
|
||||
[ >r dup third swap first r> get-slot-named swap ]
|
||||
curry { } map>assoc ;
|
||||
|
||||
M: postgresql-db last-id ( res -- id )
|
||||
pq-oid-value ;
|
||||
|
||||
: postgresql-db-modifiers ( -- hashtable )
|
||||
H{
|
||||
{ +native-id+ "primary key" }
|
||||
{ +native-id+ "not null primary key" }
|
||||
{ +assigned-id+ "primary key" }
|
||||
{ +autoincrement+ "autoincrement" }
|
||||
{ +unique+ "unique" }
|
||||
|
@ -189,18 +258,3 @@ M: postgresql-db sql-modifiers* ( modifiers -- str )
|
|||
swap at
|
||||
] if
|
||||
] with map [ ] subset ;
|
||||
|
||||
: postgresql-type-hash ( -- assoc )
|
||||
H{
|
||||
{ INTEGER "integer" }
|
||||
{ TEXT "text" }
|
||||
{ VARCHAR "text" }
|
||||
{ DOUBLE "real" }
|
||||
} ;
|
||||
|
||||
M: postgresql-db >sql-type ( obj -- str )
|
||||
dup pair? [
|
||||
first >sql-type
|
||||
] [
|
||||
postgresql-type-hash at* [ T{ no-sql-type } throw ] unless
|
||||
] if ;
|
||||
|
|
|
@ -74,10 +74,11 @@ IN: db.sqlite.lib
|
|||
dup array? [ first ] when
|
||||
{
|
||||
{ INTEGER [ sqlite-bind-int-by-name ] }
|
||||
{ BIG_INTEGER [ sqlite-bind-int-by-name ] }
|
||||
{ BIG_INTEGER [ sqlite-bind-int64-by-name ] }
|
||||
{ TEXT [ sqlite-bind-text-by-name ] }
|
||||
{ VARCHAR [ sqlite-bind-text-by-name ] }
|
||||
{ DOUBLE [ sqlite-bind-double-by-name ] }
|
||||
{ SERIAL [ sqlite-bind-int-by-name ] }
|
||||
! { NULL [ sqlite-bind-null-by-name ] }
|
||||
[ no-sql-type ]
|
||||
} case ;
|
||||
|
@ -99,13 +100,13 @@ IN: db.sqlite.lib
|
|||
: sqlite-row ( handle -- seq )
|
||||
dup sqlite-#columns [ sqlite-column ] with map ;
|
||||
|
||||
: step-complete? ( step-result -- bool )
|
||||
: sqlite-step-has-more-rows? ( step-result -- bool )
|
||||
dup SQLITE_ROW = [
|
||||
drop f
|
||||
drop t
|
||||
] [
|
||||
dup SQLITE_DONE =
|
||||
[ drop ] [ sqlite-check-result ] if t
|
||||
[ drop ] [ sqlite-check-result ] if f
|
||||
] if ;
|
||||
|
||||
: sqlite-next ( prepared -- ? )
|
||||
sqlite3_step step-complete? ;
|
||||
sqlite3_step sqlite-step-has-more-rows? ;
|
||||
|
|
|
@ -25,9 +25,7 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
|
|||
TUPLE: sqlite-statement ;
|
||||
C: <sqlite-statement> sqlite-statement
|
||||
|
||||
TUPLE: sqlite-result-set advanced? ;
|
||||
: <sqlite-result-set> ( query -- sqlite-result-set )
|
||||
dup statement-handle sqlite-result-set <result-set> ;
|
||||
TUPLE: sqlite-result-set has-more? ;
|
||||
|
||||
M: sqlite-db <simple-statement> ( str -- obj )
|
||||
<prepared-statement> ;
|
||||
|
@ -40,13 +38,7 @@ M: sqlite-db <prepared-statement> ( str -- obj )
|
|||
M: sqlite-statement dispose ( statement -- )
|
||||
statement-handle sqlite-finalize ;
|
||||
|
||||
: maybe-advance-row ( result-set -- result-set )
|
||||
dup sqlite-result-set-advanced? [
|
||||
dup advance-row drop
|
||||
] unless ;
|
||||
|
||||
M: sqlite-result-set dispose ( result-set -- )
|
||||
maybe-advance-row
|
||||
f swap set-result-set-handle ;
|
||||
|
||||
: sqlite-bind ( triples handle -- )
|
||||
|
@ -58,8 +50,12 @@ M: sqlite-statement bind-statement* ( triples statement -- )
|
|||
M: sqlite-statement reset-statement ( statement -- )
|
||||
statement-handle sqlite-reset ;
|
||||
|
||||
M: sqlite-statement execute-statement* ( statement -- obj )
|
||||
query-results ;
|
||||
: last-insert-id ( -- id )
|
||||
db get db-handle sqlite3_last_insert_rowid
|
||||
dup zero? [ "last-id failed" throw ] when ;
|
||||
|
||||
M: sqlite-statement insert-statement ( statement -- id )
|
||||
execute-statement last-insert-id ;
|
||||
|
||||
M: sqlite-result-set #columns ( result-set -- n )
|
||||
result-set-handle sqlite-#columns ;
|
||||
|
@ -67,12 +63,16 @@ M: sqlite-result-set #columns ( result-set -- n )
|
|||
M: sqlite-result-set row-column ( result-set n -- obj )
|
||||
>r result-set-handle r> sqlite-column ;
|
||||
|
||||
M: sqlite-result-set advance-row ( result-set -- handle ? )
|
||||
M: sqlite-result-set advance-row ( result-set -- )
|
||||
[ result-set-handle sqlite-next ] keep
|
||||
t swap set-sqlite-result-set-advanced? ;
|
||||
set-sqlite-result-set-has-more? ;
|
||||
|
||||
M: sqlite-result-set more-rows? ( result-set -- ? )
|
||||
sqlite-result-set-has-more? ;
|
||||
|
||||
M: sqlite-statement query-results ( query -- result-set )
|
||||
dup statement-handle sqlite-result-set <result-set> ;
|
||||
dup statement-handle sqlite-result-set <result-set>
|
||||
dup advance-row ;
|
||||
|
||||
M: sqlite-db begin-transaction ( -- )
|
||||
"BEGIN" sql-command ;
|
||||
|
@ -93,9 +93,10 @@ M: sqlite-db create-sql ( columns table -- sql )
|
|||
] interleave ")" %
|
||||
] "" make ;
|
||||
|
||||
M: sqlite-db drop-sql ( table -- sql )
|
||||
M: sqlite-db drop-sql ( columns table -- sql )
|
||||
[
|
||||
"drop table " % %
|
||||
drop
|
||||
] "" make ;
|
||||
|
||||
M: sqlite-db insert-sql* ( columns table -- sql )
|
||||
|
@ -144,11 +145,6 @@ M: sqlite-db tuple>params ( columns tuple -- obj )
|
|||
dupd >r first r> get-slot-named swap
|
||||
third 3array
|
||||
] curry map ;
|
||||
|
||||
M: sqlite-db last-id ( result-set -- id )
|
||||
maybe-advance-row drop
|
||||
db get db-handle sqlite3_last_insert_rowid
|
||||
dup zero? [ "last-id failed" throw ] when ;
|
||||
|
||||
: sqlite-db-modifiers ( -- hashtable )
|
||||
H{
|
||||
|
@ -175,6 +171,7 @@ M: sqlite-db sql-modifiers* ( modifiers -- str )
|
|||
: sqlite-type-hash ( -- assoc )
|
||||
H{
|
||||
{ INTEGER "integer" }
|
||||
{ SERIAL "integer" }
|
||||
{ TEXT "text" }
|
||||
{ VARCHAR "text" }
|
||||
{ DOUBLE "real" }
|
||||
|
@ -190,4 +187,3 @@ M: sqlite-db >sql-type ( obj -- str )
|
|||
! HOOK: get-column-value ( n result-set type -- )
|
||||
! M: sqlite get-column-value { { "TEXT" get-text-column } {
|
||||
! "INTEGER" get-integer-column } ... } case ;
|
||||
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.files kernel tools.test db db.sqlite db.tuples
|
||||
db.types continuations namespaces db.postgresql math
|
||||
tools.time ;
|
||||
db.types continuations namespaces db.postgresql math ;
|
||||
! tools.time ;
|
||||
IN: temporary
|
||||
|
||||
TUPLE: person the-id the-name the-number real ;
|
||||
|
@ -30,7 +30,8 @@ SYMBOL: the-person
|
|||
|
||||
[ ] [ the-person get update-tuple ] unit-test
|
||||
|
||||
[ ] [ the-person get delete-tuple ] unit-test ;
|
||||
[ ] [ the-person get delete-tuple ] unit-test
|
||||
[ ] [ person drop-table ] unit-test ;
|
||||
|
||||
: test-sqlite ( -- )
|
||||
"tuples-test.db" resource-path <sqlite-db> [
|
||||
|
@ -44,7 +45,7 @@ SYMBOL: the-person
|
|||
|
||||
person "PERSON"
|
||||
{
|
||||
{ "the-id" "ROWID" INTEGER +native-id+ }
|
||||
{ "the-id" "ID" SERIAL +native-id+ }
|
||||
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
|
||||
{ "the-number" "AGE" INTEGER { +default+ 0 } }
|
||||
{ "real" "REAL" DOUBLE { +default+ 0.3 } }
|
||||
|
@ -52,12 +53,12 @@ person "PERSON"
|
|||
|
||||
"billy" 10 3.14 <person> the-person set
|
||||
|
||||
test-sqlite
|
||||
! test-postgresql
|
||||
! test-sqlite
|
||||
test-postgresql
|
||||
|
||||
person "PERSON"
|
||||
{
|
||||
{ "the-id" "ROWID" INTEGER +assigned-id+ }
|
||||
{ "the-id" "ID" INTEGER +assigned-id+ }
|
||||
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
|
||||
{ "the-number" "AGE" INTEGER { +default+ 0 } }
|
||||
{ "real" "REAL" DOUBLE { +default+ 0.3 } }
|
||||
|
@ -65,5 +66,5 @@ person "PERSON"
|
|||
|
||||
1 "billy" 20 6.28 <assigned-person> the-person set
|
||||
|
||||
test-sqlite
|
||||
! test-sqlite
|
||||
! test-postgresql
|
||||
|
|
|
@ -38,8 +38,9 @@ TUPLE: no-slot-named ;
|
|||
[ db-table dupd ] swap
|
||||
[ <prepared-statement> ] 3compose cache nip ; inline
|
||||
|
||||
HOOK: create-sql db ( columns table -- sql )
|
||||
HOOK: drop-sql db ( table -- sql )
|
||||
HOOK: create-sql db ( columns table -- seq )
|
||||
HOOK: drop-sql db ( columns table -- seq )
|
||||
|
||||
HOOK: insert-sql* db ( columns table -- sql )
|
||||
HOOK: update-sql* db ( columns table -- sql )
|
||||
HOOK: delete-sql* db ( columns table -- sql )
|
||||
|
@ -75,12 +76,12 @@ HOOK: tuple>params db ( columns tuple -- obj )
|
|||
dup db-columns swap db-table create-sql sql-command ;
|
||||
|
||||
: drop-table ( class -- )
|
||||
db-table drop-sql sql-command ;
|
||||
dup db-columns swap db-table drop-sql sql-command ;
|
||||
|
||||
: insert-tuple ( tuple -- )
|
||||
[
|
||||
[ maybe-remove-id ] [ insert-sql ]
|
||||
make-tuple-statement execute-statement-last-id
|
||||
make-tuple-statement insert-statement
|
||||
] keep set-primary-key ;
|
||||
|
||||
: update-tuple ( tuple -- )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ;
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
|
@ -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
|
||||
|
|
|
@ -0,0 +1,2 @@
|
|||
Slava Pestov
|
||||
Jorge Acereda Macia
|
|
@ -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"
|
|
@ -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 ;
|
|
@ -0,0 +1 @@
|
|||
Disassemble words using gdb
|
|
@ -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"
|
||||
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -67,7 +67,7 @@ IN: unicode.data
|
|||
: process-combining ( data -- hash )
|
||||
3 swap (process-data)
|
||||
[ string>number ] assoc-map
|
||||
[ nip 0 = not ] assoc-subset
|
||||
[ nip zero? not ] assoc-subset
|
||||
>hashtable ;
|
||||
|
||||
: categories ( -- names )
|
||||
|
@ -93,13 +93,10 @@ IN: unicode.data
|
|||
: ascii-lower ( string -- lower )
|
||||
[ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ] map ;
|
||||
|
||||
: replace ( seq old new -- newseq )
|
||||
swap rot [ 2dup = [ drop over ] when ] map 2nip ;
|
||||
|
||||
: process-names ( data -- names-hash )
|
||||
1 swap (process-data)
|
||||
[ ascii-lower CHAR: \s CHAR: - replace swap ] assoc-map
|
||||
>hashtable ;
|
||||
1 swap (process-data) [
|
||||
ascii-lower { { CHAR: \s CHAR: - } } substitute swap
|
||||
] assoc-map >hashtable ;
|
||||
|
||||
: multihex ( hexstring -- string )
|
||||
" " split [ hex> ] map [ ] subset ;
|
||||
|
|
|
@ -1,4 +0,0 @@
|
|||
USING: unicode.syntax tools.test ;
|
||||
|
||||
[ CHAR: ! ] [ UNICHAR: exclamation-mark ] unit-test
|
||||
! Write a test for CATEGORY and CATEGORY-NOT
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue