Merge commit 'origin/master'

db4
Chris Double 2008-04-09 10:49:26 +12:00
commit c39ece54a1
52 changed files with 604 additions and 299 deletions

View File

@ -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
} }

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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=

View File

@ -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 -- )

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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:"

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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." }

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 )

View File

@ -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 >>

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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 )

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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- ;

View File

@ -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 %

View File

@ -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.

View File

@ -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

View File

@ -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." ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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>

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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 */

View File

@ -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)

View File

@ -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;

View File

@ -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];

View File

@ -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();
}

View File

@ -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);

View File

@ -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();
} }

View File

@ -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,
}; };