Merge commit 'origin/master'
commit
c39ece54a1
|
@ -89,11 +89,6 @@ set_md5sum() {
|
||||||
set_gcc() {
|
set_gcc() {
|
||||||
case $OS in
|
case $OS in
|
||||||
openbsd) ensure_program_installed egcc; CC=egcc;;
|
openbsd) ensure_program_installed egcc; CC=egcc;;
|
||||||
netbsd) if [[ $WORD -eq 64 ]] ; then
|
|
||||||
CC=/usr/pkg/gcc34/bin/gcc
|
|
||||||
else
|
|
||||||
CC=gcc
|
|
||||||
fi ;;
|
|
||||||
*) CC=gcc;;
|
*) CC=gcc;;
|
||||||
esac
|
esac
|
||||||
}
|
}
|
||||||
|
|
|
@ -155,6 +155,9 @@ M: assoc >alist [ 2array ] { } assoc>map ;
|
||||||
: value-at ( value assoc -- key/f )
|
: value-at ( value assoc -- key/f )
|
||||||
swap [ = nip ] curry assoc-find 2drop ;
|
swap [ = nip ] curry assoc-find 2drop ;
|
||||||
|
|
||||||
|
: zip ( keys values -- alist )
|
||||||
|
2array flip ; inline
|
||||||
|
|
||||||
: search-alist ( key alist -- pair i )
|
: search-alist ( key alist -- pair i )
|
||||||
[ first = ] with find swap ; inline
|
[ first = ] with find swap ; inline
|
||||||
|
|
||||||
|
@ -204,7 +207,7 @@ M: enum set-at seq>> set-nth ;
|
||||||
M: enum delete-at enum-seq delete-nth ;
|
M: enum delete-at enum-seq delete-nth ;
|
||||||
|
|
||||||
M: enum >alist ( enum -- alist )
|
M: enum >alist ( enum -- alist )
|
||||||
seq>> [ length ] keep 2array flip ;
|
seq>> [ length ] keep zip ;
|
||||||
|
|
||||||
M: enum assoc-size seq>> length ;
|
M: enum assoc-size seq>> length ;
|
||||||
|
|
||||||
|
|
|
@ -737,6 +737,7 @@ define-builtin
|
||||||
{ "resize-bit-array" "bit-arrays" }
|
{ "resize-bit-array" "bit-arrays" }
|
||||||
{ "resize-float-array" "float-arrays" }
|
{ "resize-float-array" "float-arrays" }
|
||||||
{ "dll-valid?" "alien" }
|
{ "dll-valid?" "alien" }
|
||||||
|
{ "unimplemented" "kernel.private" }
|
||||||
}
|
}
|
||||||
dup length [ >r first2 r> make-primitive ] 2each
|
dup length [ >r first2 r> make-primitive ] 2each
|
||||||
|
|
||||||
|
|
|
@ -529,3 +529,12 @@ TUPLE: another-forget-accessors-test ;
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ t ] [ \ another-forget-accessors-test class? ] unit-test
|
[ t ] [ \ another-forget-accessors-test class? ] unit-test
|
||||||
|
|
||||||
|
! Shadowing test
|
||||||
|
[ f ] [
|
||||||
|
t parser-notes? [
|
||||||
|
[
|
||||||
|
"IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval
|
||||||
|
] with-string-writer empty?
|
||||||
|
] with-variable
|
||||||
|
] unit-test
|
||||||
|
|
|
@ -55,6 +55,9 @@ PRIVATE>
|
||||||
"slot-names" word-prop
|
"slot-names" word-prop
|
||||||
[ dup array? [ second ] when ] map ;
|
[ dup array? [ second ] when ] map ;
|
||||||
|
|
||||||
|
: all-slot-names ( class -- slots )
|
||||||
|
superclasses [ slot-names ] map concat \ class prefix ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: tuple= ( tuple1 tuple2 -- ? )
|
: tuple= ( tuple1 tuple2 -- ? )
|
||||||
|
@ -119,9 +122,6 @@ PRIVATE>
|
||||||
: define-tuple-layout ( class -- )
|
: define-tuple-layout ( class -- )
|
||||||
dup make-tuple-layout "layout" set-word-prop ;
|
dup make-tuple-layout "layout" set-word-prop ;
|
||||||
|
|
||||||
: all-slot-names ( class -- slots )
|
|
||||||
superclasses [ slot-names ] map concat \ class prefix ;
|
|
||||||
|
|
||||||
: compute-slot-permutation ( class old-slot-names -- permutation )
|
: compute-slot-permutation ( class old-slot-names -- permutation )
|
||||||
>r all-slot-names r> [ index ] curry map ;
|
>r all-slot-names r> [ index ] curry map ;
|
||||||
|
|
||||||
|
|
|
@ -59,6 +59,10 @@ ERROR: no-case ;
|
||||||
M: sequence hashcode*
|
M: sequence hashcode*
|
||||||
[ sequence-hashcode ] recursive-hashcode ;
|
[ sequence-hashcode ] recursive-hashcode ;
|
||||||
|
|
||||||
|
M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
|
||||||
|
|
||||||
|
M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
|
||||||
|
|
||||||
M: hashtable hashcode*
|
M: hashtable hashcode*
|
||||||
[
|
[
|
||||||
dup assoc-size 1 number=
|
dup assoc-size 1 number=
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel namespaces arrays sequences io inference.backend
|
USING: kernel namespaces arrays sequences io inference.backend
|
||||||
inference.state generator debugger math.parser prettyprint words
|
inference.state generator debugger words compiler.units
|
||||||
compiler.units continuations vocabs assocs alien.compiler dlists
|
continuations vocabs assocs alien.compiler dlists optimizer
|
||||||
optimizer definitions math compiler.errors threads graphs
|
definitions math compiler.errors threads graphs generic
|
||||||
generic inference ;
|
inference ;
|
||||||
IN: compiler
|
IN: compiler
|
||||||
|
|
||||||
: ripple-up ( word -- )
|
: ripple-up ( word -- )
|
||||||
|
|
|
@ -146,7 +146,7 @@ M: int-regs %save-param-reg drop 1 rot local@ STW ;
|
||||||
|
|
||||||
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
|
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
|
||||||
|
|
||||||
GENERIC: STF ( src dst reg-class -- )
|
GENERIC: STF ( src dst off reg-class -- )
|
||||||
|
|
||||||
M: single-float-regs STF drop STFS ;
|
M: single-float-regs STF drop STFS ;
|
||||||
|
|
||||||
|
@ -154,7 +154,7 @@ M: double-float-regs STF drop STFD ;
|
||||||
|
|
||||||
M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
|
M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
|
||||||
|
|
||||||
GENERIC: LF ( src dst reg-class -- )
|
GENERIC: LF ( dst src off reg-class -- )
|
||||||
|
|
||||||
M: single-float-regs LF drop LFS ;
|
M: single-float-regs LF drop LFS ;
|
||||||
|
|
||||||
|
|
|
@ -322,7 +322,7 @@ M: phantom-retainstack finalize-height
|
||||||
|
|
||||||
: (live-locs) ( phantom -- seq )
|
: (live-locs) ( phantom -- seq )
|
||||||
#! Discard locs which haven't moved
|
#! Discard locs which haven't moved
|
||||||
[ phantom-locs* ] [ stack>> ] bi 2array flip
|
[ phantom-locs* ] [ stack>> ] bi zip
|
||||||
[ live-loc? ] assoc-subset
|
[ live-loc? ] assoc-subset
|
||||||
values ;
|
values ;
|
||||||
|
|
||||||
|
@ -421,7 +421,7 @@ M: loc lazy-store
|
||||||
|
|
||||||
: slow-shuffle-mapping ( locs tmp -- pairs )
|
: slow-shuffle-mapping ( locs tmp -- pairs )
|
||||||
>r dup length r>
|
>r dup length r>
|
||||||
[ swap - <ds-loc> ] curry map 2array flip ;
|
[ swap - <ds-loc> ] curry map zip ;
|
||||||
|
|
||||||
: slow-shuffle ( locs -- )
|
: slow-shuffle ( locs -- )
|
||||||
#! We don't have enough free registers to load all shuffle
|
#! We don't have enough free registers to load all shuffle
|
||||||
|
|
|
@ -373,7 +373,7 @@ set-primitive-effect
|
||||||
\ data-room { } { integer array } <effect> set-primitive-effect
|
\ data-room { } { integer array } <effect> set-primitive-effect
|
||||||
\ data-room make-flushable
|
\ data-room make-flushable
|
||||||
|
|
||||||
\ code-room { } { integer integer } <effect> set-primitive-effect
|
\ code-room { } { integer integer integer integer } <effect> set-primitive-effect
|
||||||
\ code-room make-flushable
|
\ code-room make-flushable
|
||||||
|
|
||||||
\ os-env { string } { object } <effect> set-primitive-effect
|
\ os-env { string } { object } <effect> set-primitive-effect
|
||||||
|
@ -594,3 +594,5 @@ set-primitive-effect
|
||||||
\ dll-valid? { object } { object } <effect> set-primitive-effect
|
\ dll-valid? { object } { object } <effect> set-primitive-effect
|
||||||
|
|
||||||
\ modify-code-heap { array object } { } <effect> set-primitive-effect
|
\ modify-code-heap { array object } { } <effect> set-primitive-effect
|
||||||
|
|
||||||
|
\ unimplemented { } { } <effect> set-primitive-effect
|
||||||
|
|
|
@ -7,14 +7,15 @@ ARTICLE: "file-streams" "Reading and writing files"
|
||||||
{ $subsection <file-reader> }
|
{ $subsection <file-reader> }
|
||||||
{ $subsection <file-writer> }
|
{ $subsection <file-writer> }
|
||||||
{ $subsection <file-appender> }
|
{ $subsection <file-appender> }
|
||||||
|
"Reading and writing the entire contents of a file; this is only recommended for smaller files:"
|
||||||
|
{ $subsection file-contents }
|
||||||
|
{ $subsection set-file-contents }
|
||||||
|
{ $subsection file-lines }
|
||||||
|
{ $subsection set-file-lines }
|
||||||
"Utility combinators:"
|
"Utility combinators:"
|
||||||
{ $subsection with-file-reader }
|
{ $subsection with-file-reader }
|
||||||
{ $subsection with-file-writer }
|
{ $subsection with-file-writer }
|
||||||
{ $subsection with-file-appender }
|
{ $subsection with-file-appender } ;
|
||||||
{ $subsection set-file-contents }
|
|
||||||
{ $subsection file-contents }
|
|
||||||
{ $subsection set-file-lines }
|
|
||||||
{ $subsection file-lines } ;
|
|
||||||
|
|
||||||
ARTICLE: "pathnames" "Pathname manipulation"
|
ARTICLE: "pathnames" "Pathname manipulation"
|
||||||
"Pathname manipulation:"
|
"Pathname manipulation:"
|
||||||
|
|
|
@ -108,3 +108,12 @@ IN: kernel.tests
|
||||||
H{ } values swap >r dup length swap r> 0 -roll (loop) ;
|
H{ } values swap >r dup length swap r> 0 -roll (loop) ;
|
||||||
|
|
||||||
[ loop ] must-fail
|
[ loop ] must-fail
|
||||||
|
|
||||||
|
! Discovered on Windows
|
||||||
|
: total-failure-1 "" [ ] map unimplemented ;
|
||||||
|
|
||||||
|
[ total-failure-1 ] must-fail
|
||||||
|
|
||||||
|
: total-failure-2 [ ] (call) unimplemented ;
|
||||||
|
|
||||||
|
[ total-failure-2 ] must-fail
|
||||||
|
|
|
@ -42,7 +42,7 @@ M: mirror delete-at ( key mirror -- )
|
||||||
M: mirror >alist ( mirror -- alist )
|
M: mirror >alist ( mirror -- alist )
|
||||||
>mirror<
|
>mirror<
|
||||||
[ [ slot-spec-offset slot ] with map ] keep
|
[ [ slot-spec-offset slot ] with map ] keep
|
||||||
[ slot-spec-name ] map swap 2array flip ;
|
[ slot-spec-name ] map swap zip ;
|
||||||
|
|
||||||
M: mirror assoc-size mirror-slots length ;
|
M: mirror assoc-size mirror-slots length ;
|
||||||
|
|
||||||
|
|
|
@ -370,4 +370,7 @@ HINTS: recursive-inline-hang-2 array ;
|
||||||
|
|
||||||
HINTS: recursive-inline-hang-3 array ;
|
HINTS: recursive-inline-hang-3 array ;
|
||||||
|
|
||||||
|
! Regression
|
||||||
|
USE: sequences.private
|
||||||
|
|
||||||
|
[ ] [ { (3append) } compile ] unit-test
|
||||||
|
|
|
@ -153,6 +153,8 @@ ARTICLE: "parser-files" "Parsing source files"
|
||||||
{ $subsection parse-file }
|
{ $subsection parse-file }
|
||||||
{ $subsection bootstrap-file }
|
{ $subsection bootstrap-file }
|
||||||
"The parser cross-references source files and definitions. This allows it to keep track of removed definitions, and prevent forward references and accidental redefinitions."
|
"The parser cross-references source files and definitions. This allows it to keep track of removed definitions, and prevent forward references and accidental redefinitions."
|
||||||
|
$nl
|
||||||
|
"While the above words are useful for one-off experiments, real programs should be written to use the vocabulary system instead; see " { $link "vocabs.loader" } "."
|
||||||
{ $see-also "source-files" } ;
|
{ $see-also "source-files" } ;
|
||||||
|
|
||||||
ARTICLE: "parser-usage" "Reflective parser usage"
|
ARTICLE: "parser-usage" "Reflective parser usage"
|
||||||
|
@ -161,6 +163,13 @@ ARTICLE: "parser-usage" "Reflective parser usage"
|
||||||
"The parser can also parse from a stream:"
|
"The parser can also parse from a stream:"
|
||||||
{ $subsection parse-stream } ;
|
{ $subsection parse-stream } ;
|
||||||
|
|
||||||
|
ARTICLE: "top-level-forms" "Top level forms"
|
||||||
|
"Any code outside of a definition is known as a " { $emphasis "top-level form" } "; top-level forms are run after the entire source file has been parsed, regardless of their position in the file."
|
||||||
|
$nl
|
||||||
|
"Top-level forms do not have access to the " { $link in } " and " { $link use } " variables that were set at parse time, nor do they run inside " { $link with-compilation-unit } "; so meta-programming might require extra work in a top-level form compared with a parsing word."
|
||||||
|
$nl
|
||||||
|
"Also, top-level forms run in a new dynamic scope, so using " { $link set } " to store values is almost always wrong, since the values will be lost after the top-level form completes. To save values computed by a top-level form, either use " { $link set-global } " or define a new word with the value." ;
|
||||||
|
|
||||||
ARTICLE: "parser" "The parser"
|
ARTICLE: "parser" "The parser"
|
||||||
"This parser is a general facility for reading textual representations of objects and definitions. The parser is implemented in the " { $vocab-link "parser" } " and " { $vocab-link "syntax" } " vocabularies."
|
"This parser is a general facility for reading textual representations of objects and definitions. The parser is implemented in the " { $vocab-link "parser" } " and " { $vocab-link "syntax" } " vocabularies."
|
||||||
$nl
|
$nl
|
||||||
|
@ -168,6 +177,7 @@ $nl
|
||||||
{ $subsection "vocabulary-search" }
|
{ $subsection "vocabulary-search" }
|
||||||
{ $subsection "parser-files" }
|
{ $subsection "parser-files" }
|
||||||
{ $subsection "parser-usage" }
|
{ $subsection "parser-usage" }
|
||||||
|
{ $subsection "top-level-forms" }
|
||||||
"The parser can be extended."
|
"The parser can be extended."
|
||||||
{ $subsection "parsing-words" }
|
{ $subsection "parsing-words" }
|
||||||
{ $subsection "parser-lexer" }
|
{ $subsection "parser-lexer" }
|
||||||
|
@ -284,10 +294,6 @@ HELP: use
|
||||||
HELP: in
|
HELP: in
|
||||||
{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ;
|
{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ;
|
||||||
|
|
||||||
HELP: shadow-warnings
|
|
||||||
{ $values { "vocab" "an assoc mapping strings to words" } { "vocabs" "a sequence of assocs" } }
|
|
||||||
{ $description "Tests if any keys in " { $snippet "vocab" } " shadow keys in the elements of " { $snippet "vocabs" } ", and if so, prints a warning message. These warning messages can be disabled by setting " { $link parser-notes } " to " { $link f } "." } ;
|
|
||||||
|
|
||||||
HELP: (use+)
|
HELP: (use+)
|
||||||
{ $values { "vocab" "an assoc mapping strings to words" } }
|
{ $values { "vocab" "an assoc mapping strings to words" } }
|
||||||
{ $description "Adds an assoc at the front of the search path." }
|
{ $description "Adds an assoc at the front of the search path." }
|
||||||
|
|
|
@ -1,12 +1,11 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays definitions generic assocs kernel math
|
USING: arrays definitions generic assocs kernel math namespaces
|
||||||
namespaces prettyprint sequences strings vectors words
|
prettyprint sequences strings vectors words quotations inspector
|
||||||
quotations inspector io.styles io combinators sorting
|
io.styles io combinators sorting splitting math.parser effects
|
||||||
splitting math.parser effects continuations debugger
|
continuations debugger io.files io.streams.string vocabs
|
||||||
io.files io.streams.string vocabs io.encodings.utf8
|
io.encodings.utf8 source-files classes classes.tuple hashtables
|
||||||
source-files classes hashtables compiler.errors compiler.units
|
compiler.errors compiler.units accessors ;
|
||||||
accessors ;
|
|
||||||
IN: parser
|
IN: parser
|
||||||
|
|
||||||
TUPLE: lexer text line line-text line-length column ;
|
TUPLE: lexer text line line-text line-length column ;
|
||||||
|
@ -191,22 +190,8 @@ SYMBOL: in
|
||||||
: word/vocab% ( word -- )
|
: word/vocab% ( word -- )
|
||||||
"(" % dup word-vocabulary % " " % word-name % ")" % ;
|
"(" % dup word-vocabulary % " " % word-name % ")" % ;
|
||||||
|
|
||||||
: shadow-warning ( new old -- )
|
|
||||||
2dup eq? [
|
|
||||||
2drop
|
|
||||||
] [
|
|
||||||
[ word/vocab% " shadowed by " % word/vocab% ] "" make
|
|
||||||
note.
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: shadow-warnings ( vocab vocabs -- )
|
|
||||||
[
|
|
||||||
swapd assoc-stack dup
|
|
||||||
[ shadow-warning ] [ 2drop ] if
|
|
||||||
] curry assoc-each ;
|
|
||||||
|
|
||||||
: (use+) ( vocab -- )
|
: (use+) ( vocab -- )
|
||||||
vocab-words use get 2dup shadow-warnings push ;
|
vocab-words use get push ;
|
||||||
|
|
||||||
: use+ ( vocab -- )
|
: use+ ( vocab -- )
|
||||||
load-vocab (use+) ;
|
load-vocab (use+) ;
|
||||||
|
@ -299,13 +284,27 @@ M: no-word-error summary
|
||||||
: CREATE-METHOD ( -- method )
|
: CREATE-METHOD ( -- method )
|
||||||
scan-word bootstrap-word scan-word create-method-in ;
|
scan-word bootstrap-word scan-word create-method-in ;
|
||||||
|
|
||||||
|
: shadowed-slots ( superclass slots -- shadowed )
|
||||||
|
>r all-slot-names r> seq-intersect ;
|
||||||
|
|
||||||
|
: check-slot-shadowing ( class superclass slots -- )
|
||||||
|
shadowed-slots [
|
||||||
|
[
|
||||||
|
"Definition of slot ``" %
|
||||||
|
%
|
||||||
|
"'' in class ``" %
|
||||||
|
word-name %
|
||||||
|
"'' shadows a superclass slot" %
|
||||||
|
] "" make note.
|
||||||
|
] with each ;
|
||||||
|
|
||||||
: parse-tuple-definition ( -- class superclass slots )
|
: parse-tuple-definition ( -- class superclass slots )
|
||||||
CREATE-CLASS
|
CREATE-CLASS
|
||||||
scan {
|
scan {
|
||||||
{ ";" [ tuple f ] }
|
{ ";" [ tuple f ] }
|
||||||
{ "<" [ scan-word ";" parse-tokens ] }
|
{ "<" [ scan-word ";" parse-tokens ] }
|
||||||
[ >r tuple ";" parse-tokens r> prefix ]
|
[ >r tuple ";" parse-tokens r> prefix ]
|
||||||
} case ;
|
} case 3dup check-slot-shadowing ;
|
||||||
|
|
||||||
ERROR: staging-violation word ;
|
ERROR: staging-violation word ;
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: arrays kernel math namespaces sequences kernel.private
|
USING: arrays kernel math namespaces sequences kernel.private
|
||||||
sequences.private strings sbufs tools.test vectors bit-arrays
|
sequences.private strings sbufs tools.test vectors bit-arrays
|
||||||
generic ;
|
generic vocabs.loader ;
|
||||||
IN: sequences.tests
|
IN: sequences.tests
|
||||||
|
|
||||||
[ V{ 1 2 3 4 } ] [ 1 5 dup <slice> >vector ] unit-test
|
[ V{ 1 2 3 4 } ] [ 1 5 dup <slice> >vector ] unit-test
|
||||||
|
@ -100,6 +100,16 @@ unit-test
|
||||||
[ [ ] ] [ [ 1 2 3 ] 3 tail ] unit-test
|
[ [ ] ] [ [ 1 2 3 ] 3 tail ] unit-test
|
||||||
[ [ 3 ] ] [ [ 1 2 3 ] 2 tail ] unit-test
|
[ [ 3 ] ] [ [ 1 2 3 ] 2 tail ] unit-test
|
||||||
|
|
||||||
|
[ "blah" ] [ "blahxx" 2 head* ] unit-test
|
||||||
|
|
||||||
|
[ "xx" ] [ "blahxx" 2 tail* ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice = ] unit-test
|
||||||
|
[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice [ hashcode ] bi@ = ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* = ] unit-test
|
||||||
|
[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* [ hashcode ] bi@ = ] unit-test
|
||||||
|
|
||||||
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] sequence= ] unit-test
|
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] sequence= ] unit-test
|
||||||
[ t ] [ [ 1 2 3 ] { 1 2 3 } sequence= ] unit-test
|
[ t ] [ [ 1 2 3 ] { 1 2 3 } sequence= ] unit-test
|
||||||
[ t ] [ { 1 2 3 } [ 1 2 3 ] sequence= ] unit-test
|
[ t ] [ { 1 2 3 } [ 1 2 3 ] sequence= ] unit-test
|
||||||
|
@ -195,6 +205,12 @@ unit-test
|
||||||
! Pathological case
|
! Pathological case
|
||||||
[ "ihbye" ] [ "hi" <reversed> "bye" append ] unit-test
|
[ "ihbye" ] [ "hi" <reversed> "bye" append ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ "hi" <reversed> SBUF" hi" <reversed> = ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ "hi" <reversed> SBUF" hi" <reversed> = ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ "hi" <reversed> SBUF" hi" <reversed> [ hashcode ] bi@ = ] unit-test
|
||||||
|
|
||||||
[ -10 "hi" "bye" copy ] must-fail
|
[ -10 "hi" "bye" copy ] must-fail
|
||||||
[ 10 "hi" "bye" copy ] must-fail
|
[ 10 "hi" "bye" copy ] must-fail
|
||||||
|
|
||||||
|
@ -244,3 +260,5 @@ unit-test
|
||||||
[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
|
[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
|
||||||
[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test
|
[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test
|
||||||
|
|
||||||
|
! Hardcore
|
||||||
|
[ ] [ "sequences" reload ] unit-test
|
||||||
|
|
|
@ -172,7 +172,9 @@ TUPLE: reversed seq ;
|
||||||
C: <reversed> reversed
|
C: <reversed> reversed
|
||||||
|
|
||||||
M: reversed virtual-seq reversed-seq ;
|
M: reversed virtual-seq reversed-seq ;
|
||||||
|
|
||||||
M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ;
|
M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ;
|
||||||
|
|
||||||
M: reversed length reversed-seq length ;
|
M: reversed length reversed-seq length ;
|
||||||
|
|
||||||
INSTANCE: reversed virtual-sequence
|
INSTANCE: reversed virtual-sequence
|
||||||
|
@ -198,7 +200,9 @@ ERROR: slice-error reason ;
|
||||||
slice construct-boa ; inline
|
slice construct-boa ; inline
|
||||||
|
|
||||||
M: slice virtual-seq slice-seq ;
|
M: slice virtual-seq slice-seq ;
|
||||||
|
|
||||||
M: slice virtual@ [ slice-from + ] keep slice-seq ;
|
M: slice virtual@ [ slice-from + ] keep slice-seq ;
|
||||||
|
|
||||||
M: slice length dup slice-to swap slice-from - ;
|
M: slice length dup slice-to swap slice-from - ;
|
||||||
|
|
||||||
: head-slice ( seq n -- slice ) (head) <slice> ;
|
: head-slice ( seq n -- slice ) (head) <slice> ;
|
||||||
|
@ -466,6 +470,21 @@ M: sequence <=>
|
||||||
2dup [ length ] bi@ number=
|
2dup [ length ] bi@ number=
|
||||||
[ mismatch not ] [ 2drop f ] if ; inline
|
[ mismatch not ] [ 2drop f ] if ; inline
|
||||||
|
|
||||||
|
: sequence-hashcode-step ( oldhash newpart -- newhash )
|
||||||
|
swap [
|
||||||
|
dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
|
||||||
|
fixnum+fast fixnum+fast
|
||||||
|
] keep fixnum-bitxor ; inline
|
||||||
|
|
||||||
|
: sequence-hashcode ( n seq -- x )
|
||||||
|
0 -rot [
|
||||||
|
hashcode* >fixnum sequence-hashcode-step
|
||||||
|
] with each ; inline
|
||||||
|
|
||||||
|
M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
||||||
|
|
||||||
: move ( to from seq -- )
|
: move ( to from seq -- )
|
||||||
2over number=
|
2over number=
|
||||||
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
|
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
|
||||||
|
@ -692,14 +711,3 @@ PRIVATE>
|
||||||
dup [ length ] map infimum
|
dup [ length ] map infimum
|
||||||
[ <column> dup like ] with map
|
[ <column> dup like ] with map
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
||||||
: sequence-hashcode-step ( oldhash newpart -- newhash )
|
|
||||||
swap [
|
|
||||||
dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
|
|
||||||
fixnum+fast fixnum+fast
|
|
||||||
] keep fixnum-bitxor ; inline
|
|
||||||
|
|
||||||
: sequence-hashcode ( n seq -- x )
|
|
||||||
0 -rot [
|
|
||||||
hashcode* >fixnum sequence-hashcode-step
|
|
||||||
] with each ; inline
|
|
||||||
|
|
|
@ -37,9 +37,6 @@ IN: assocs.lib
|
||||||
|
|
||||||
: insert ( value variable -- ) namespace insert-at ;
|
: insert ( value variable -- ) namespace insert-at ;
|
||||||
|
|
||||||
: 2seq>assoc ( keys values exemplar -- assoc )
|
|
||||||
>r 2array flip r> assoc-like ;
|
|
||||||
|
|
||||||
: generate-key ( assoc -- str )
|
: generate-key ( assoc -- str )
|
||||||
>r 256 random-bits >hex r>
|
>r 256 random-bits >hex r>
|
||||||
2dup key? [ nip generate-key ] [ drop ] if ;
|
2dup key? [ nip generate-key ] [ drop ] if ;
|
||||||
|
|
|
@ -106,7 +106,7 @@ IN: builder
|
||||||
+closed+ >>stdin
|
+closed+ >>stdin
|
||||||
"../test-log" >>stdout
|
"../test-log" >>stdout
|
||||||
+stdout+ >>stderr
|
+stdout+ >>stderr
|
||||||
120 minutes >>timeout ;
|
240 minutes >>timeout ;
|
||||||
|
|
||||||
: do-builder-test ( -- )
|
: do-builder-test ( -- )
|
||||||
builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;
|
builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;
|
||||||
|
|
|
@ -11,14 +11,19 @@ TUPLE: db
|
||||||
update-statements
|
update-statements
|
||||||
delete-statements ;
|
delete-statements ;
|
||||||
|
|
||||||
: <db> ( handle -- obj )
|
: construct-db ( class -- obj )
|
||||||
H{ } clone H{ } clone H{ } clone
|
construct-empty
|
||||||
db construct-boa ;
|
H{ } clone >>insert-statements
|
||||||
|
H{ } clone >>update-statements
|
||||||
|
H{ } clone >>delete-statements ;
|
||||||
|
|
||||||
GENERIC: make-db* ( seq class -- db )
|
GENERIC: make-db* ( seq class -- db )
|
||||||
GENERIC: db-open ( db -- )
|
|
||||||
|
: make-db ( seq class -- db )
|
||||||
|
construct-db make-db* ;
|
||||||
|
|
||||||
|
GENERIC: db-open ( db -- db )
|
||||||
HOOK: db-close db ( handle -- )
|
HOOK: db-close db ( handle -- )
|
||||||
: make-db ( seq class -- db ) construct-empty make-db* ;
|
|
||||||
|
|
||||||
: dispose-statements ( seq -- ) [ dispose drop ] assoc-each ;
|
: dispose-statements ( seq -- ) [ dispose drop ] assoc-each ;
|
||||||
|
|
||||||
|
@ -30,10 +35,13 @@ HOOK: db-close db ( handle -- )
|
||||||
handle>> db-close
|
handle>> db-close
|
||||||
] with-variable ;
|
] with-variable ;
|
||||||
|
|
||||||
|
! TUPLE: sql sql in-params out-params ;
|
||||||
TUPLE: statement handle sql in-params out-params bind-params bound? ;
|
TUPLE: statement handle sql in-params out-params bind-params bound? ;
|
||||||
TUPLE: simple-statement ;
|
TUPLE: simple-statement < statement ;
|
||||||
TUPLE: prepared-statement ;
|
TUPLE: prepared-statement < statement ;
|
||||||
TUPLE: nonthrowable-statement ;
|
TUPLE: nonthrowable-statement < statement ;
|
||||||
|
TUPLE: throwable-statement < statement ;
|
||||||
|
|
||||||
: make-nonthrowable ( obj -- obj' )
|
: make-nonthrowable ( obj -- obj' )
|
||||||
dup sequence? [
|
dup sequence? [
|
||||||
[ make-nonthrowable ] map
|
[ make-nonthrowable ] map
|
||||||
|
@ -41,14 +49,13 @@ TUPLE: nonthrowable-statement ;
|
||||||
nonthrowable-statement construct-delegate
|
nonthrowable-statement construct-delegate
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
MIXIN: throwable-statement
|
|
||||||
INSTANCE: statement throwable-statement
|
|
||||||
INSTANCE: simple-statement throwable-statement
|
|
||||||
INSTANCE: prepared-statement throwable-statement
|
|
||||||
|
|
||||||
TUPLE: result-set sql in-params out-params handle n max ;
|
TUPLE: result-set sql in-params out-params handle n max ;
|
||||||
: <statement> ( sql in out -- statement )
|
|
||||||
{ (>>sql) (>>in-params) (>>out-params) } statement construct ;
|
: construct-statement ( sql in out class -- statement )
|
||||||
|
construct-empty
|
||||||
|
swap >>out-params
|
||||||
|
swap >>in-params
|
||||||
|
swap >>sql ;
|
||||||
|
|
||||||
HOOK: <simple-statement> db ( str in out -- statement )
|
HOOK: <simple-statement> db ( str in out -- statement )
|
||||||
HOOK: <prepared-statement> db ( str in out -- statement )
|
HOOK: <prepared-statement> db ( str in out -- statement )
|
||||||
|
@ -88,11 +95,14 @@ M: nonthrowable-statement execute-statement ( statement -- )
|
||||||
dup #rows >>max
|
dup #rows >>max
|
||||||
0 >>n drop ;
|
0 >>n drop ;
|
||||||
|
|
||||||
: <result-set> ( query handle tuple -- result-set )
|
: construct-result-set ( query handle class -- result-set )
|
||||||
>r >r { sql>> in-params>> out-params>> } get-slots r>
|
construct-empty
|
||||||
{ (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set
|
swap >>handle
|
||||||
construct r> construct-delegate ;
|
>r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
|
||||||
|
swap >>out-params
|
||||||
|
swap >>in-params
|
||||||
|
swap >>sql ;
|
||||||
|
|
||||||
: sql-row ( result-set -- seq )
|
: sql-row ( result-set -- seq )
|
||||||
dup #columns [ row-column ] with map ;
|
dup #columns [ row-column ] with map ;
|
||||||
|
|
||||||
|
@ -110,7 +120,7 @@ M: nonthrowable-statement execute-statement ( statement -- )
|
||||||
accumulator >r query-each r> { } like ; inline
|
accumulator >r query-each r> { } like ; inline
|
||||||
|
|
||||||
: with-db ( db seq quot -- )
|
: with-db ( db seq quot -- )
|
||||||
>r make-db dup db-open db r>
|
>r make-db db-open db r>
|
||||||
[ db get swap [ drop ] swap compose with-disposal ] curry with-variable ;
|
[ db get swap [ drop ] swap compose with-disposal ] curry with-variable ;
|
||||||
|
|
||||||
: default-query ( query -- result-set )
|
: default-query ( query -- result-set )
|
||||||
|
|
|
@ -6,7 +6,8 @@ IN: db.postgresql.ffi
|
||||||
|
|
||||||
<< "postgresql" {
|
<< "postgresql" {
|
||||||
{ [ os winnt? ] [ "libpq.dll" ] }
|
{ [ os winnt? ] [ "libpq.dll" ] }
|
||||||
{ [ os macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] }
|
{ [ os macosx? ] [ "/opt/local/lib/postgresql83/libpq.dylib" ] }
|
||||||
|
! { [ os macosx? ] [ "libpq.dylib" ] }
|
||||||
{ [ os unix? ] [ "libpq.so" ] }
|
{ [ os unix? ] [ "libpq.so" ] }
|
||||||
} cond "cdecl" add-library >>
|
} cond "cdecl" add-library >>
|
||||||
|
|
||||||
|
|
|
@ -5,40 +5,39 @@ kernel math math.parser namespaces prettyprint quotations
|
||||||
sequences debugger db db.postgresql.lib db.postgresql.ffi
|
sequences debugger db db.postgresql.lib db.postgresql.ffi
|
||||||
db.tuples db.types tools.annotations math.ranges
|
db.tuples db.types tools.annotations math.ranges
|
||||||
combinators sequences.lib classes locals words tools.walker
|
combinators sequences.lib classes locals words tools.walker
|
||||||
namespaces.lib ;
|
namespaces.lib accessors ;
|
||||||
IN: db.postgresql
|
IN: db.postgresql
|
||||||
|
|
||||||
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
|
TUPLE: postgresql-db < db
|
||||||
TUPLE: postgresql-statement ;
|
host port pgopts pgtty db user pass ;
|
||||||
INSTANCE: postgresql-statement throwable-statement
|
|
||||||
TUPLE: postgresql-result-set ;
|
TUPLE: postgresql-statement < throwable-statement ;
|
||||||
|
|
||||||
|
TUPLE: postgresql-result-set < result-set ;
|
||||||
|
|
||||||
: <postgresql-statement> ( statement in out -- postgresql-statement )
|
: <postgresql-statement> ( statement in out -- postgresql-statement )
|
||||||
<statement>
|
postgresql-statement construct-statement ;
|
||||||
postgresql-statement construct-delegate ;
|
|
||||||
|
|
||||||
M: postgresql-db make-db* ( seq tuple -- db )
|
M: postgresql-db make-db* ( seq tuple -- db )
|
||||||
>r first4 r> [
|
>r first4 r>
|
||||||
{
|
swap >>db
|
||||||
set-postgresql-db-host
|
swap >>pass
|
||||||
set-postgresql-db-user
|
swap >>user
|
||||||
set-postgresql-db-pass
|
swap >>host ;
|
||||||
set-postgresql-db-db
|
|
||||||
} set-slots
|
|
||||||
] keep ;
|
|
||||||
|
|
||||||
M: postgresql-db db-open ( db -- )
|
M: postgresql-db db-open ( db -- db )
|
||||||
dup {
|
dup {
|
||||||
postgresql-db-host
|
[ host>> ]
|
||||||
postgresql-db-port
|
[ port>> ]
|
||||||
postgresql-db-pgopts
|
[ pgopts>> ]
|
||||||
postgresql-db-pgtty
|
[ pgtty>> ]
|
||||||
postgresql-db-db
|
[ db>> ]
|
||||||
postgresql-db-user
|
[ user>> ]
|
||||||
postgresql-db-pass
|
[ pass>> ]
|
||||||
} get-slots connect-postgres <db> swap set-delegate ;
|
} cleave connect-postgres >>handle ;
|
||||||
|
|
||||||
M: postgresql-db dispose ( db -- )
|
M: postgresql-db dispose ( db -- )
|
||||||
db-handle PQfinish ;
|
handle>> PQfinish ;
|
||||||
|
|
||||||
M: postgresql-statement bind-statement* ( statement -- )
|
M: postgresql-statement bind-statement* ( statement -- )
|
||||||
drop ;
|
drop ;
|
||||||
|
@ -50,10 +49,10 @@ M: postgresql-statement bind-tuple ( tuple statement -- )
|
||||||
] keep set-statement-bind-params ;
|
] keep set-statement-bind-params ;
|
||||||
|
|
||||||
M: postgresql-result-set #rows ( result-set -- n )
|
M: postgresql-result-set #rows ( result-set -- n )
|
||||||
result-set-handle PQntuples ;
|
handle>> PQntuples ;
|
||||||
|
|
||||||
M: postgresql-result-set #columns ( result-set -- n )
|
M: postgresql-result-set #columns ( result-set -- n )
|
||||||
result-set-handle PQnfields ;
|
handle>> PQnfields ;
|
||||||
|
|
||||||
M: postgresql-result-set row-column ( result-set column -- obj )
|
M: postgresql-result-set row-column ( result-set column -- obj )
|
||||||
>r dup result-set-handle swap result-set-n r> pq-get-string ;
|
>r dup result-set-handle swap result-set-n r> pq-get-string ;
|
||||||
|
@ -69,7 +68,7 @@ M: postgresql-statement query-results ( query -- result-set )
|
||||||
] [
|
] [
|
||||||
dup do-postgresql-statement
|
dup do-postgresql-statement
|
||||||
] if*
|
] if*
|
||||||
postgresql-result-set <result-set>
|
postgresql-result-set construct-result-set
|
||||||
dup init-result-set ;
|
dup init-result-set ;
|
||||||
|
|
||||||
M: postgresql-result-set advance-row ( result-set -- )
|
M: postgresql-result-set advance-row ( result-set -- )
|
||||||
|
@ -90,7 +89,7 @@ M: postgresql-result-set dispose ( result-set -- )
|
||||||
|
|
||||||
M: postgresql-statement prepare-statement ( statement -- )
|
M: postgresql-statement prepare-statement ( statement -- )
|
||||||
[
|
[
|
||||||
>r db get db-handle "" r>
|
>r db get handle>> "" r>
|
||||||
dup statement-sql swap statement-in-params
|
dup statement-sql swap statement-in-params
|
||||||
length f PQprepare postgresql-error
|
length f PQprepare postgresql-error
|
||||||
] keep set-statement-handle ;
|
] keep set-statement-handle ;
|
||||||
|
|
|
@ -5,61 +5,48 @@ hashtables io.files kernel math math.parser namespaces
|
||||||
prettyprint sequences strings classes.tuple alien.c-types
|
prettyprint sequences strings classes.tuple alien.c-types
|
||||||
continuations db.sqlite.lib db.sqlite.ffi db.tuples
|
continuations db.sqlite.lib db.sqlite.ffi db.tuples
|
||||||
words combinators.lib db.types combinators
|
words combinators.lib db.types combinators
|
||||||
io namespaces.lib ;
|
io namespaces.lib accessors ;
|
||||||
USE: tools.walker
|
|
||||||
IN: db.sqlite
|
IN: db.sqlite
|
||||||
|
|
||||||
TUPLE: sqlite-db path ;
|
TUPLE: sqlite-db < db path ;
|
||||||
|
|
||||||
M: sqlite-db make-db* ( path db -- db )
|
M: sqlite-db make-db* ( path db -- db )
|
||||||
[ set-sqlite-db-path ] keep ;
|
swap >>path ;
|
||||||
|
|
||||||
M: sqlite-db db-open ( db -- )
|
M: sqlite-db db-open ( db -- db )
|
||||||
dup sqlite-db-path sqlite-open <db>
|
[ path>> sqlite-open ] [ swap >>handle ] bi ;
|
||||||
swap set-delegate ;
|
|
||||||
|
|
||||||
M: sqlite-db db-close ( handle -- ) sqlite-close ;
|
M: sqlite-db db-close ( handle -- ) sqlite-close ;
|
||||||
M: sqlite-db dispose ( db -- ) dispose-db ;
|
M: sqlite-db dispose ( db -- ) dispose-db ;
|
||||||
: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
|
|
||||||
|
|
||||||
TUPLE: sqlite-statement ;
|
TUPLE: sqlite-statement < throwable-statement ;
|
||||||
INSTANCE: sqlite-statement throwable-statement
|
|
||||||
|
|
||||||
TUPLE: sqlite-result-set has-more? ;
|
TUPLE: sqlite-result-set < result-set has-more? ;
|
||||||
|
|
||||||
M: sqlite-db <simple-statement> ( str in out -- obj )
|
M: sqlite-db <simple-statement> ( str in out -- obj )
|
||||||
<prepared-statement> ;
|
<prepared-statement> ;
|
||||||
|
|
||||||
M: sqlite-db <prepared-statement> ( str in out -- obj )
|
M: sqlite-db <prepared-statement> ( str in out -- obj )
|
||||||
{
|
sqlite-statement construct-statement ;
|
||||||
set-statement-sql
|
|
||||||
set-statement-in-params
|
|
||||||
set-statement-out-params
|
|
||||||
} statement construct
|
|
||||||
sqlite-statement construct-delegate ;
|
|
||||||
|
|
||||||
: sqlite-maybe-prepare ( statement -- statement )
|
: sqlite-maybe-prepare ( statement -- statement )
|
||||||
dup statement-handle [
|
dup handle>> [
|
||||||
[
|
db get handle>> over sql>> sqlite-prepare
|
||||||
delegate
|
>>handle
|
||||||
db get db-handle over statement-sql sqlite-prepare
|
|
||||||
swap set-statement-handle
|
|
||||||
] keep
|
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
||||||
M: sqlite-statement dispose ( statement -- )
|
M: sqlite-statement dispose ( statement -- )
|
||||||
statement-handle
|
handle>>
|
||||||
[ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
|
[ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
|
||||||
|
|
||||||
M: sqlite-result-set dispose ( result-set -- )
|
M: sqlite-result-set dispose ( result-set -- )
|
||||||
f swap set-result-set-handle ;
|
f >>handle drop ;
|
||||||
|
|
||||||
: sqlite-bind ( triples handle -- )
|
: sqlite-bind ( triples handle -- )
|
||||||
swap [ first3 sqlite-bind-type ] with each ;
|
swap [ first3 sqlite-bind-type ] with each ;
|
||||||
|
|
||||||
: reset-statement ( statement -- )
|
: reset-statement ( statement -- )
|
||||||
sqlite-maybe-prepare
|
sqlite-maybe-prepare handle>> sqlite-reset ;
|
||||||
statement-handle sqlite-reset ;
|
|
||||||
|
|
||||||
M: sqlite-statement bind-statement* ( statement -- )
|
M: sqlite-statement bind-statement* ( statement -- )
|
||||||
sqlite-maybe-prepare
|
sqlite-maybe-prepare
|
||||||
|
@ -69,11 +56,11 @@ M: sqlite-statement bind-statement* ( statement -- )
|
||||||
|
|
||||||
M: sqlite-statement bind-tuple ( tuple statement -- )
|
M: sqlite-statement bind-tuple ( tuple statement -- )
|
||||||
[
|
[
|
||||||
statement-in-params
|
in-params>>
|
||||||
[
|
[
|
||||||
[ sql-spec-column-name ":" prepend ]
|
[ column-name>> ":" prepend ]
|
||||||
[ sql-spec-slot-name rot get-slot-named ]
|
[ slot-name>> rot get-slot-named ]
|
||||||
[ sql-spec-type ] tri 3array
|
[ type>> ] tri 3array
|
||||||
] with map
|
] with map
|
||||||
] keep
|
] keep
|
||||||
bind-statement ;
|
bind-statement ;
|
||||||
|
@ -86,25 +73,24 @@ M: sqlite-db insert-tuple* ( tuple statement -- )
|
||||||
execute-statement last-insert-id swap set-primary-key ;
|
execute-statement last-insert-id swap set-primary-key ;
|
||||||
|
|
||||||
M: sqlite-result-set #columns ( result-set -- n )
|
M: sqlite-result-set #columns ( result-set -- n )
|
||||||
result-set-handle sqlite-#columns ;
|
handle>> sqlite-#columns ;
|
||||||
|
|
||||||
M: sqlite-result-set row-column ( result-set n -- obj )
|
M: sqlite-result-set row-column ( result-set n -- obj )
|
||||||
>r result-set-handle r> sqlite-column ;
|
[ handle>> ] [ sqlite-column ] bi* ;
|
||||||
|
|
||||||
M: sqlite-result-set row-column-typed ( result-set n -- obj )
|
M: sqlite-result-set row-column-typed ( result-set n -- obj )
|
||||||
dup pick result-set-out-params nth sql-spec-type
|
dup pick out-params>> nth type>>
|
||||||
>r >r result-set-handle r> r> sqlite-column-typed ;
|
>r >r handle>> r> r> sqlite-column-typed ;
|
||||||
|
|
||||||
M: sqlite-result-set advance-row ( result-set -- )
|
M: sqlite-result-set advance-row ( result-set -- )
|
||||||
[ result-set-handle sqlite-next ] keep
|
dup handle>> sqlite-next >>has-more? drop ;
|
||||||
set-sqlite-result-set-has-more? ;
|
|
||||||
|
|
||||||
M: sqlite-result-set more-rows? ( result-set -- ? )
|
M: sqlite-result-set more-rows? ( result-set -- ? )
|
||||||
sqlite-result-set-has-more? ;
|
has-more?>> ;
|
||||||
|
|
||||||
M: sqlite-statement query-results ( query -- result-set )
|
M: sqlite-statement query-results ( query -- result-set )
|
||||||
sqlite-maybe-prepare
|
sqlite-maybe-prepare
|
||||||
dup statement-handle sqlite-result-set <result-set>
|
dup handle>> sqlite-result-set construct-result-set
|
||||||
dup advance-row ;
|
dup advance-row ;
|
||||||
|
|
||||||
M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
|
M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
|
||||||
|
@ -119,9 +105,9 @@ M: sqlite-db create-sql-statement ( class -- statement )
|
||||||
[
|
[
|
||||||
"create table " 0% 0%
|
"create table " 0% 0%
|
||||||
"(" 0% [ ", " 0% ] [
|
"(" 0% [ ", " 0% ] [
|
||||||
dup sql-spec-column-name 0%
|
dup column-name>> 0%
|
||||||
" " 0%
|
" " 0%
|
||||||
dup sql-spec-type t lookup-type 0%
|
dup type>> t lookup-type 0%
|
||||||
modifiers 0%
|
modifiers 0%
|
||||||
] interleave ");" 0%
|
] interleave ");" 0%
|
||||||
] sqlite-make ;
|
] sqlite-make ;
|
||||||
|
@ -134,7 +120,7 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
|
||||||
"insert into " 0% 0%
|
"insert into " 0% 0%
|
||||||
"(" 0%
|
"(" 0%
|
||||||
maybe-remove-id
|
maybe-remove-id
|
||||||
dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
|
dup [ ", " 0% ] [ column-name>> 0% ] interleave
|
||||||
") values(" 0%
|
") values(" 0%
|
||||||
[ ", " 0% ] [ bind% ] interleave
|
[ ", " 0% ] [ bind% ] interleave
|
||||||
");" 0%
|
");" 0%
|
||||||
|
@ -145,11 +131,11 @@ M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
|
||||||
|
|
||||||
: where-primary-key% ( specs -- )
|
: where-primary-key% ( specs -- )
|
||||||
" where " 0%
|
" where " 0%
|
||||||
find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ;
|
find-primary-key dup column-name>> 0% " = " 0% bind% ;
|
||||||
|
|
||||||
: where-clause ( specs -- )
|
: where-clause ( specs -- )
|
||||||
" where " 0%
|
" where " 0%
|
||||||
[ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ;
|
[ " and " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave ;
|
||||||
|
|
||||||
M: sqlite-db <update-tuple-statement> ( class -- statement )
|
M: sqlite-db <update-tuple-statement> ( class -- statement )
|
||||||
[
|
[
|
||||||
|
@ -157,7 +143,7 @@ M: sqlite-db <update-tuple-statement> ( class -- statement )
|
||||||
0%
|
0%
|
||||||
" set " 0%
|
" set " 0%
|
||||||
dup remove-id
|
dup remove-id
|
||||||
[ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
|
[ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
|
||||||
where-primary-key%
|
where-primary-key%
|
||||||
] sqlite-make ;
|
] sqlite-make ;
|
||||||
|
|
||||||
|
@ -166,23 +152,23 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
|
||||||
"delete from " 0% 0%
|
"delete from " 0% 0%
|
||||||
" where " 0%
|
" where " 0%
|
||||||
find-primary-key
|
find-primary-key
|
||||||
dup sql-spec-column-name 0% " = " 0% bind%
|
dup column-name>> 0% " = " 0% bind%
|
||||||
] sqlite-make ;
|
] sqlite-make ;
|
||||||
|
|
||||||
! : select-interval ( interval name -- ) ;
|
! : select-interval ( interval name -- ) ;
|
||||||
! : select-sequence ( seq name -- ) ;
|
! : select-sequence ( seq name -- ) ;
|
||||||
|
|
||||||
M: sqlite-db bind% ( spec -- )
|
M: sqlite-db bind% ( spec -- )
|
||||||
dup 1, sql-spec-column-name ":" prepend 0% ;
|
dup 1, column-name>> ":" prepend 0% ;
|
||||||
|
|
||||||
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
|
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
|
||||||
[
|
[
|
||||||
"select " 0%
|
"select " 0%
|
||||||
over [ ", " 0% ]
|
over [ ", " 0% ]
|
||||||
[ dup sql-spec-column-name 0% 2, ] interleave
|
[ dup column-name>> 0% 2, ] interleave
|
||||||
|
|
||||||
" from " 0% 0%
|
" from " 0% 0%
|
||||||
[ sql-spec-slot-name swap get-slot-named ] with subset
|
[ slot-name>> swap get-slot-named ] with subset
|
||||||
dup empty? [ drop ] [ where-clause ] if ";" 0%
|
dup empty? [ drop ] [ where-clause ] if ";" 0%
|
||||||
] sqlite-make ;
|
] sqlite-make ;
|
||||||
|
|
||||||
|
|
|
@ -260,10 +260,10 @@ C: <secret> secret
|
||||||
! [ test-random-id ] test-sqlite
|
! [ test-random-id ] test-sqlite
|
||||||
[ native-person-schema test-tuples ] test-sqlite
|
[ native-person-schema test-tuples ] test-sqlite
|
||||||
[ assigned-person-schema test-tuples ] test-sqlite
|
[ assigned-person-schema test-tuples ] test-sqlite
|
||||||
! [ assigned-person-schema test-repeated-insert ] test-sqlite
|
[ assigned-person-schema test-repeated-insert ] test-sqlite
|
||||||
! [ native-person-schema test-tuples ] test-postgresql
|
[ native-person-schema test-tuples ] test-postgresql
|
||||||
! [ assigned-person-schema test-tuples ] test-postgresql
|
[ assigned-person-schema test-tuples ] test-postgresql
|
||||||
! [ assigned-person-schema test-repeated-insert ] test-postgresql
|
[ assigned-person-schema test-repeated-insert ] test-postgresql
|
||||||
|
|
||||||
! \ insert-tuple must-infer
|
! \ insert-tuple must-infer
|
||||||
! \ update-tuple must-infer
|
! \ update-tuple must-infer
|
||||||
|
|
|
@ -2,6 +2,7 @@ USING: system ;
|
||||||
IN: hardware-info.backend
|
IN: hardware-info.backend
|
||||||
|
|
||||||
HOOK: cpus os ( -- n )
|
HOOK: cpus os ( -- n )
|
||||||
|
HOOK: cpu-mhz os ( -- n )
|
||||||
HOOK: memory-load os ( -- n )
|
HOOK: memory-load os ( -- n )
|
||||||
HOOK: physical-mem os ( -- n )
|
HOOK: physical-mem os ( -- n )
|
||||||
HOOK: available-mem os ( -- n )
|
HOOK: available-mem os ( -- n )
|
||||||
|
|
|
@ -3,11 +3,12 @@ combinators vocabs.loader hardware-info.backend system ;
|
||||||
IN: hardware-info
|
IN: hardware-info
|
||||||
|
|
||||||
: write-unit ( x n str -- )
|
: write-unit ( x n str -- )
|
||||||
[ 2^ /i number>string write bl ] [ write ] bi* ;
|
[ 2^ /f number>string write bl ] [ write ] bi* ;
|
||||||
|
|
||||||
: kb ( x -- ) 10 "kB" write-unit ;
|
: kb ( x -- ) 10 "kB" write-unit ;
|
||||||
: megs ( x -- ) 20 "MB" write-unit ;
|
: megs ( x -- ) 20 "MB" write-unit ;
|
||||||
: gigs ( x -- ) 30 "GB" write-unit ;
|
: gigs ( x -- ) 30 "GB" write-unit ;
|
||||||
|
: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
|
||||||
|
|
||||||
<< {
|
<< {
|
||||||
{ [ os windows? ] [ "hardware-info.windows" ] }
|
{ [ os windows? ] [ "hardware-info.windows" ] }
|
||||||
|
@ -18,4 +19,5 @@ IN: hardware-info
|
||||||
|
|
||||||
: hardware-report. ( -- )
|
: hardware-report. ( -- )
|
||||||
"CPUs: " write cpus number>string write nl
|
"CPUs: " write cpus number>string write nl
|
||||||
|
"CPU Speed: " write cpu-mhz ghz nl
|
||||||
"Physical RAM: " write physical-mem megs nl ;
|
"Physical RAM: " write physical-mem megs nl ;
|
||||||
|
|
|
@ -41,7 +41,7 @@ M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ;
|
||||||
: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
|
: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
|
||||||
: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
|
: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
|
||||||
: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
|
: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
|
||||||
: cpu-frequency ( -- n ) { 6 15 } sysctl-query-uint ;
|
M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
|
||||||
: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
|
: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
|
||||||
: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
|
: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
|
||||||
: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;
|
: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
IN: io.windows.launcher.nt.tests
|
IN: io.windows.launcher.nt.tests
|
||||||
USING: io.launcher tools.test calendar accessors
|
USING: io.launcher tools.test calendar accessors
|
||||||
namespaces kernel system arrays io io.files io.encodings.ascii
|
namespaces kernel system arrays io io.files io.encodings.ascii
|
||||||
sequences parser assocs hashtables ;
|
sequences parser assocs hashtables math ;
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
<process>
|
<process>
|
||||||
|
@ -129,3 +129,14 @@ sequences parser assocs hashtables ;
|
||||||
|
|
||||||
"HOME" swap at "XXX" =
|
"HOME" swap at "XXX" =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
2 [
|
||||||
|
[ ] [
|
||||||
|
<process>
|
||||||
|
"cmd.exe /c dir" >>command
|
||||||
|
"dir.txt" temp-file >>stdout
|
||||||
|
try-process
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [ "dir.txt" temp-file delete-file ] unit-test
|
||||||
|
] times
|
||||||
|
|
|
@ -39,7 +39,7 @@ IN: io.windows.nt.launcher
|
||||||
create-mode
|
create-mode
|
||||||
FILE_ATTRIBUTE_NORMAL ! flags and attributes
|
FILE_ATTRIBUTE_NORMAL ! flags and attributes
|
||||||
f ! template file
|
f ! template file
|
||||||
CreateFile dup invalid-handle? dup close-later ;
|
CreateFile dup invalid-handle? dup close-always ;
|
||||||
|
|
||||||
: set-inherit ( handle ? -- )
|
: set-inherit ( handle ? -- )
|
||||||
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
|
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
|
||||||
|
|
|
@ -0,0 +1,22 @@
|
||||||
|
|
||||||
|
USING: kernel arrays math.vectors ;
|
||||||
|
|
||||||
|
IN: math.points
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: X ( x -- point ) 0 0 3array ;
|
||||||
|
: Y ( y -- point ) 0 swap 0 3array ;
|
||||||
|
: Z ( z -- point ) 0 0 rot 3array ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: v+x ( seq x -- seq ) X v+ ;
|
||||||
|
: v-x ( seq x -- seq ) X v- ;
|
||||||
|
|
||||||
|
: v+y ( seq y -- seq ) Y v+ ;
|
||||||
|
: v-y ( seq y -- seq ) Y v- ;
|
||||||
|
|
||||||
|
: v+z ( seq z -- seq ) Z v+ ;
|
||||||
|
: v-z ( seq z -- seq ) Z v- ;
|
||||||
|
|
|
@ -70,6 +70,9 @@ PREDICATE: method-body < word
|
||||||
M: method-body stack-effect
|
M: method-body stack-effect
|
||||||
"multi-method" word-prop method-generic stack-effect ;
|
"multi-method" word-prop method-generic stack-effect ;
|
||||||
|
|
||||||
|
M: method-body crossref?
|
||||||
|
drop t ;
|
||||||
|
|
||||||
: method-word-name ( classes generic -- string )
|
: method-word-name ( classes generic -- string )
|
||||||
[
|
[
|
||||||
word-name %
|
word-name %
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
|
|
||||||
USING: kernel sequences assocs qualified ;
|
USING: kernel sequences assocs qualified circular ;
|
||||||
|
|
||||||
QUALIFIED: sequences
|
QUALIFIED: sequences
|
||||||
|
QUALIFIED: circular
|
||||||
|
|
||||||
IN: newfx
|
IN: newfx
|
||||||
|
|
||||||
|
@ -53,8 +54,10 @@ IN: newfx
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: push ( seq obj -- seq ) over sequences:push ;
|
: push ( seq obj -- seq ) over sequences:push ;
|
||||||
: push-on ( obj seq -- seq ) tuck sequences:push ;
|
: push-on ( obj seq -- seq ) tuck sequences:push ;
|
||||||
|
: pushed ( seq obj -- ) swap sequences:push ;
|
||||||
|
: pushed-on ( obj seq -- ) sequences:push ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
@ -91,6 +94,10 @@ IN: newfx
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: push-circular ( seq elt -- seq ) over circular:push-circular ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
! A note about the 'mutate' qualifier. Other words also technically mutate
|
! A note about the 'mutate' qualifier. Other words also technically mutate
|
||||||
! their primary object. However, the 'mutate' qualifier is supposed to
|
! their primary object. However, the 'mutate' qualifier is supposed to
|
||||||
! indicate that this is the main objective of the word, as a side effect.
|
! indicate that this is the main objective of the word, as a side effect.
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2007, 2008 Chris Double.
|
! Copyright (C) 2007, 2008 Chris Double.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel sequences strings fry namespaces math assocs shuffle
|
USING: kernel sequences strings fry namespaces math assocs shuffle
|
||||||
vectors arrays combinators.lib math.parser
|
vectors arrays math.parser
|
||||||
unicode.categories sequences.lib compiler.units parser
|
unicode.categories compiler.units parser
|
||||||
words quotations effects memoize accessors locals effects splitting ;
|
words quotations effects memoize accessors locals effects splitting ;
|
||||||
IN: peg
|
IN: peg
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,97 @@
|
||||||
|
|
||||||
|
USING: help.syntax help.markup ;
|
||||||
|
|
||||||
|
IN: processing.gallery.bubble-chamber
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
HELP: muon
|
||||||
|
|
||||||
|
{ $class-description
|
||||||
|
"The muon is a colorful particle with an entangled friend."
|
||||||
|
"It draws both itself and its horizontally symmetric partner."
|
||||||
|
"A high range of speed and almost no speed decay allow the"
|
||||||
|
"muon to reach the extents of the window, often forming rings"
|
||||||
|
"where theta has decayed but speed remains stable. The result"
|
||||||
|
"is color almost everywhere in the general direction of collision,"
|
||||||
|
"stabilized into fuzzy rings." } ;
|
||||||
|
|
||||||
|
HELP: quark
|
||||||
|
|
||||||
|
{ $class-description
|
||||||
|
"The quark draws as a translucent black. Their large numbers"
|
||||||
|
"create fields of blackness overwritten only by the glowing shadows of "
|
||||||
|
"Hadrons. "
|
||||||
|
"quarks are allowed to accelerate away with speed decay values above 1.0. "
|
||||||
|
"Each quark has an entangled friend. Both particles are drawn identically,"
|
||||||
|
"mirrored along the y-axis." } ;
|
||||||
|
|
||||||
|
HELP: hadron
|
||||||
|
|
||||||
|
{ $class-description
|
||||||
|
"Hadrons collide from totally random directions. "
|
||||||
|
"Those hadrons that do not exit the drawing area, "
|
||||||
|
"tend to stabilize into perfect circular orbits. "
|
||||||
|
"Each hadron draws with a slight glowing emboss. "
|
||||||
|
"The hadron itself is not drawn." } ;
|
||||||
|
|
||||||
|
HELP: axion
|
||||||
|
|
||||||
|
{ $class-description
|
||||||
|
"The axion particle draws a bold black path. Axions exist "
|
||||||
|
"in a slightly higher dimension and as such are drawn with "
|
||||||
|
"elevated embossed shadows. Axions are quick to stabilize "
|
||||||
|
"and fall into single pixel orbits axions automatically "
|
||||||
|
"recollide themselves after stabilizing." } ;
|
||||||
|
|
||||||
|
{ muon quark hadron axion } related-words
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
ARTICLE: "bubble-chamber" "Bubble Chamber"
|
||||||
|
|
||||||
|
{ $subsection "bubble-chamber-introduction" }
|
||||||
|
{ $subsection "bubble-chamber-particles" }
|
||||||
|
{ $subsection "bubble-chamber-author" }
|
||||||
|
{ $subsection "bubble-chamber-running" } ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
ARTICLE: "bubble-chamber-introduction" "Introduction"
|
||||||
|
|
||||||
|
"The Bubble Chamber is a generative painting system of imaginary "
|
||||||
|
"colliding particles. A single super-massive collision produces a "
|
||||||
|
"discrete universe of four particle types. Particles draw their "
|
||||||
|
"positions over time as pixel exposures. " ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
ARTICLE: "bubble-chamber-particles" "Particles"
|
||||||
|
|
||||||
|
"Four types of particles exist. The behavior and graphic appearance of "
|
||||||
|
"each particle type is unique."
|
||||||
|
|
||||||
|
{ $subsection muon }
|
||||||
|
{ $subsection quark }
|
||||||
|
{ $subsection hadron }
|
||||||
|
{ $subsection axion } ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
ARTICLE: "bubble-chamber-author" "Author"
|
||||||
|
|
||||||
|
"Bubble Chamber was created by Jared Tarbell. "
|
||||||
|
"It was originally implemented in Processing. "
|
||||||
|
"It was ported to Factor by Eduardo Cavazos. "
|
||||||
|
"The original work is on display here: "
|
||||||
|
{ $url
|
||||||
|
"http://www.complexification.net/gallery/machines/bubblechamber/" } ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
ARTICLE: "bubble-chamber-running" "How to use"
|
||||||
|
|
||||||
|
"After you run the vocabulary, a window will appear. Click the "
|
||||||
|
"mouse in a random area to fire 11 particles of each type. "
|
||||||
|
"Another way to fire particles is to press the "
|
||||||
|
"spacebar. This fires all the particles." ;
|
|
@ -7,6 +7,7 @@ USING: kernel namespaces sequences combinators arrays threads
|
||||||
math.ranges
|
math.ranges
|
||||||
math.constants
|
math.constants
|
||||||
math.functions
|
math.functions
|
||||||
|
math.points
|
||||||
|
|
||||||
ui
|
ui
|
||||||
ui.gadgets
|
ui.gadgets
|
||||||
|
@ -21,13 +22,7 @@ USING: kernel namespaces sequences combinators arrays threads
|
||||||
processing.gadget
|
processing.gadget
|
||||||
processing.color ;
|
processing.color ;
|
||||||
|
|
||||||
IN: bubble-chamber
|
IN: processing.gallery.bubble-chamber
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
|
|
||||||
|
|
||||||
: 1random ( b -- num ) 0 swap 2random ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
@ -82,17 +77,8 @@ VARS: particles muons quarks hadrons axions ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: x>> ( particle -- x ) pos>> first ;
|
: x ( particle -- x ) pos>> first ;
|
||||||
: y>> ( particle -- x ) pos>> second ;
|
: y ( particle -- x ) pos>> second ;
|
||||||
|
|
||||||
: >>x ( particle x -- particle ) over y>> 2array >>pos ;
|
|
||||||
: >>y ( particle y -- particle ) over x>> swap 2array >>pos ;
|
|
||||||
|
|
||||||
: x x>> ;
|
|
||||||
: y y>> ;
|
|
||||||
|
|
||||||
: v+y ( seq y -- seq ) >r first2 r> + 2array ;
|
|
||||||
: v-y ( seq y -- seq ) >r first2 r> - 2array ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
@ -103,23 +89,34 @@ VARS: particles muons quarks hadrons axions ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: initialize-particle ( particle -- particle )
|
||||||
|
|
||||||
|
0 0 {2} >>pos
|
||||||
|
0 0 {2} >>vel
|
||||||
|
|
||||||
|
0 >>speed
|
||||||
|
0 >>speed-d
|
||||||
|
0 >>theta
|
||||||
|
0 >>theta-d
|
||||||
|
0 >>theta-dd
|
||||||
|
|
||||||
|
0 0 0 1 <rgba> >>myc
|
||||||
|
0 0 0 1 <rgba> >>mya ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
GENERIC: collide ( particle -- )
|
GENERIC: collide ( particle -- )
|
||||||
GENERIC: move ( particle -- )
|
GENERIC: move ( particle -- )
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
TUPLE: muon pos speed theta speed-d theta-d theta-dd myc mya ;
|
TUPLE: muon < particle ;
|
||||||
|
|
||||||
: <muon> ( -- muon )
|
: <muon> ( -- muon ) muon construct-empty initialize-particle ;
|
||||||
muon construct-empty
|
|
||||||
0 0 2array >>pos
|
|
||||||
0 >>speed
|
|
||||||
0 >>speed-d
|
|
||||||
0 >>theta
|
|
||||||
0 >>theta-d
|
|
||||||
0 >>theta-dd
|
|
||||||
0 0 0 1 <rgba> >>myc
|
|
||||||
0 0 0 1 <rgba> >>mya ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
@ -177,18 +174,9 @@ METHOD: move { muon }
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
TUPLE: quark pos vel speed theta speed-d theta-d theta-dd myc ;
|
TUPLE: quark < particle ;
|
||||||
|
|
||||||
: <quark> ( -- quark )
|
: <quark> ( -- quark ) quark construct-empty initialize-particle ;
|
||||||
quark construct-empty
|
|
||||||
0 0 2array >>pos
|
|
||||||
0 0 2array >>vel
|
|
||||||
0 >>speed
|
|
||||||
0 >>speed-d
|
|
||||||
0 >>theta
|
|
||||||
0 >>theta-d
|
|
||||||
0 >>theta-dd
|
|
||||||
0 0 0 1 <rgba> >>myc ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
@ -228,7 +216,8 @@ METHOD: move { quark }
|
||||||
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
|
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
|
||||||
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
|
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
|
||||||
|
|
||||||
1000 random 997 >
|
! 1000 random 997 >
|
||||||
|
3/1000 chance
|
||||||
[
|
[
|
||||||
dup speed>> neg >>speed
|
dup speed>> neg >>speed
|
||||||
2 over speed-d>> - >>speed-d
|
2 over speed-d>> - >>speed-d
|
||||||
|
@ -242,18 +231,9 @@ METHOD: move { quark }
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
TUPLE: hadron pos vel speed theta speed-d theta-d theta-dd myc ;
|
TUPLE: hadron < particle ;
|
||||||
|
|
||||||
: <hadron> ( -- hadron )
|
: <hadron> ( -- hadron ) hadron construct-empty initialize-particle ;
|
||||||
hadron construct-empty
|
|
||||||
0 0 2array >>pos
|
|
||||||
0 0 2array >>vel
|
|
||||||
0 >>speed
|
|
||||||
0 >>speed-d
|
|
||||||
0 >>theta
|
|
||||||
0 >>theta-d
|
|
||||||
0 >>theta-dd
|
|
||||||
0 0 0 1 <rgba> >>myc ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
@ -296,12 +276,14 @@ METHOD: move { hadron }
|
||||||
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
|
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
|
||||||
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
|
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
|
||||||
|
|
||||||
1000 random 997 >
|
! 1000 random 997 >
|
||||||
|
3/1000 chance
|
||||||
[
|
[
|
||||||
1.0 >>speed-d
|
1.0 >>speed-d
|
||||||
0.00001 >>theta-dd
|
0.00001 >>theta-dd
|
||||||
|
|
||||||
100 random 70 >
|
! 100 random 70 >
|
||||||
|
30/100 chance
|
||||||
[
|
[
|
||||||
dim 2 / dup 2array >>pos
|
dim 2 / dup 2array >>pos
|
||||||
dup collide
|
dup collide
|
||||||
|
@ -317,17 +299,9 @@ METHOD: move { hadron }
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
TUPLE: axion pos vel speed theta speed-d theta-d theta-dd ;
|
TUPLE: axion < particle ;
|
||||||
|
|
||||||
: <axion> ( -- axion )
|
: <axion> ( -- axion ) axion construct-empty initialize-particle ;
|
||||||
axion construct-empty
|
|
||||||
0 0 2array >>pos
|
|
||||||
0 0 2array >>vel
|
|
||||||
0 >>speed
|
|
||||||
0 >>speed-d
|
|
||||||
0 >>theta
|
|
||||||
0 >>theta-d
|
|
||||||
0 >>theta-dd ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
@ -381,12 +355,14 @@ METHOD: move { axion }
|
||||||
|
|
||||||
[ ] [ speed-d>> 0.9999 * ] bi >>speed-d
|
[ ] [ speed-d>> 0.9999 * ] bi >>speed-d
|
||||||
|
|
||||||
1000 random 996 >
|
! 1000 random 996 >
|
||||||
|
4/1000 chance
|
||||||
[
|
[
|
||||||
dup speed>> neg >>speed
|
dup speed>> neg >>speed
|
||||||
dup speed-d>> neg 2 + >>speed-d
|
dup speed-d>> neg 2 + >>speed-d
|
||||||
|
|
||||||
100 random 30 >
|
! 100 random 30 >
|
||||||
|
70/100 chance
|
||||||
[
|
[
|
||||||
dim 2 / dup 2array >>pos
|
dim 2 / dup 2array >>pos
|
||||||
collide
|
collide
|
||||||
|
@ -472,6 +448,6 @@ METHOD: move { axion }
|
||||||
|
|
||||||
;
|
;
|
||||||
|
|
||||||
: go ( -- ) [ bubble-chamber 500 sleep run ] with-ui ;
|
: go ( -- ) [ bubble-chamber run ] with-ui ;
|
||||||
|
|
||||||
MAIN: go
|
MAIN: go
|
|
@ -0,0 +1,47 @@
|
||||||
|
|
||||||
|
USING: kernel arrays sequences math qualified
|
||||||
|
sequences.lib circular processing ui newfx ;
|
||||||
|
|
||||||
|
IN: processing.gallery.trails
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
! Example 33-15 from the Processing book
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: point-list ( n -- seq ) [ drop 0 0 2array ] map <circular> ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: dot ( pos percent -- ) 1 swap - 25 * 5 max circle ;
|
||||||
|
|
||||||
|
: step ( seq -- )
|
||||||
|
|
||||||
|
no-stroke
|
||||||
|
{ 1 0.4 } fill
|
||||||
|
|
||||||
|
0 background
|
||||||
|
|
||||||
|
mouse push-circular
|
||||||
|
[ dot ]
|
||||||
|
each-percent ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: go* ( -- )
|
||||||
|
|
||||||
|
500 500 size*
|
||||||
|
|
||||||
|
[
|
||||||
|
100 point-list
|
||||||
|
[ step ]
|
||||||
|
curry
|
||||||
|
draw
|
||||||
|
] setup
|
||||||
|
|
||||||
|
run ;
|
||||||
|
|
||||||
|
: go ( -- ) [ go* ] with-ui ;
|
||||||
|
|
||||||
|
MAIN: go
|
|
@ -1,6 +1,6 @@
|
||||||
|
|
||||||
USING: kernel namespaces threads combinators sequences arrays
|
USING: kernel namespaces threads combinators sequences arrays
|
||||||
math math.functions
|
math math.functions math.ranges random
|
||||||
opengl.gl opengl.glu vars multi-methods shuffle
|
opengl.gl opengl.glu vars multi-methods shuffle
|
||||||
ui
|
ui
|
||||||
ui.gestures
|
ui.gestures
|
||||||
|
@ -16,6 +16,18 @@ IN: processing
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
|
||||||
|
|
||||||
|
: 1random ( b -- num ) 0 swap 2random ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: chance ( fraction -- ? ) 0 1 2random > ;
|
||||||
|
|
||||||
|
: percent-chance ( percent -- ? ) 100 / chance ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
VAR: fill-color
|
VAR: fill-color
|
||||||
VAR: stroke-color
|
VAR: stroke-color
|
||||||
|
|
||||||
|
|
|
@ -4,7 +4,7 @@
|
||||||
USING: combinators.lib kernel sequences math namespaces assocs
|
USING: combinators.lib kernel sequences math namespaces assocs
|
||||||
random sequences.private shuffle math.functions mirrors
|
random sequences.private shuffle math.functions mirrors
|
||||||
arrays math.parser math.private sorting strings ascii macros
|
arrays math.parser math.private sorting strings ascii macros
|
||||||
assocs.lib quotations ;
|
assocs.lib quotations hashtables ;
|
||||||
IN: sequences.lib
|
IN: sequences.lib
|
||||||
|
|
||||||
: each-withn ( seq quot n -- ) nwith each ; inline
|
: each-withn ( seq quot n -- ) nwith each ; inline
|
||||||
|
@ -37,6 +37,16 @@ MACRO: firstn ( n -- )
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: each-percent ( seq quot -- )
|
||||||
|
>r
|
||||||
|
dup length
|
||||||
|
dup [ / ] curry
|
||||||
|
[ 1+ ] swap compose
|
||||||
|
r> compose
|
||||||
|
2each ; inline
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: sigma ( seq quot -- n )
|
: sigma ( seq quot -- n )
|
||||||
[ rot slip + ] curry 0 swap reduce ; inline
|
[ rot slip + ] curry 0 swap reduce ; inline
|
||||||
|
|
||||||
|
@ -221,7 +231,7 @@ PRIVATE>
|
||||||
[ swap nth ] with map ;
|
[ swap nth ] with map ;
|
||||||
|
|
||||||
: replace ( str oldseq newseq -- str' )
|
: replace ( str oldseq newseq -- str' )
|
||||||
H{ } 2seq>assoc substitute ;
|
zip >hashtable substitute ;
|
||||||
|
|
||||||
: remove-nth ( seq n -- seq' )
|
: remove-nth ( seq n -- seq' )
|
||||||
cut-slice 1 tail-slice append ;
|
cut-slice 1 tail-slice append ;
|
||||||
|
|
|
@ -26,8 +26,7 @@ M: pair make-disassemble-cmd
|
||||||
M: method-spec make-disassemble-cmd
|
M: method-spec make-disassemble-cmd
|
||||||
first2 method make-disassemble-cmd ;
|
first2 method make-disassemble-cmd ;
|
||||||
|
|
||||||
: gdb-binary ( -- string )
|
: gdb-binary ( -- string ) "gdb" ;
|
||||||
os freebsd? "gdb66" "gdb" ? ;
|
|
||||||
|
|
||||||
: run-gdb ( -- lines )
|
: run-gdb ( -- lines )
|
||||||
<process>
|
<process>
|
||||||
|
|
|
@ -1,4 +1,8 @@
|
||||||
USING: tools.test tools.memory ;
|
USING: tools.test tools.memory ;
|
||||||
IN: tools.memory.tests
|
IN: tools.memory.tests
|
||||||
|
|
||||||
|
\ room. must-infer
|
||||||
|
[ ] [ room. ] unit-test
|
||||||
|
|
||||||
|
\ heap-stats. must-infer
|
||||||
[ ] [ heap-stats. ] unit-test
|
[ ] [ heap-stats. ] unit-test
|
||||||
|
|
|
@ -1,22 +1,29 @@
|
||||||
! Copyright (C) 2005, 2007 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel sequences vectors arrays generic assocs io math
|
USING: kernel sequences vectors arrays generic assocs io math
|
||||||
namespaces parser prettyprint strings io.styles vectors words
|
namespaces parser prettyprint strings io.styles vectors words
|
||||||
system sorting splitting math.parser classes memory ;
|
system sorting splitting math.parser classes memory combinators ;
|
||||||
IN: tools.memory
|
IN: tools.memory
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: write-size ( n -- )
|
||||||
|
number>string
|
||||||
|
dup length 4 > [ 3 cut* "," swap 3append ] when
|
||||||
|
" KB" append write-cell ;
|
||||||
|
|
||||||
: write-total/used/free ( free total str -- )
|
: write-total/used/free ( free total str -- )
|
||||||
[
|
[
|
||||||
write-cell
|
write-cell
|
||||||
dup number>string write-cell
|
dup write-size
|
||||||
over - number>string write-cell
|
over - write-size
|
||||||
number>string write-cell
|
write-size
|
||||||
] with-row ;
|
] with-row ;
|
||||||
|
|
||||||
: write-total ( n str -- )
|
: write-total ( n str -- )
|
||||||
[
|
[
|
||||||
write-cell
|
write-cell
|
||||||
number>string write-cell
|
write-size
|
||||||
[ ] with-cell
|
[ ] with-cell
|
||||||
[ ] with-cell
|
[ ] with-cell
|
||||||
] with-row ;
|
] with-row ;
|
||||||
|
@ -25,26 +32,41 @@ IN: tools.memory
|
||||||
[ [ write-cell ] each ] with-row ;
|
[ [ write-cell ] each ] with-row ;
|
||||||
|
|
||||||
: (data-room.) ( -- )
|
: (data-room.) ( -- )
|
||||||
data-room 2 <groups> 0 [
|
data-room 2 <groups> dup length [
|
||||||
"Generation " pick number>string append
|
[ first2 ] [ number>string "Generation " prepend ] bi*
|
||||||
>r first2 r> write-total/used/free 1+
|
write-total/used/free
|
||||||
] reduce drop
|
] 2each
|
||||||
"Cards" write-total ;
|
"Cards" write-total ;
|
||||||
|
|
||||||
: (code-room.) ( -- )
|
: write-labelled-size ( n string -- )
|
||||||
code-room "Code space" write-total/used/free ;
|
[ write-cell write-size ] with-row ;
|
||||||
|
|
||||||
: room. ( -- )
|
: (code-room.) ( -- )
|
||||||
standard-table-style [
|
code-room {
|
||||||
{ "" "Total" "Used" "Free" } write-headings
|
[ "Size:" write-labelled-size ]
|
||||||
(data-room.)
|
[ "Used:" write-labelled-size ]
|
||||||
(code-room.)
|
[ "Total free space:" write-labelled-size ]
|
||||||
] tabular-output ;
|
[ "Largest free block:" write-labelled-size ]
|
||||||
|
} spread ;
|
||||||
|
|
||||||
: heap-stat-step ( counts sizes obj -- )
|
: heap-stat-step ( counts sizes obj -- )
|
||||||
[ dup size swap class rot at+ ] keep
|
[ dup size swap class rot at+ ] keep
|
||||||
1 swap class rot at+ ;
|
1 swap class rot at+ ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: room. ( -- )
|
||||||
|
"==== DATA HEAP" print
|
||||||
|
standard-table-style [
|
||||||
|
{ "" "Total" "Used" "Free" } write-headings
|
||||||
|
(data-room.)
|
||||||
|
] tabular-output
|
||||||
|
nl
|
||||||
|
"==== CODE HEAP" print
|
||||||
|
standard-table-style [
|
||||||
|
(code-room.)
|
||||||
|
] tabular-output ;
|
||||||
|
|
||||||
: heap-stats ( -- counts sizes )
|
: heap-stats ( -- counts sizes )
|
||||||
H{ } clone H{ } clone
|
H{ } clone H{ } clone
|
||||||
[ >r 2dup r> heap-stat-step ] each-object ;
|
[ >r 2dup r> heap-stat-step ] each-object ;
|
||||||
|
|
|
@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor
|
||||||
ui.tools.listener hashtables kernel namespaces parser sequences
|
ui.tools.listener hashtables kernel namespaces parser sequences
|
||||||
tools.test ui.commands ui.gadgets ui.gadgets.editors
|
tools.test ui.commands ui.gadgets ui.gadgets.editors
|
||||||
ui.gadgets.panes vocabs words tools.test.ui slots.private
|
ui.gadgets.panes vocabs words tools.test.ui slots.private
|
||||||
threads ;
|
threads arrays generic ;
|
||||||
IN: ui.tools.listener.tests
|
IN: ui.tools.listener.tests
|
||||||
|
|
||||||
[ f ] [ "word" source-editor command-map empty? ] unit-test
|
[ f ] [ "word" source-editor command-map empty? ] unit-test
|
||||||
|
@ -13,11 +13,11 @@ IN: ui.tools.listener.tests
|
||||||
|
|
||||||
"listener" get [
|
"listener" get [
|
||||||
[ "dup" ] [
|
[ "dup" ] [
|
||||||
\ dup "listener" get word-completion-string
|
\ dup word-completion-string
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "USE: slots.private slot" ]
|
[ "equal?" ]
|
||||||
[ \ slot "listener" get word-completion-string ] unit-test
|
[ \ array \ equal? method word-completion-string ] unit-test
|
||||||
|
|
||||||
<pane> <interactor> "i" set
|
<pane> <interactor> "i" set
|
||||||
|
|
||||||
|
|
|
@ -7,7 +7,7 @@ ui.gadgets ui.gadgets.editors ui.gadgets.labelled
|
||||||
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
|
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
|
||||||
ui.gadgets.tracks ui.gestures ui.operations vocabs words
|
ui.gadgets.tracks ui.gestures ui.operations vocabs words
|
||||||
prettyprint listener debugger threads boxes concurrency.flags
|
prettyprint listener debugger threads boxes concurrency.flags
|
||||||
math arrays generic accessors ;
|
math arrays generic accessors combinators ;
|
||||||
IN: ui.tools.listener
|
IN: ui.tools.listener
|
||||||
|
|
||||||
TUPLE: listener-gadget input output stack ;
|
TUPLE: listener-gadget input output stack ;
|
||||||
|
@ -101,26 +101,32 @@ M: listener-operation invoke-command ( target command -- )
|
||||||
: clear-stack ( listener -- )
|
: clear-stack ( listener -- )
|
||||||
[ clear ] swap (call-listener) ;
|
[ clear ] swap (call-listener) ;
|
||||||
|
|
||||||
GENERIC# word-completion-string 1 ( word listener -- string )
|
GENERIC: word-completion-string ( word -- string )
|
||||||
|
|
||||||
|
M: word word-completion-string
|
||||||
|
word-name ;
|
||||||
|
|
||||||
M: method-body word-completion-string
|
M: method-body word-completion-string
|
||||||
>r "method-generic" word-prop r> word-completion-string ;
|
"method-generic" word-prop word-completion-string ;
|
||||||
|
|
||||||
USE: generic.standard.engines.tuple
|
USE: generic.standard.engines.tuple
|
||||||
|
|
||||||
M: tuple-dispatch-engine-word word-completion-string
|
M: tuple-dispatch-engine-word word-completion-string
|
||||||
>r "engine-generic" word-prop r> word-completion-string ;
|
"engine-generic" word-prop word-completion-string ;
|
||||||
|
|
||||||
M: word word-completion-string ( word listener -- string )
|
: use-if-necessary ( word seq -- )
|
||||||
>r [ word-name ] [ word-vocabulary ] bi dup vocab-words r>
|
>r word-vocabulary vocab-words r>
|
||||||
input>> interactor-use memq?
|
{
|
||||||
[ drop ] [ [ "USE: " % % " " % % ] "" make ] if ;
|
{ [ dup not ] [ 2drop ] }
|
||||||
|
{ [ 2dup memq? ] [ 2drop ] }
|
||||||
|
{ [ t ] [ push ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
: insert-word ( word -- )
|
: insert-word ( word -- )
|
||||||
get-workspace
|
get-workspace workspace-listener input>>
|
||||||
workspace-listener
|
[ >r word-completion-string r> user-input ]
|
||||||
[ word-completion-string ] keep
|
[ interactor-use use-if-necessary ]
|
||||||
input>> user-input ;
|
2bi ;
|
||||||
|
|
||||||
: quot-action ( interactor -- lines )
|
: quot-action ( interactor -- lines )
|
||||||
dup control-value
|
dup control-value
|
||||||
|
|
33
vm/code_gc.c
33
vm/code_gc.c
|
@ -198,20 +198,33 @@ void free_unmarked(F_HEAP *heap)
|
||||||
build_free_list(heap,heap->segment->size);
|
build_free_list(heap,heap->segment->size);
|
||||||
}
|
}
|
||||||
|
|
||||||
/* Compute total sum of sizes of free blocks */
|
/* Compute total sum of sizes of free blocks, and size of largest free block */
|
||||||
CELL heap_usage(F_HEAP *heap, F_BLOCK_STATUS status)
|
void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free)
|
||||||
{
|
{
|
||||||
CELL size = 0;
|
*used = 0;
|
||||||
|
*total_free = 0;
|
||||||
|
*max_free = 0;
|
||||||
|
|
||||||
F_BLOCK *scan = first_block(heap);
|
F_BLOCK *scan = first_block(heap);
|
||||||
|
|
||||||
while(scan)
|
while(scan)
|
||||||
{
|
{
|
||||||
if(scan->status == status)
|
switch(scan->status)
|
||||||
size += scan->size;
|
{
|
||||||
|
case B_ALLOCATED:
|
||||||
|
*used += scan->size;
|
||||||
|
break;
|
||||||
|
case B_FREE:
|
||||||
|
*total_free += scan->size;
|
||||||
|
if(scan->size > *max_free)
|
||||||
|
*max_free = scan->size;
|
||||||
|
break;
|
||||||
|
default:
|
||||||
|
critical_error("Invalid scan->status",(CELL)scan);
|
||||||
|
}
|
||||||
|
|
||||||
scan = next_block(heap,scan);
|
scan = next_block(heap,scan);
|
||||||
}
|
}
|
||||||
|
|
||||||
return size;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
/* The size of the heap, not including the last block if it's free */
|
/* The size of the heap, not including the last block if it's free */
|
||||||
|
@ -283,8 +296,12 @@ void recursive_mark(F_BLOCK *block)
|
||||||
/* Push the free space and total size of the code heap */
|
/* Push the free space and total size of the code heap */
|
||||||
DEFINE_PRIMITIVE(code_room)
|
DEFINE_PRIMITIVE(code_room)
|
||||||
{
|
{
|
||||||
dpush(tag_fixnum(heap_usage(&code_heap,B_FREE) / 1024));
|
CELL used, total_free, max_free;
|
||||||
|
heap_usage(&code_heap,&used,&total_free,&max_free);
|
||||||
dpush(tag_fixnum((code_heap.segment->size) / 1024));
|
dpush(tag_fixnum((code_heap.segment->size) / 1024));
|
||||||
|
dpush(tag_fixnum(used / 1024));
|
||||||
|
dpush(tag_fixnum(total_free / 1024));
|
||||||
|
dpush(tag_fixnum(max_free / 1024));
|
||||||
}
|
}
|
||||||
|
|
||||||
/* Dump all code blocks for debugging */
|
/* Dump all code blocks for debugging */
|
||||||
|
|
|
@ -32,7 +32,7 @@ void build_free_list(F_HEAP *heap, CELL size);
|
||||||
CELL heap_allot(F_HEAP *heap, CELL size);
|
CELL heap_allot(F_HEAP *heap, CELL size);
|
||||||
void unmark_marked(F_HEAP *heap);
|
void unmark_marked(F_HEAP *heap);
|
||||||
void free_unmarked(F_HEAP *heap);
|
void free_unmarked(F_HEAP *heap);
|
||||||
CELL heap_usage(F_HEAP *heap, F_BLOCK_STATUS status);
|
void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free);
|
||||||
CELL heap_size(F_HEAP *heap);
|
CELL heap_size(F_HEAP *heap);
|
||||||
|
|
||||||
INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
|
INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
|
||||||
|
|
|
@ -229,7 +229,16 @@ CELL allot_code_block(CELL size)
|
||||||
|
|
||||||
/* Insufficient room even after code GC, give up */
|
/* Insufficient room even after code GC, give up */
|
||||||
if(start == 0)
|
if(start == 0)
|
||||||
|
{
|
||||||
|
CELL used, total_free, max_free;
|
||||||
|
heap_usage(&code_heap,&used,&total_free,&max_free);
|
||||||
|
|
||||||
|
fprintf(stderr,"Code heap stats:\n");
|
||||||
|
fprintf(stderr,"Used: %ld\n",used);
|
||||||
|
fprintf(stderr,"Total free space: %ld\n",total_free);
|
||||||
|
fprintf(stderr,"Largest free block: %ld\n",max_free);
|
||||||
fatal_error("Out of memory in add-compiled-block",0);
|
fatal_error("Out of memory in add-compiled-block",0);
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
return start;
|
return start;
|
||||||
|
|
|
@ -315,8 +315,6 @@ INLINE void* allot_object(CELL type, CELL a)
|
||||||
{
|
{
|
||||||
CELL *object;
|
CELL *object;
|
||||||
|
|
||||||
/* If the object is bigger than the nursery, allocate it in
|
|
||||||
tenured space */
|
|
||||||
if(nursery->size - ALLOT_BUFFER_ZONE > a)
|
if(nursery->size - ALLOT_BUFFER_ZONE > a)
|
||||||
{
|
{
|
||||||
/* If there is insufficient room, collect the nursery */
|
/* If there is insufficient room, collect the nursery */
|
||||||
|
@ -325,6 +323,8 @@ INLINE void* allot_object(CELL type, CELL a)
|
||||||
|
|
||||||
object = allot_zone(nursery,a);
|
object = allot_zone(nursery,a);
|
||||||
}
|
}
|
||||||
|
/* If the object is bigger than the nursery, allocate it in
|
||||||
|
tenured space */
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
F_ZONE *tenured = &data_heap->generations[TENURED];
|
F_ZONE *tenured = &data_heap->generations[TENURED];
|
||||||
|
|
|
@ -145,3 +145,9 @@ DEFINE_PRIMITIVE(call_clear)
|
||||||
{
|
{
|
||||||
throw_impl(dpop(),stack_chain->callstack_bottom);
|
throw_impl(dpop(),stack_chain->callstack_bottom);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/* For testing purposes */
|
||||||
|
DEFINE_PRIMITIVE(unimplemented)
|
||||||
|
{
|
||||||
|
not_implemented_error();
|
||||||
|
}
|
||||||
|
|
|
@ -55,3 +55,5 @@ void *signal_callstack_top;
|
||||||
void memory_signal_handler_impl(void);
|
void memory_signal_handler_impl(void);
|
||||||
void divide_by_zero_signal_handler_impl(void);
|
void divide_by_zero_signal_handler_impl(void);
|
||||||
void misc_signal_handler_impl(void);
|
void misc_signal_handler_impl(void);
|
||||||
|
|
||||||
|
DECLARE_PRIMITIVE(unimplemented);
|
||||||
|
|
|
@ -215,7 +215,7 @@ void sleep_millis(DWORD msec)
|
||||||
Sleep(msec);
|
Sleep(msec);
|
||||||
}
|
}
|
||||||
|
|
||||||
DECLARE_PRIMITIVE(set_os_envs)
|
DEFINE_PRIMITIVE(set_os_envs)
|
||||||
{
|
{
|
||||||
not_implemented_error();
|
not_implemented_error();
|
||||||
}
|
}
|
||||||
|
|
|
@ -187,4 +187,5 @@ void *primitives[] = {
|
||||||
primitive_resize_bit_array,
|
primitive_resize_bit_array,
|
||||||
primitive_resize_float_array,
|
primitive_resize_float_array,
|
||||||
primitive_dll_validp,
|
primitive_dll_validp,
|
||||||
|
primitive_unimplemented,
|
||||||
};
|
};
|
||||||
|
|
Loading…
Reference in New Issue