Merge commit 'origin/master'
Chris Double
commit
c39ece54a1
|
|
@ -89,11 +89,6 @@ set_md5sum() {
|
|||
set_gcc() {
|
||||
case $OS in
|
||||
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;;
|
||||
esac
|
||||
}
|
||||
|
|
|
|||
|
|
@ -155,6 +155,9 @@ M: assoc >alist [ 2array ] { } assoc>map ;
|
|||
: value-at ( value assoc -- key/f )
|
||||
swap [ = nip ] curry assoc-find 2drop ;
|
||||
|
||||
: zip ( keys values -- alist )
|
||||
2array flip ; inline
|
||||
|
||||
: search-alist ( key alist -- pair i )
|
||||
[ 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 >alist ( enum -- alist )
|
||||
seq>> [ length ] keep 2array flip ;
|
||||
seq>> [ length ] keep zip ;
|
||||
|
||||
M: enum assoc-size seq>> length ;
|
||||
|
||||
|
|
|
|||
|
|
@ -737,6 +737,7 @@ define-builtin
|
|||
{ "resize-bit-array" "bit-arrays" }
|
||||
{ "resize-float-array" "float-arrays" }
|
||||
{ "dll-valid?" "alien" }
|
||||
{ "unimplemented" "kernel.private" }
|
||||
}
|
||||
dup length [ >r first2 r> make-primitive ] 2each
|
||||
|
||||
|
|
|
|||
|
|
@ -529,3 +529,12 @@ TUPLE: another-forget-accessors-test ;
|
|||
] 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
|
||||
[ dup array? [ second ] when ] map ;
|
||||
|
||||
: all-slot-names ( class -- slots )
|
||||
superclasses [ slot-names ] map concat \ class prefix ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: tuple= ( tuple1 tuple2 -- ? )
|
||||
|
|
@ -119,9 +122,6 @@ PRIVATE>
|
|||
: define-tuple-layout ( class -- )
|
||||
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 )
|
||||
>r all-slot-names r> [ index ] curry map ;
|
||||
|
||||
|
|
|
|||
|
|
@ -59,6 +59,10 @@ ERROR: no-case ;
|
|||
M: sequence hashcode*
|
||||
[ sequence-hashcode ] recursive-hashcode ;
|
||||
|
||||
M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
|
||||
|
||||
M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
|
||||
|
||||
M: hashtable hashcode*
|
||||
[
|
||||
dup assoc-size 1 number=
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces arrays sequences io inference.backend
|
||||
inference.state generator debugger math.parser prettyprint words
|
||||
compiler.units continuations vocabs assocs alien.compiler dlists
|
||||
optimizer definitions math compiler.errors threads graphs
|
||||
generic inference ;
|
||||
inference.state generator debugger words compiler.units
|
||||
continuations vocabs assocs alien.compiler dlists optimizer
|
||||
definitions math compiler.errors threads graphs generic
|
||||
inference ;
|
||||
IN: compiler
|
||||
|
||||
: 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 ;
|
||||
|
||||
GENERIC: STF ( src dst reg-class -- )
|
||||
GENERIC: STF ( src dst off reg-class -- )
|
||||
|
||||
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 ;
|
||||
|
||||
GENERIC: LF ( src dst reg-class -- )
|
||||
GENERIC: LF ( dst src off reg-class -- )
|
||||
|
||||
M: single-float-regs LF drop LFS ;
|
||||
|
||||
|
|
|
|||
|
|
@ -322,7 +322,7 @@ M: phantom-retainstack finalize-height
|
|||
|
||||
: (live-locs) ( phantom -- seq )
|
||||
#! Discard locs which haven't moved
|
||||
[ phantom-locs* ] [ stack>> ] bi 2array flip
|
||||
[ phantom-locs* ] [ stack>> ] bi zip
|
||||
[ live-loc? ] assoc-subset
|
||||
values ;
|
||||
|
||||
|
|
@ -421,7 +421,7 @@ M: loc lazy-store
|
|||
|
||||
: slow-shuffle-mapping ( locs tmp -- pairs )
|
||||
>r dup length r>
|
||||
[ swap - <ds-loc> ] curry map 2array flip ;
|
||||
[ swap - <ds-loc> ] curry map zip ;
|
||||
|
||||
: slow-shuffle ( locs -- )
|
||||
#! 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 make-flushable
|
||||
|
||||
\ code-room { } { integer integer } <effect> set-primitive-effect
|
||||
\ code-room { } { integer integer integer integer } <effect> set-primitive-effect
|
||||
\ code-room make-flushable
|
||||
|
||||
\ os-env { string } { object } <effect> set-primitive-effect
|
||||
|
|
@ -594,3 +594,5 @@ set-primitive-effect
|
|||
\ dll-valid? { object } { 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-writer> }
|
||||
{ $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:"
|
||||
{ $subsection with-file-reader }
|
||||
{ $subsection with-file-writer }
|
||||
{ $subsection with-file-appender }
|
||||
{ $subsection set-file-contents }
|
||||
{ $subsection file-contents }
|
||||
{ $subsection set-file-lines }
|
||||
{ $subsection file-lines } ;
|
||||
{ $subsection with-file-appender } ;
|
||||
|
||||
ARTICLE: "pathnames" "Pathname manipulation"
|
||||
"Pathname manipulation:"
|
||||
|
|
|
|||
|
|
@ -108,3 +108,12 @@ IN: kernel.tests
|
|||
H{ } values swap >r dup length swap r> 0 -roll (loop) ;
|
||||
|
||||
[ 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 )
|
||||
>mirror<
|
||||
[ [ 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -370,4 +370,7 @@ HINTS: recursive-inline-hang-2 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 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."
|
||||
$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" } ;
|
||||
|
||||
ARTICLE: "parser-usage" "Reflective parser usage"
|
||||
|
|
@ -161,6 +163,13 @@ ARTICLE: "parser-usage" "Reflective parser usage"
|
|||
"The parser can also parse from a 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"
|
||||
"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
|
||||
|
|
@ -168,6 +177,7 @@ $nl
|
|||
{ $subsection "vocabulary-search" }
|
||||
{ $subsection "parser-files" }
|
||||
{ $subsection "parser-usage" }
|
||||
{ $subsection "top-level-forms" }
|
||||
"The parser can be extended."
|
||||
{ $subsection "parsing-words" }
|
||||
{ $subsection "parser-lexer" }
|
||||
|
|
@ -284,10 +294,6 @@ HELP: use
|
|||
HELP: in
|
||||
{ $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+)
|
||||
{ $values { "vocab" "an assoc mapping strings to words" } }
|
||||
{ $description "Adds an assoc at the front of the search path." }
|
||||
|
|
|
|||
|
|
@ -1,12 +1,11 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays definitions generic assocs kernel math
|
||||
namespaces prettyprint sequences strings vectors words
|
||||
quotations inspector io.styles io combinators sorting
|
||||
splitting math.parser effects continuations debugger
|
||||
io.files io.streams.string vocabs io.encodings.utf8
|
||||
source-files classes hashtables compiler.errors compiler.units
|
||||
accessors ;
|
||||
USING: arrays definitions generic assocs kernel math namespaces
|
||||
prettyprint sequences strings vectors words quotations inspector
|
||||
io.styles io combinators sorting splitting math.parser effects
|
||||
continuations debugger io.files io.streams.string vocabs
|
||||
io.encodings.utf8 source-files classes classes.tuple hashtables
|
||||
compiler.errors compiler.units accessors ;
|
||||
IN: parser
|
||||
|
||||
TUPLE: lexer text line line-text line-length column ;
|
||||
|
|
@ -191,22 +190,8 @@ SYMBOL: in
|
|||
: word/vocab% ( word -- )
|
||||
"(" % 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 -- )
|
||||
vocab-words use get 2dup shadow-warnings push ;
|
||||
vocab-words use get push ;
|
||||
|
||||
: use+ ( vocab -- )
|
||||
load-vocab (use+) ;
|
||||
|
|
@ -299,13 +284,27 @@ M: no-word-error summary
|
|||
: CREATE-METHOD ( -- method )
|
||||
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 )
|
||||
CREATE-CLASS
|
||||
scan {
|
||||
{ ";" [ tuple f ] }
|
||||
{ "<" [ scan-word ";" parse-tokens ] }
|
||||
[ >r tuple ";" parse-tokens r> prefix ]
|
||||
} case ;
|
||||
} case 3dup check-slot-shadowing ;
|
||||
|
||||
ERROR: staging-violation word ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: arrays kernel math namespaces sequences kernel.private
|
||||
sequences.private strings sbufs tools.test vectors bit-arrays
|
||||
generic ;
|
||||
generic vocabs.loader ;
|
||||
IN: sequences.tests
|
||||
|
||||
[ 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
|
||||
[ [ 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
|
||||
|
|
@ -195,6 +205,12 @@ unit-test
|
|||
! Pathological case
|
||||
[ "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
|
||||
|
||||
|
|
@ -244,3 +260,5 @@ unit-test
|
|||
[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-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
|
||||
|
||||
M: reversed virtual-seq reversed-seq ;
|
||||
|
||||
M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ;
|
||||
|
||||
M: reversed length reversed-seq length ;
|
||||
|
||||
INSTANCE: reversed virtual-sequence
|
||||
|
|
@ -198,7 +200,9 @@ ERROR: slice-error reason ;
|
|||
slice construct-boa ; inline
|
||||
|
||||
M: slice virtual-seq slice-seq ;
|
||||
|
||||
M: slice virtual@ [ slice-from + ] keep slice-seq ;
|
||||
|
||||
M: slice length dup slice-to swap slice-from - ;
|
||||
|
||||
: head-slice ( seq n -- slice ) (head) <slice> ;
|
||||
|
|
@ -466,6 +470,21 @@ M: sequence <=>
|
|||
2dup [ length ] bi@ number=
|
||||
[ 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 -- )
|
||||
2over number=
|
||||
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
|
||||
|
|
@ -692,14 +711,3 @@ PRIVATE>
|
|||
dup [ length ] map infimum
|
||||
[ <column> dup like ] with map
|
||||
] 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 ;
|
||||
|
||||
: 2seq>assoc ( keys values exemplar -- assoc )
|
||||
>r 2array flip r> assoc-like ;
|
||||
|
||||
: generate-key ( assoc -- str )
|
||||
>r 256 random-bits >hex r>
|
||||
2dup key? [ nip generate-key ] [ drop ] if ;
|
||||
|
|
|
|||
|
|
@ -106,7 +106,7 @@ IN: builder
|
|||
+closed+ >>stdin
|
||||
"../test-log" >>stdout
|
||||
+stdout+ >>stderr
|
||||
120 minutes >>timeout ;
|
||||
240 minutes >>timeout ;
|
||||
|
||||
: do-builder-test ( -- )
|
||||
builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;
|
||||
|
|
|
|||
|
|
@ -11,14 +11,19 @@ TUPLE: db
|
|||
update-statements
|
||||
delete-statements ;
|
||||
|
||||
: <db> ( handle -- obj )
|
||||
H{ } clone H{ } clone H{ } clone
|
||||
db construct-boa ;
|
||||
: construct-db ( class -- obj )
|
||||
construct-empty
|
||||
H{ } clone >>insert-statements
|
||||
H{ } clone >>update-statements
|
||||
H{ } clone >>delete-statements ;
|
||||
|
||||
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 -- )
|
||||
: make-db ( seq class -- db ) construct-empty make-db* ;
|
||||
|
||||
: dispose-statements ( seq -- ) [ dispose drop ] assoc-each ;
|
||||
|
||||
|
|
@ -30,10 +35,13 @@ HOOK: db-close db ( handle -- )
|
|||
handle>> db-close
|
||||
] with-variable ;
|
||||
|
||||
! TUPLE: sql sql in-params out-params ;
|
||||
TUPLE: statement handle sql in-params out-params bind-params bound? ;
|
||||
TUPLE: simple-statement ;
|
||||
TUPLE: prepared-statement ;
|
||||
TUPLE: nonthrowable-statement ;
|
||||
TUPLE: simple-statement < statement ;
|
||||
TUPLE: prepared-statement < statement ;
|
||||
TUPLE: nonthrowable-statement < statement ;
|
||||
TUPLE: throwable-statement < statement ;
|
||||
|
||||
: make-nonthrowable ( obj -- obj' )
|
||||
dup sequence? [
|
||||
[ make-nonthrowable ] map
|
||||
|
|
@ -41,14 +49,13 @@ TUPLE: nonthrowable-statement ;
|
|||
nonthrowable-statement construct-delegate
|
||||
] 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 ;
|
||||
: <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: <prepared-statement> db ( str in out -- statement )
|
||||
|
|
@ -88,11 +95,14 @@ M: nonthrowable-statement execute-statement ( statement -- )
|
|||
dup #rows >>max
|
||||
0 >>n drop ;
|
||||
|
||||
: <result-set> ( query handle tuple -- result-set )
|
||||
>r >r { sql>> in-params>> out-params>> } get-slots r>
|
||||
{ (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set
|
||||
construct r> construct-delegate ;
|
||||
|
||||
: construct-result-set ( query handle class -- result-set )
|
||||
construct-empty
|
||||
swap >>handle
|
||||
>r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
|
||||
swap >>out-params
|
||||
swap >>in-params
|
||||
swap >>sql ;
|
||||
|
||||
: sql-row ( result-set -- seq )
|
||||
dup #columns [ row-column ] with map ;
|
||||
|
||||
|
|
@ -110,7 +120,7 @@ M: nonthrowable-statement execute-statement ( statement -- )
|
|||
accumulator >r query-each r> { } like ; inline
|
||||
|
||||
: 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 ;
|
||||
|
||||
: default-query ( query -- result-set )
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@ IN: db.postgresql.ffi
|
|||
|
||||
<< "postgresql" {
|
||||
{ [ 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" ] }
|
||||
} cond "cdecl" add-library >>
|
||||
|
||||
|
|
|
|||
|
|
@ -5,40 +5,39 @@ kernel math math.parser namespaces prettyprint quotations
|
|||
sequences debugger db db.postgresql.lib db.postgresql.ffi
|
||||
db.tuples db.types tools.annotations math.ranges
|
||||
combinators sequences.lib classes locals words tools.walker
|
||||
namespaces.lib ;
|
||||
namespaces.lib accessors ;
|
||||
IN: db.postgresql
|
||||
|
||||
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
|
||||
TUPLE: postgresql-statement ;
|
||||
INSTANCE: postgresql-statement throwable-statement
|
||||
TUPLE: postgresql-result-set ;
|
||||
TUPLE: postgresql-db < db
|
||||
host port pgopts pgtty db user pass ;
|
||||
|
||||
TUPLE: postgresql-statement < throwable-statement ;
|
||||
|
||||
TUPLE: postgresql-result-set < result-set ;
|
||||
|
||||
: <postgresql-statement> ( statement in out -- postgresql-statement )
|
||||
<statement>
|
||||
postgresql-statement construct-delegate ;
|
||||
postgresql-statement construct-statement ;
|
||||
|
||||
M: postgresql-db make-db* ( seq tuple -- db )
|
||||
>r first4 r> [
|
||||
{
|
||||
set-postgresql-db-host
|
||||
set-postgresql-db-user
|
||||
set-postgresql-db-pass
|
||||
set-postgresql-db-db
|
||||
} set-slots
|
||||
] keep ;
|
||||
>r first4 r>
|
||||
swap >>db
|
||||
swap >>pass
|
||||
swap >>user
|
||||
swap >>host ;
|
||||
|
||||
M: postgresql-db db-open ( db -- )
|
||||
dup {
|
||||
postgresql-db-host
|
||||
postgresql-db-port
|
||||
postgresql-db-pgopts
|
||||
postgresql-db-pgtty
|
||||
postgresql-db-db
|
||||
postgresql-db-user
|
||||
postgresql-db-pass
|
||||
} get-slots connect-postgres <db> swap set-delegate ;
|
||||
M: postgresql-db db-open ( db -- db )
|
||||
dup {
|
||||
[ host>> ]
|
||||
[ port>> ]
|
||||
[ pgopts>> ]
|
||||
[ pgtty>> ]
|
||||
[ db>> ]
|
||||
[ user>> ]
|
||||
[ pass>> ]
|
||||
} cleave connect-postgres >>handle ;
|
||||
|
||||
M: postgresql-db dispose ( db -- )
|
||||
db-handle PQfinish ;
|
||||
handle>> PQfinish ;
|
||||
|
||||
M: postgresql-statement bind-statement* ( statement -- )
|
||||
drop ;
|
||||
|
|
@ -50,10 +49,10 @@ M: postgresql-statement bind-tuple ( tuple statement -- )
|
|||
] keep set-statement-bind-params ;
|
||||
|
||||
M: postgresql-result-set #rows ( result-set -- n )
|
||||
result-set-handle PQntuples ;
|
||||
handle>> PQntuples ;
|
||||
|
||||
M: postgresql-result-set #columns ( result-set -- n )
|
||||
result-set-handle PQnfields ;
|
||||
handle>> PQnfields ;
|
||||
|
||||
M: postgresql-result-set row-column ( result-set column -- obj )
|
||||
>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
|
||||
] if*
|
||||
postgresql-result-set <result-set>
|
||||
postgresql-result-set construct-result-set
|
||||
dup init-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 -- )
|
||||
[
|
||||
>r db get db-handle "" r>
|
||||
>r db get handle>> "" r>
|
||||
dup statement-sql swap statement-in-params
|
||||
length f PQprepare postgresql-error
|
||||
] keep set-statement-handle ;
|
||||
|
|
|
|||
|
|
@ -5,61 +5,48 @@ hashtables io.files kernel math math.parser namespaces
|
|||
prettyprint sequences strings classes.tuple alien.c-types
|
||||
continuations db.sqlite.lib db.sqlite.ffi db.tuples
|
||||
words combinators.lib db.types combinators
|
||||
io namespaces.lib ;
|
||||
USE: tools.walker
|
||||
io namespaces.lib accessors ;
|
||||
IN: db.sqlite
|
||||
|
||||
TUPLE: sqlite-db path ;
|
||||
TUPLE: sqlite-db < db path ;
|
||||
|
||||
M: sqlite-db make-db* ( path db -- db )
|
||||
[ set-sqlite-db-path ] keep ;
|
||||
swap >>path ;
|
||||
|
||||
M: sqlite-db db-open ( db -- )
|
||||
dup sqlite-db-path sqlite-open <db>
|
||||
swap set-delegate ;
|
||||
M: sqlite-db db-open ( db -- db )
|
||||
[ path>> sqlite-open ] [ swap >>handle ] bi ;
|
||||
|
||||
M: sqlite-db db-close ( handle -- ) sqlite-close ;
|
||||
M: sqlite-db dispose ( db -- ) dispose-db ;
|
||||
: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
|
||||
|
||||
TUPLE: sqlite-statement ;
|
||||
INSTANCE: sqlite-statement throwable-statement
|
||||
TUPLE: 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 )
|
||||
<prepared-statement> ;
|
||||
|
||||
M: sqlite-db <prepared-statement> ( str in out -- obj )
|
||||
{
|
||||
set-statement-sql
|
||||
set-statement-in-params
|
||||
set-statement-out-params
|
||||
} statement construct
|
||||
sqlite-statement construct-delegate ;
|
||||
sqlite-statement construct-statement ;
|
||||
|
||||
: sqlite-maybe-prepare ( statement -- statement )
|
||||
dup statement-handle [
|
||||
[
|
||||
delegate
|
||||
db get db-handle over statement-sql sqlite-prepare
|
||||
swap set-statement-handle
|
||||
] keep
|
||||
dup handle>> [
|
||||
db get handle>> over sql>> sqlite-prepare
|
||||
>>handle
|
||||
] unless ;
|
||||
|
||||
M: sqlite-statement dispose ( statement -- )
|
||||
statement-handle
|
||||
handle>>
|
||||
[ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
|
||||
|
||||
M: sqlite-result-set dispose ( result-set -- )
|
||||
f swap set-result-set-handle ;
|
||||
f >>handle drop ;
|
||||
|
||||
: sqlite-bind ( triples handle -- )
|
||||
swap [ first3 sqlite-bind-type ] with each ;
|
||||
|
||||
: reset-statement ( statement -- )
|
||||
sqlite-maybe-prepare
|
||||
statement-handle sqlite-reset ;
|
||||
sqlite-maybe-prepare handle>> sqlite-reset ;
|
||||
|
||||
M: sqlite-statement bind-statement* ( statement -- )
|
||||
sqlite-maybe-prepare
|
||||
|
|
@ -69,11 +56,11 @@ M: sqlite-statement bind-statement* ( statement -- )
|
|||
|
||||
M: sqlite-statement bind-tuple ( tuple statement -- )
|
||||
[
|
||||
statement-in-params
|
||||
in-params>>
|
||||
[
|
||||
[ sql-spec-column-name ":" prepend ]
|
||||
[ sql-spec-slot-name rot get-slot-named ]
|
||||
[ sql-spec-type ] tri 3array
|
||||
[ column-name>> ":" prepend ]
|
||||
[ slot-name>> rot get-slot-named ]
|
||||
[ type>> ] tri 3array
|
||||
] with map
|
||||
] keep
|
||||
bind-statement ;
|
||||
|
|
@ -86,25 +73,24 @@ M: sqlite-db insert-tuple* ( tuple statement -- )
|
|||
execute-statement last-insert-id swap set-primary-key ;
|
||||
|
||||
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 )
|
||||
>r result-set-handle r> sqlite-column ;
|
||||
[ handle>> ] [ sqlite-column ] bi* ;
|
||||
|
||||
M: sqlite-result-set row-column-typed ( result-set n -- obj )
|
||||
dup pick result-set-out-params nth sql-spec-type
|
||||
>r >r result-set-handle r> r> sqlite-column-typed ;
|
||||
dup pick out-params>> nth type>>
|
||||
>r >r handle>> r> r> sqlite-column-typed ;
|
||||
|
||||
M: sqlite-result-set advance-row ( result-set -- )
|
||||
[ result-set-handle sqlite-next ] keep
|
||||
set-sqlite-result-set-has-more? ;
|
||||
dup handle>> sqlite-next >>has-more? drop ;
|
||||
|
||||
M: sqlite-result-set more-rows? ( result-set -- ? )
|
||||
sqlite-result-set-has-more? ;
|
||||
has-more?>> ;
|
||||
|
||||
M: sqlite-statement query-results ( query -- result-set )
|
||||
sqlite-maybe-prepare
|
||||
dup statement-handle sqlite-result-set <result-set>
|
||||
dup handle>> sqlite-result-set construct-result-set
|
||||
dup advance-row ;
|
||||
|
||||
M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
|
||||
|
|
@ -119,9 +105,9 @@ M: sqlite-db create-sql-statement ( class -- statement )
|
|||
[
|
||||
"create table " 0% 0%
|
||||
"(" 0% [ ", " 0% ] [
|
||||
dup sql-spec-column-name 0%
|
||||
dup column-name>> 0%
|
||||
" " 0%
|
||||
dup sql-spec-type t lookup-type 0%
|
||||
dup type>> t lookup-type 0%
|
||||
modifiers 0%
|
||||
] interleave ");" 0%
|
||||
] sqlite-make ;
|
||||
|
|
@ -134,7 +120,7 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
|
|||
"insert into " 0% 0%
|
||||
"(" 0%
|
||||
maybe-remove-id
|
||||
dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
|
||||
dup [ ", " 0% ] [ column-name>> 0% ] interleave
|
||||
") values(" 0%
|
||||
[ ", " 0% ] [ bind% ] interleave
|
||||
");" 0%
|
||||
|
|
@ -145,11 +131,11 @@ M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
|
|||
|
||||
: where-primary-key% ( specs -- )
|
||||
" 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 " 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 )
|
||||
[
|
||||
|
|
@ -157,7 +143,7 @@ M: sqlite-db <update-tuple-statement> ( class -- statement )
|
|||
0%
|
||||
" set " 0%
|
||||
dup remove-id
|
||||
[ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
|
||||
[ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
|
||||
where-primary-key%
|
||||
] sqlite-make ;
|
||||
|
||||
|
|
@ -166,23 +152,23 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
|
|||
"delete from " 0% 0%
|
||||
" where " 0%
|
||||
find-primary-key
|
||||
dup sql-spec-column-name 0% " = " 0% bind%
|
||||
dup column-name>> 0% " = " 0% bind%
|
||||
] sqlite-make ;
|
||||
|
||||
! : select-interval ( interval name -- ) ;
|
||||
! : select-sequence ( seq name -- ) ;
|
||||
|
||||
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 )
|
||||
[
|
||||
"select " 0%
|
||||
over [ ", " 0% ]
|
||||
[ dup sql-spec-column-name 0% 2, ] interleave
|
||||
[ dup column-name>> 0% 2, ] interleave
|
||||
|
||||
" 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%
|
||||
] sqlite-make ;
|
||||
|
||||
|
|
|
|||
|
|
@ -260,10 +260,10 @@ C: <secret> secret
|
|||
! [ test-random-id ] test-sqlite
|
||||
[ native-person-schema test-tuples ] test-sqlite
|
||||
[ assigned-person-schema test-tuples ] test-sqlite
|
||||
! [ assigned-person-schema test-repeated-insert ] test-sqlite
|
||||
! [ native-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-sqlite
|
||||
[ native-person-schema test-tuples ] test-postgresql
|
||||
[ assigned-person-schema test-tuples ] test-postgresql
|
||||
[ assigned-person-schema test-repeated-insert ] test-postgresql
|
||||
|
||||
! \ insert-tuple must-infer
|
||||
! \ update-tuple must-infer
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@ USING: system ;
|
|||
IN: hardware-info.backend
|
||||
|
||||
HOOK: cpus os ( -- n )
|
||||
HOOK: cpu-mhz os ( -- n )
|
||||
HOOK: memory-load os ( -- n )
|
||||
HOOK: physical-mem os ( -- n )
|
||||
HOOK: available-mem os ( -- n )
|
||||
|
|
|
|||
|
|
@ -3,11 +3,12 @@ combinators vocabs.loader hardware-info.backend system ;
|
|||
IN: hardware-info
|
||||
|
||||
: 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 ;
|
||||
: megs ( x -- ) 20 "MB" write-unit ;
|
||||
: gigs ( x -- ) 30 "GB" write-unit ;
|
||||
: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
|
||||
|
||||
<< {
|
||||
{ [ os windows? ] [ "hardware-info.windows" ] }
|
||||
|
|
@ -18,4 +19,5 @@ IN: hardware-info
|
|||
|
||||
: hardware-report. ( -- )
|
||||
"CPUs: " write cpus number>string write nl
|
||||
"CPU Speed: " write cpu-mhz ghz 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 ;
|
||||
: vector-unit ( -- n ) { 6 13 } 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 ;
|
||||
: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
|
||||
: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: io.windows.launcher.nt.tests
|
||||
USING: io.launcher tools.test calendar accessors
|
||||
namespaces kernel system arrays io io.files io.encodings.ascii
|
||||
sequences parser assocs hashtables ;
|
||||
sequences parser assocs hashtables math ;
|
||||
|
||||
[ ] [
|
||||
<process>
|
||||
|
|
@ -129,3 +129,14 @@ sequences parser assocs hashtables ;
|
|||
|
||||
"HOME" swap at "XXX" =
|
||||
] 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
|
||||
FILE_ATTRIBUTE_NORMAL ! flags and attributes
|
||||
f ! template file
|
||||
CreateFile dup invalid-handle? dup close-later ;
|
||||
CreateFile dup invalid-handle? dup close-always ;
|
||||
|
||||
: set-inherit ( handle ? -- )
|
||||
>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
|
||||
"multi-method" word-prop method-generic stack-effect ;
|
||||
|
||||
M: method-body crossref?
|
||||
drop t ;
|
||||
|
||||
: method-word-name ( classes generic -- string )
|
||||
[
|
||||
word-name %
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
|
||||
USING: kernel sequences assocs qualified ;
|
||||
USING: kernel sequences assocs qualified circular ;
|
||||
|
||||
QUALIFIED: sequences
|
||||
QUALIFIED: circular
|
||||
|
||||
IN: newfx
|
||||
|
||||
|
|
@ -53,8 +54,10 @@ IN: newfx
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: push ( seq obj -- seq ) over sequences:push ;
|
||||
: push-on ( obj seq -- seq ) tuck sequences:push ;
|
||||
: push ( seq obj -- seq ) over 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
|
||||
! their primary object. However, the 'mutate' qualifier is supposed to
|
||||
! indicate that this is the main objective of the word, as a side effect.
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2007, 2008 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences strings fry namespaces math assocs shuffle
|
||||
vectors arrays combinators.lib math.parser
|
||||
unicode.categories sequences.lib compiler.units parser
|
||||
vectors arrays math.parser
|
||||
unicode.categories compiler.units parser
|
||||
words quotations effects memoize accessors locals effects splitting ;
|
||||
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.constants
|
||||
math.functions
|
||||
math.points
|
||||
|
||||
ui
|
||||
ui.gadgets
|
||||
|
|
@ -21,13 +22,7 @@ USING: kernel namespaces sequences combinators arrays threads
|
|||
processing.gadget
|
||||
processing.color ;
|
||||
|
||||
IN: bubble-chamber
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
|
||||
|
||||
: 1random ( b -- num ) 0 swap 2random ;
|
||||
IN: processing.gallery.bubble-chamber
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -82,17 +77,8 @@ VARS: particles muons quarks hadrons axions ;
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: x>> ( particle -- x ) pos>> first ;
|
||||
: 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 ;
|
||||
: x ( particle -- x ) pos>> first ;
|
||||
: y ( particle -- x ) pos>> second ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -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: move ( particle -- )
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: muon pos speed theta speed-d theta-d theta-dd myc mya ;
|
||||
TUPLE: muon < particle ;
|
||||
|
||||
: <muon> ( -- muon )
|
||||
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 ;
|
||||
: <muon> ( -- muon ) muon construct-empty initialize-particle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -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 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 ;
|
||||
: <quark> ( -- quark ) quark construct-empty initialize-particle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -228,7 +216,8 @@ METHOD: move { quark }
|
|||
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
|
||||
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
|
||||
|
||||
1000 random 997 >
|
||||
! 1000 random 997 >
|
||||
3/1000 chance
|
||||
[
|
||||
dup speed>> neg >>speed
|
||||
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 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 ;
|
||||
: <hadron> ( -- hadron ) hadron construct-empty initialize-particle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -296,12 +276,14 @@ METHOD: move { hadron }
|
|||
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
|
||||
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
|
||||
|
||||
1000 random 997 >
|
||||
! 1000 random 997 >
|
||||
3/1000 chance
|
||||
[
|
||||
1.0 >>speed-d
|
||||
0.00001 >>theta-dd
|
||||
|
||||
100 random 70 >
|
||||
! 100 random 70 >
|
||||
30/100 chance
|
||||
[
|
||||
dim 2 / dup 2array >>pos
|
||||
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 construct-empty
|
||||
0 0 2array >>pos
|
||||
0 0 2array >>vel
|
||||
0 >>speed
|
||||
0 >>speed-d
|
||||
0 >>theta
|
||||
0 >>theta-d
|
||||
0 >>theta-dd ;
|
||||
: <axion> ( -- axion ) axion construct-empty initialize-particle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -381,12 +355,14 @@ METHOD: move { axion }
|
|||
|
||||
[ ] [ speed-d>> 0.9999 * ] bi >>speed-d
|
||||
|
||||
1000 random 996 >
|
||||
! 1000 random 996 >
|
||||
4/1000 chance
|
||||
[
|
||||
dup speed>> neg >>speed
|
||||
dup speed-d>> neg 2 + >>speed-d
|
||||
|
||||
100 random 30 >
|
||||
! 100 random 30 >
|
||||
70/100 chance
|
||||
[
|
||||
dim 2 / dup 2array >>pos
|
||||
collide
|
||||
|
|
@ -472,6 +448,6 @@ METHOD: move { axion }
|
|||
|
||||
;
|
||||
|
||||
: go ( -- ) [ bubble-chamber 500 sleep run ] with-ui ;
|
||||
: go ( -- ) [ bubble-chamber run ] with-ui ;
|
||||
|
||||
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
|
||||
math math.functions
|
||||
math math.functions math.ranges random
|
||||
opengl.gl opengl.glu vars multi-methods shuffle
|
||||
ui
|
||||
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: stroke-color
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
USING: combinators.lib kernel sequences math namespaces assocs
|
||||
random sequences.private shuffle math.functions mirrors
|
||||
arrays math.parser math.private sorting strings ascii macros
|
||||
assocs.lib quotations ;
|
||||
assocs.lib quotations hashtables ;
|
||||
IN: sequences.lib
|
||||
|
||||
: 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 )
|
||||
[ rot slip + ] curry 0 swap reduce ; inline
|
||||
|
||||
|
|
@ -221,7 +231,7 @@ PRIVATE>
|
|||
[ swap nth ] with map ;
|
||||
|
||||
: replace ( str oldseq newseq -- str' )
|
||||
H{ } 2seq>assoc substitute ;
|
||||
zip >hashtable substitute ;
|
||||
|
||||
: remove-nth ( seq n -- seq' )
|
||||
cut-slice 1 tail-slice append ;
|
||||
|
|
|
|||
|
|
@ -26,8 +26,7 @@ M: pair make-disassemble-cmd
|
|||
M: method-spec make-disassemble-cmd
|
||||
first2 method make-disassemble-cmd ;
|
||||
|
||||
: gdb-binary ( -- string )
|
||||
os freebsd? "gdb66" "gdb" ? ;
|
||||
: gdb-binary ( -- string ) "gdb" ;
|
||||
|
||||
: run-gdb ( -- lines )
|
||||
<process>
|
||||
|
|
|
|||
|
|
@ -1,4 +1,8 @@
|
|||
USING: tools.test tools.memory ;
|
||||
IN: tools.memory.tests
|
||||
|
||||
\ room. must-infer
|
||||
[ ] [ room. ] unit-test
|
||||
|
||||
\ heap-stats. must-infer
|
||||
[ ] [ 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.
|
||||
USING: kernel sequences vectors arrays generic assocs io math
|
||||
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
|
||||
|
||||
<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-cell
|
||||
dup number>string write-cell
|
||||
over - number>string write-cell
|
||||
number>string write-cell
|
||||
dup write-size
|
||||
over - write-size
|
||||
write-size
|
||||
] with-row ;
|
||||
|
||||
: write-total ( n str -- )
|
||||
[
|
||||
write-cell
|
||||
number>string write-cell
|
||||
write-size
|
||||
[ ] with-cell
|
||||
[ ] with-cell
|
||||
] with-row ;
|
||||
|
|
@ -25,26 +32,41 @@ IN: tools.memory
|
|||
[ [ write-cell ] each ] with-row ;
|
||||
|
||||
: (data-room.) ( -- )
|
||||
data-room 2 <groups> 0 [
|
||||
"Generation " pick number>string append
|
||||
>r first2 r> write-total/used/free 1+
|
||||
] reduce drop
|
||||
data-room 2 <groups> dup length [
|
||||
[ first2 ] [ number>string "Generation " prepend ] bi*
|
||||
write-total/used/free
|
||||
] 2each
|
||||
"Cards" write-total ;
|
||||
|
||||
: (code-room.) ( -- )
|
||||
code-room "Code space" write-total/used/free ;
|
||||
: write-labelled-size ( n string -- )
|
||||
[ write-cell write-size ] with-row ;
|
||||
|
||||
: room. ( -- )
|
||||
standard-table-style [
|
||||
{ "" "Total" "Used" "Free" } write-headings
|
||||
(data-room.)
|
||||
(code-room.)
|
||||
] tabular-output ;
|
||||
: (code-room.) ( -- )
|
||||
code-room {
|
||||
[ "Size:" write-labelled-size ]
|
||||
[ "Used:" write-labelled-size ]
|
||||
[ "Total free space:" write-labelled-size ]
|
||||
[ "Largest free block:" write-labelled-size ]
|
||||
} spread ;
|
||||
|
||||
: heap-stat-step ( counts sizes obj -- )
|
||||
[ dup size swap class rot at+ ] keep
|
||||
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 )
|
||||
H{ } clone H{ } clone
|
||||
[ >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
|
||||
tools.test ui.commands ui.gadgets ui.gadgets.editors
|
||||
ui.gadgets.panes vocabs words tools.test.ui slots.private
|
||||
threads ;
|
||||
threads arrays generic ;
|
||||
IN: ui.tools.listener.tests
|
||||
|
||||
[ f ] [ "word" source-editor command-map empty? ] unit-test
|
||||
|
|
@ -13,11 +13,11 @@ IN: ui.tools.listener.tests
|
|||
|
||||
"listener" get [
|
||||
[ "dup" ] [
|
||||
\ dup "listener" get word-completion-string
|
||||
\ dup word-completion-string
|
||||
] unit-test
|
||||
|
||||
[ "USE: slots.private slot" ]
|
||||
[ \ slot "listener" get word-completion-string ] unit-test
|
||||
[ "equal?" ]
|
||||
[ \ array \ equal? method word-completion-string ] unit-test
|
||||
|
||||
<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.tracks ui.gestures ui.operations vocabs words
|
||||
prettyprint listener debugger threads boxes concurrency.flags
|
||||
math arrays generic accessors ;
|
||||
math arrays generic accessors combinators ;
|
||||
IN: ui.tools.listener
|
||||
|
||||
TUPLE: listener-gadget input output stack ;
|
||||
|
|
@ -101,26 +101,32 @@ M: listener-operation invoke-command ( target command -- )
|
|||
: clear-stack ( 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
|
||||
>r "method-generic" word-prop r> word-completion-string ;
|
||||
"method-generic" word-prop word-completion-string ;
|
||||
|
||||
USE: generic.standard.engines.tuple
|
||||
|
||||
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 )
|
||||
>r [ word-name ] [ word-vocabulary ] bi dup vocab-words r>
|
||||
input>> interactor-use memq?
|
||||
[ drop ] [ [ "USE: " % % " " % % ] "" make ] if ;
|
||||
: use-if-necessary ( word seq -- )
|
||||
>r word-vocabulary vocab-words r>
|
||||
{
|
||||
{ [ dup not ] [ 2drop ] }
|
||||
{ [ 2dup memq? ] [ 2drop ] }
|
||||
{ [ t ] [ push ] }
|
||||
} cond ;
|
||||
|
||||
: insert-word ( word -- )
|
||||
get-workspace
|
||||
workspace-listener
|
||||
[ word-completion-string ] keep
|
||||
input>> user-input ;
|
||||
get-workspace workspace-listener input>>
|
||||
[ >r word-completion-string r> user-input ]
|
||||
[ interactor-use use-if-necessary ]
|
||||
2bi ;
|
||||
|
||||
: quot-action ( interactor -- lines )
|
||||
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);
|
||||
}
|
||||
|
||||
/* Compute total sum of sizes of free blocks */
|
||||
CELL heap_usage(F_HEAP *heap, F_BLOCK_STATUS status)
|
||||
/* Compute total sum of sizes of free blocks, and size of largest free block */
|
||||
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);
|
||||
|
||||
while(scan)
|
||||
{
|
||||
if(scan->status == status)
|
||||
size += scan->size;
|
||||
switch(scan->status)
|
||||
{
|
||||
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);
|
||||
}
|
||||
|
||||
return size;
|
||||
}
|
||||
|
||||
/* 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 */
|
||||
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(used / 1024));
|
||||
dpush(tag_fixnum(total_free / 1024));
|
||||
dpush(tag_fixnum(max_free / 1024));
|
||||
}
|
||||
|
||||
/* 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);
|
||||
void unmark_marked(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);
|
||||
|
||||
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 */
|
||||
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);
|
||||
}
|
||||
}
|
||||
|
||||
return start;
|
||||
|
|
|
|||
|
|
@ -315,8 +315,6 @@ INLINE void* allot_object(CELL type, CELL a)
|
|||
{
|
||||
CELL *object;
|
||||
|
||||
/* If the object is bigger than the nursery, allocate it in
|
||||
tenured space */
|
||||
if(nursery->size - ALLOT_BUFFER_ZONE > a)
|
||||
{
|
||||
/* 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);
|
||||
}
|
||||
/* If the object is bigger than the nursery, allocate it in
|
||||
tenured space */
|
||||
else
|
||||
{
|
||||
F_ZONE *tenured = &data_heap->generations[TENURED];
|
||||
|
|
|
|||
|
|
@ -145,3 +145,9 @@ DEFINE_PRIMITIVE(call_clear)
|
|||
{
|
||||
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 divide_by_zero_signal_handler_impl(void);
|
||||
void misc_signal_handler_impl(void);
|
||||
|
||||
DECLARE_PRIMITIVE(unimplemented);
|
||||
|
|
|
|||
|
|
@ -215,7 +215,7 @@ void sleep_millis(DWORD msec)
|
|||
Sleep(msec);
|
||||
}
|
||||
|
||||
DECLARE_PRIMITIVE(set_os_envs)
|
||||
DEFINE_PRIMITIVE(set_os_envs)
|
||||
{
|
||||
not_implemented_error();
|
||||
}
|
||||
|
|
|
|||
|
|
@ -187,4 +187,5 @@ void *primitives[] = {
|
|||
primitive_resize_bit_array,
|
||||
primitive_resize_float_array,
|
||||
primitive_dll_validp,
|
||||
primitive_unimplemented,
|
||||
};
|
||||
|
|
|
|||
Loading…
Reference in New Issue