steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge git://factorcode.org/git/factor

db4
Eduardo Cavazos 2008-02-28 00:03:35 -06:00
parent bef1d40964 260acff952
commit cc0bafecc6
41 changed files with 397 additions and 255 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/alien/compiler/compiler.factor
View File

@ -367,7 +367,7 @@ TUPLE: callback-context ;
] if ;
: do-callback ( quot token -- )
init-error-handler
init-catchstack
dup 2 setenv
slip
wait-to-return ; inline

13
core/bootstrap/stage1.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: bootstrap.stage1
USING: arrays debugger generic hashtables io assocs
kernel.private kernel math memory namespaces parser
prettyprint sequences vectors words system splitting
init io.files bootstrap.image bootstrap.image.private vocabs
vocabs.loader system ;
vocabs.loader system debugger continuations ;
{ "resource:core" } vocab-roots set
@ -40,7 +40,14 @@ vocabs.loader system ;
[
"resource:core/bootstrap/stage2.factor"
dup resource-exists? [
run-file
[ run-file ]
[
:c
dup print-error flush
"listener" vocab
[ restarts. vocab-main execute ]
[ die ] if*
] recover
] [
"Cannot find " write write "." print
"Please move " write image write " to the same directory as the Factor sources," print

104
core/bootstrap/stage2.factor
View File

@ -51,66 +51,60 @@ SYMBOL: bootstrap-time
! Wrap everything in a catch which starts a listener so
! you can see what went wrong, instead of dealing with a
! fep
[
! We time bootstrap
millis >r
default-image-name "output-image" set-global
! We time bootstrap
millis >r
"math help handbook compiler tools ui ui.tools io" "include" set-global
"" "exclude" set-global
default-image-name "output-image" set-global
parse-command-line
"math help handbook compiler tools ui ui.tools io" "include" set-global
"" "exclude" set-global
"-no-crossref" cli-args member? [ do-crossref ] unless
parse-command-line
! Set dll paths
wince? [ "windows.ce" require ] when
winnt? [ "windows.nt" require ] when
"-no-crossref" cli-args member? [ do-crossref ] unless
"deploy-vocab" get [
"stage2: deployment mode" print
] [
"listener" require
"none" require
] if
! Set dll paths
wince? [ "windows.ce" require ] when
winnt? [ "windows.nt" require ] when
[
load-components
run-bootstrap-init
"bootstrap.compiler" vocab [
compile-remaining
] when
] with-compiler-errors
:errors
f error set-global
f error-continuation set-global
"deploy-vocab" get [
"tools.deploy.shaker" run
] [
[
boot
do-init-hooks
[
parse-command-line
run-user-init
"run" get run
stdio get [ stream-flush ] when*
] [ print-error 1 exit ] recover
] set-boot-quot
millis r> - dup bootstrap-time set-global
print-report
"output-image" get resource-path save-image-and-exit
] if
"deploy-vocab" get [
"stage2: deployment mode" print
] [
:c
print-error restarts.
"listener" vocab-main execute
1 exit
] recover
"listener" require
"none" require
] if
[
load-components
run-bootstrap-init
"bootstrap.compiler" vocab [
compile-remaining
] when
] with-compiler-errors
:errors
f error set-global
f error-continuation set-global
"deploy-vocab" get [
"tools.deploy.shaker" run
] [
[
boot
do-init-hooks
[
parse-command-line
run-user-init
"run" get run
stdio get [ stream-flush ] when*
] [ print-error 1 exit ] recover
] set-boot-quot
millis r> - dup bootstrap-time set-global
print-report
"output-image" get resource-path save-image-and-exit
] if

3
core/continuations/continuations-docs.factor
View File

@ -193,6 +193,3 @@ HELP: save-error
{ $values { "error" "an error" } }
{ $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." }
$low-level-note ;
HELP: init-error-handler
{ $description "Called on startup to initialize the catch stack and set a pair of hooks which allow the Factor VM to signal errors to library code." } ;

17
core/continuations/continuations.factor
View File

@ -6,6 +6,7 @@ IN: continuations
SYMBOL: error
SYMBOL: error-continuation
SYMBOL: error-thread
SYMBOL: restarts
<PRIVATE
@ -24,6 +25,8 @@ SYMBOL: restarts
#! with a declaration.
f { object } declare ;
: init-catchstack V{ } clone 1 setenv ;
PRIVATE>
: catchstack ( -- catchstack ) catchstack* clone ; inline
@ -169,17 +172,3 @@ M: condition compute-restarts
condition-continuation
[ <restart> ] curry { } assoc>map
append ;
<PRIVATE
: init-error-handler ( -- )
V{ } clone set-catchstack
! VM calls on error
[
continuation error-continuation set-global rethrow
] 5 setenv
! VM adds this to kernel errors, so that user-space
! can identify them
"kernel-error" 6 setenv ;
PRIVATE>

8
core/debugger/debugger-docs.factor
View File

@ -1,6 +1,6 @@
USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes
help generic.standard continuations system ;
help generic.standard continuations system debugger.private ;
IN: debugger
ARTICLE: "errors-assert" "Assertions"
@ -80,9 +80,6 @@ HELP: print-error
HELP: restarts.
{ $description "Print a list of restarts for the most recently thrown error to the " { $link stdio } " stream." } ;
HELP: debug-help
{ $description "Print a synopsis of useful debugger words." } ;
HELP: error-hook
{ $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." }
{ $examples "The default value prints the error with " { $link print-error } ", followed by a list of restarts and a help message. The graphical listener sets this variable to display a popup instead." } ;
@ -169,3 +166,6 @@ HELP: depth
HELP: assert-depth
{ $values { "quot" "a quotation" } }
{ $description "Runs a quotation. Throws an error if the total number of elements on the stack is not the same before and after the quotation runs." } ;
HELP: init-debugger
{ $description "Called on startup to set a pair of hooks which allow the " { $link throw } " word to function." } ;

62
core/debugger/debugger.factor
View File

@ -5,7 +5,8 @@ math namespaces prettyprint sequences assocs sequences.private
strings io.styles vectors words system splitting math.parser
tuples continuations continuations.private combinators
generic.math io.streams.duplex classes compiler.units
generic.standard vocabs ;
generic.standard vocabs threads threads.private init
kernel.private ;
IN: debugger
GENERIC: error. ( error -- )
@ -57,27 +58,30 @@ M: string error. print ;
dup length [ restart. ] 2each
] if ;
: debug-help ( -- )
nl
"Debugger commands:" print
nl
":help - documentation for this error" print
":s - data stack at exception time" print
":r - retain stack at exception time" print
":c - call stack at exception time" print
":edit - jump to source location (parse errors only)" print
":get ( var -- value ) accesses variables at time of the error" print
flush ;
: print-error ( error -- )
[ error. flush ] curry
[ global [ "Error in print-error!" print drop ] bind ]
recover ;
: error-in-thread. ( -- )
error-thread get-global
"Error in thread " write
[
dup thread-id #
" (" % dup thread-name %
", " % dup thread-quot unparse-short % ")" %
] "" make
swap write-object ":" print nl ;
SYMBOL: error-hook
[ print-error restarts. debug-help ] error-hook set-global
[
error-in-thread.
print-error
restarts.
nl
"Type :help for debugging help." print flush
] error-hook set-global
: try ( quot -- )
[ error-hook get call ] recover ;
@ -260,3 +264,31 @@ M: no-compilation-unit error.
M: no-vocab summary
drop "Vocabulary does not exist" ;
! Hooks
M: thread error-in-thread ( error thread -- )
initial-thread get-global eq? [
die drop
] [
global [
error-in-thread. print-error flush
] bind
] if ;
<PRIVATE
: init-debugger ( -- )
V{ } clone set-catchstack
! VM calls on error
[
self error-thread set-global
continuation error-continuation set-global
rethrow
] 5 setenv
! VM adds this to kernel errors, so that user-space
! can identify them
"kernel-error" 6 setenv ;
PRIVATE>
[ init-debugger ] "debugger" add-init-hook

7
core/init/init-tests.factor Normal file
View File

@ -0,0 +1,7 @@
IN: temporary
USING: init namespaces sequences math tools.test kernel ;
[ t ] [
init-hooks get [ first "libc" = ] find drop
init-hooks get [ first "io.backend" = ] find drop <
] unit-test

2
core/init/init.factor
View File

@ -15,7 +15,7 @@ init-hooks global [ drop V{ } clone ] cache drop
dup init-hooks get at [ over call ] unless
init-hooks get set-at ;
: boot ( -- ) init-namespaces init-error-handler ;
: boot ( -- ) init-namespaces init-catchstack ;
: boot-quot ( -- quot ) 20 getenv ;

2
core/libc/libc.factor
View File

@ -46,7 +46,7 @@ M: realloc-error summary drop "Memory reallocation failed" ;
<PRIVATE
[ H{ } clone mallocs set-global ] "mallocs" add-init-hook
[ H{ } clone mallocs set-global ] "libc" add-init-hook
: add-malloc ( alien -- )
dup mallocs get-global set-at ;

4
core/sequences/sequences-docs.factor
View File

@ -429,7 +429,7 @@ HELP: collect
HELP: each
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
{ $description "Applies the quotation to each element of the sequence in turn." } ;
{ $description "Applies the quotation to each element of the sequence in order." } ;
HELP: reduce
{ $values { "seq" sequence } { "identity" object } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "result" "the final result" } }
@ -447,7 +447,7 @@ HELP: accumulate
HELP: map
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each element yielding a new element. The new elements are collected into a sequence of the same class as the input sequence." } ;
{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ;
HELP: change-nth
{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } }

28
core/threads/threads.factor
View File

@ -4,13 +4,12 @@
IN: threads
USING: arrays hashtables heaps kernel kernel.private math
namespaces sequences vectors continuations continuations.private
dlists assocs system combinators debugger prettyprint io init
boxes ;
dlists assocs system combinators init boxes ;
SYMBOL: initial-thread
TUPLE: thread
name quot error-handler exit-handler
name quot exit-handler
id
continuation state
mailbox variables sleep-entry ;
@ -60,11 +59,10 @@ threads global [ H{ } assoc-like ] change-at
PRIVATE>
: <thread> ( quot name error-handler -- thread )
: <thread> ( quot name -- thread )
\ thread counter <box> [ ] {
set-thread-quot
set-thread-name
set-thread-error-handler
set-thread-id
set-thread-continuation
set-thread-exit-handler
@ -179,20 +177,8 @@ M: real sleep
] 1 (throw)
] "spawn" suspend 2drop ;
: default-thread-error-handler ( error thread -- )
global [
"Error in thread " write
dup thread-id pprint
" (" write
dup thread-name pprint ")" print
"spawned to call " write
thread-quot short.
nl
print-error flush
] bind ;
: spawn ( quot name -- thread )
[ default-thread-error-handler ] <thread> [ (spawn) ] keep ;
<thread> [ (spawn) ] keep ;
: spawn-server ( quot name -- thread )
>r [ [ ] [ ] while ] curry r> spawn ;
@ -202,6 +188,8 @@ M: real sleep
[ >r set-namestack set-datastack r> call ] 3curry
"Thread" spawn drop ;
GENERIC: error-in-thread ( error thread -- )
<PRIVATE
: init-threads ( -- )
@ -209,13 +197,13 @@ M: real sleep
<dlist> 42 setenv
<min-heap> 43 setenv
initial-thread global
[ drop f "Initial" [ die ] <thread> ] cache
[ drop f "Initial" <thread> ] cache
<box> over set-thread-continuation
f over set-thread-state
dup register-thread
set-self ;
[ self dup thread-error-handler call stop ]
[ self error-in-thread stop ]
thread-error-hook set-global
PRIVATE>

10
extra/benchmark/crc32/crc32.factor Normal file
View File

@ -0,0 +1,10 @@
USING: io.crc32 io.files kernel math ;
IN: benchmark.crc32
: crc32-primes-list ( -- )
10 [
"extra/math/primes/list/list.factor" resource-path
file-contents crc32 drop
] times ;
MAIN: crc32-primes-list

7
extra/benchmark/md5/md5.factor Normal file
View File

@ -0,0 +1,7 @@
USING: crypto.md5 io.files kernel ;
IN: benchmark.md5
: md5-primes-list ( -- )
"extra/math/primes/list/list.factor" resource-path file>md5 drop ;
MAIN: md5-primes-list

14
extra/benchmark/random/random.factor Normal file
View File

@ -0,0 +1,14 @@
USING: io.files random math.parser io math ;
IN: benchmark.random
: random-numbers-path "random-numbers.txt" temp-file ;
: write-random-numbers ( n -- )
random-numbers-path [
[ 200 random 100 - number>string print ] times
] with-file-writer ;
: random-main ( -- )
1000000 write-random-numbers ;
MAIN: random-main

5
extra/benchmark/sort/sort.factor
View File

@ -1,7 +1,8 @@
USING: kernel sequences sorting random ;
USING: kernel sequences sorting benchmark.random math.parser
io.files ;
IN: benchmark.sort
: sort-benchmark
100000 [ drop 100000 random ] map natural-sort drop ;
random-numbers-path file-lines [ string>number ] map natural-sort drop ;
MAIN: sort-benchmark

5
extra/benchmark/sum-file/sum-file.factor
View File

@ -1,4 +1,5 @@
USING: io io.files math math.parser kernel prettyprint ;
USING: io io.files math math.parser kernel prettyprint
benchmark.random ;
IN: benchmark.sum-file
: sum-file-loop ( n -- n' )
@ -8,6 +9,6 @@ IN: benchmark.sum-file
[ 0 sum-file-loop ] with-file-reader . ;
: sum-file-main ( -- )
home "sum-file-in.txt" path+ sum-file ;
random-numbers-path sum-file ;
MAIN: sum-file-main

2
extra/concurrency/combinators/combinators-tests.factor
View File

@ -11,7 +11,7 @@ concurrency.mailboxes threads sequences ;
[ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test
[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]
[ linked-error "Even" = ] must-fail-with
[ delegate "Even" = ] must-fail-with
[ V{ 0 3 6 9 } ]
[ 10 [ 3 mod zero? ] parallel-subset ] unit-test

7
extra/concurrency/flags/flags-docs.factor
View File

@ -14,6 +14,10 @@ HELP: raise-flag
{ $values { "flag" flag } }
{ $description "Raises a flag, notifying any threads waiting on it. Does nothing if the flag has already been raised." } ;
HELP: wait-for-flag
{ $values { "flag" flag } }
{ $description "Waits for a flag to be raised. If the flag has already been raised, returns immediately." } ;
HELP: lower-flag
{ $values { "flag" flag } }
{ $description "Attempts to lower a flag. If the flag has been raised previously, returns immediately, otherwise waits for it to be raised first." } ;
@ -26,8 +30,9 @@ $nl
"Essentially, a flag can be thought of as a counting semaphore where the count never goes above one."
{ $subsection flag }
{ $subsection flag? }
"Raising and lowering flags:"
"Waiting for a flag to be raised:"
{ $subsection raise-flag }
{ $subsection wait-for-flag }
{ $subsection lower-flag } ;
ABOUT: "concurrency.flags"

7
extra/concurrency/flags/flags.factor
View File

@ -13,9 +13,14 @@ TUPLE: flag value? thread ;
[ resume ] [ drop t over set-flag-value? ] if
] unless drop ;
: wait-for-flag ( flag -- )
dup flag-value? [ drop ] [
[ flag-thread >box ] curry "flag" suspend drop
] if ;
: lower-flag ( flag -- )
dup flag-value? [
f swap set-flag-value?
] [
[ flag-thread >box ] curry "flag" suspend drop
wait-for-flag
] if ;

2
extra/concurrency/locks/locks-tests.factor
View File

@ -174,5 +174,5 @@ threads sequences calendar ;
] ;
[ lock-timeout-test ] [
linked-thread thread-name "Lock timeout-er" =
linked-error-thread thread-name "Lock timeout-er" =
] must-fail-with

21
extra/concurrency/mailboxes/mailboxes.factor
View File

@ -65,12 +65,23 @@ TUPLE: mailbox threads data ;
: mailbox-get? ( pred mailbox -- obj )
f mailbox-get-timeout? ; inline
TUPLE: linked error thread ;
TUPLE: linked-error thread ;
C: <linked> linked
: <linked-error> ( error thread -- linked )
{ set-delegate set-linked-error-thread }
linked-error construct ;
: ?linked dup linked? [ rethrow ] when ;
: ?linked dup linked-error? [ rethrow ] when ;
TUPLE: linked-thread supervisor ;
M: linked-thread error-in-thread
[ <linked-error> ] keep
linked-thread-supervisor mailbox-put ;
: <linked-thread> ( quot name mailbox -- thread' )
>r <thread> linked-thread construct-delegate r>
over set-linked-thread-supervisor ;
: spawn-linked-to ( quot name mailbox -- thread )
[ >r <linked> r> mailbox-put ] curry <thread>
[ (spawn) ] keep ;
<linked-thread> [ (spawn) ] keep ;

2
extra/concurrency/messaging/messaging-tests.factor
View File

@ -29,7 +29,7 @@ IN: temporary
"crash" throw
] "Linked test" spawn-linked drop
receive
] [ linked-error "crash" = ] must-fail-with
] [ delegate "crash" = ] must-fail-with
MATCH-VARS: ?from ?to ?value ;
SYMBOL: increment

2
extra/concurrency/messaging/messaging.factor
View File

@ -32,7 +32,7 @@ M: thread send ( message thread -- )
my-mailbox swap mailbox-get-timeout? ?linked ; inline
: rethrow-linked ( error process supervisor -- )
>r <linked> r> send ;
>r <linked-error> r> send ;
: spawn-linked ( quot name -- thread )
my-mailbox spawn-linked-to ;

33
extra/db/db.factor
View File

@ -5,29 +5,36 @@ namespaces sequences sequences.lib tuples words strings
tools.walker ;
IN: db
TUPLE: db handle ;
! TUPLE: db handle insert-statements update-statements delete-statements ;
TUPLE: db
handle
insert-statements
update-statements
delete-statements ;
: <db> ( handle -- obj )
! H{ } clone H{ } clone H{ } clone
H{ } clone H{ } clone H{ } clone
db construct-boa ;
GENERIC: make-db* ( seq class -- db )
: make-db ( seq class -- db ) construct-empty make-db* ;
GENERIC: db-open ( db -- )
HOOK: db-close db ( handle -- )
: make-db ( seq class -- db ) construct-empty make-db* ;
: dispose-statements ( seq -- )
[ dispose drop ] assoc-each ;
: dispose-db ( db -- )
dup db [
! dup db-insert-statements dispose-statements
! dup db-update-statements dispose-statements
! dup db-delete-statements dispose-statements
dup db-insert-statements dispose-statements
dup db-update-statements dispose-statements
dup db-delete-statements dispose-statements
db-handle db-close
] with-variable ;
TUPLE: statement handle sql in-params out-params bind-params bound? ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
TUPLE: result-set sql params handle n max ;
: <statement> ( sql in out -- statement )
{
set-statement-sql
@ -35,17 +42,11 @@ TUPLE: statement handle sql in-params out-params bind-params bound? ;
set-statement-out-params
} statement construct ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( obj statement -- )
GENERIC: reset-statement ( statement -- )
GENERIC: bind-statement* ( statement -- )
GENERIC: bind-tuple ( tuple statement -- )
TUPLE: result-set sql params handle n max ;
GENERIC: query-results ( query -- result-set )
GENERIC: #rows ( result-set -- n )
GENERIC: #columns ( result-set -- n )
@ -61,9 +62,8 @@ GENERIC: more-rows? ( result-set -- ? )
] if ;
: bind-statement ( obj statement -- )
dup statement-bound? [ dup reset-statement ] when
[ bind-statement* ] 2keep
[ set-statement-bind-params ] keep
[ bind-statement* ] keep
t swap set-statement-bound? ;
: init-result-set ( result-set -- )
@ -104,7 +104,6 @@ GENERIC: more-rows? ( result-set -- ? )
: do-bound-command ( obj query -- )
[ bind-statement ] keep execute-statement ;
SYMBOL: in-transaction
HOOK: begin-transaction db ( -- )
HOOK: commit-transaction db ( -- )

5
extra/db/postgresql/postgresql.factor
View File

@ -38,10 +38,7 @@ M: postgresql-db db-open ( db -- )
M: postgresql-db dispose ( db -- )
db-handle PQfinish ;
M: postgresql-statement bind-statement* ( seq statement -- )
set-statement-bind-params ;
M: postgresql-statement reset-statement ( statement -- )
M: postgresql-statement bind-statement* ( statement -- )
drop ;
M: postgresql-statement bind-tuple ( tuple statement -- )

47
extra/db/sqlite/sqlite.factor
View File

@ -4,7 +4,8 @@ USING: alien arrays assocs classes compiler db
hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings tuples alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators tools.walker ;
words combinators.lib db.types combinators tools.walker
combinators.cleave ;
IN: db.sqlite
TUPLE: sqlite-db path ;
@ -29,14 +30,13 @@ M: sqlite-db <simple-statement> ( str -- obj )
<prepared-statement> ;
M: sqlite-db <prepared-statement> ( str -- obj )
db get db-handle
{
set-statement-sql
set-statement-in-params
set-statement-out-params
set-statement-handle
} statement construct
dup statement-handle over statement-sql sqlite-prepare
db get db-handle over statement-sql sqlite-prepare
over set-statement-handle
sqlite-statement construct-delegate ;
M: sqlite-statement dispose ( statement -- )
@ -45,20 +45,32 @@ M: sqlite-statement dispose ( statement -- )
M: sqlite-result-set dispose ( result-set -- )
f swap set-result-set-handle ;
: sqlite-bind ( specs handle -- )
swap [ sqlite-bind-type ] with each ;
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
M: sqlite-statement bind-statement* ( obj statement -- )
statement-handle sqlite-bind ;
M: sqlite-statement reset-statement ( statement -- )
: reset-statement ( statement -- )
statement-handle sqlite-reset ;
M: sqlite-statement bind-statement* ( statement -- )
dup statement-bound? [ dup reset-statement ] when
[ statement-bind-params ] [ statement-handle ] bi sqlite-bind ;
M: sqlite-statement bind-tuple ( tuple statement -- )
[
statement-in-params
[
[ sql-spec-column-name ":" swap append ]
[ sql-spec-slot-name rot get-slot-named ]
[ sql-spec-type ] tri 3array
] with map
] keep
[ set-statement-bind-params ] keep bind-statement* ;
: last-insert-id ( -- id )
db get db-handle sqlite3_last_insert_rowid
dup zero? [ "last-id failed" throw ] when ;
M: sqlite-statement insert-tuple* ( tuple statement -- )
M: sqlite-db insert-tuple* ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n )
@ -78,7 +90,6 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
sqlite-result-set-has-more? ;
M: sqlite-statement query-results ( query -- result-set )
break
dup statement-handle sqlite-result-set <result-set>
dup advance-row ;
@ -127,7 +138,7 @@ M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
: where-primary-key% ( specs -- )
" where " 0%
find-primary-key sql-spec-column-name dup 0% " = " 0% bind% ;
find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ;
M: sqlite-db <update-tuple-statement> ( class -- statement )
[
@ -135,7 +146,7 @@ M: sqlite-db <update-tuple-statement> ( class -- statement )
0%
" set " 0%
dup remove-id
[ ", " 0% ] [ sql-spec-column-name dup 0% " = " 0% bind% ] interleave
[ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
where-primary-key%
] sqlite-make ;
@ -144,7 +155,7 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
"delete from " 0% 0%
" where " 0%
find-primary-key
sql-spec-column-name dup 0% " = " 0% bind%
dup sql-spec-column-name 0% " = " 0% bind%
] sqlite-make ;
! : select-interval ( interval name -- ) ;
@ -152,8 +163,6 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
M: sqlite-db bind% ( spec -- )
dup 1, sql-spec-column-name ":" swap append 0% ;
! dup 1, sql-spec-column-name
! dup 0% " = " 0% ":" swap append 0% ;
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[
@ -201,7 +210,3 @@ M: sqlite-db type-table ( -- assoc )
M: sqlite-db create-type-table
type-table ;
! HOOK: get-column-value ( n result-set type -- )
! M: sqlite get-column-value { { "TEXT" get-text-column } {
! "INTEGER" get-integer-column } ... } case ;

27
extra/db/tuples/tuples-tests.factor
View File

@ -22,8 +22,9 @@ SYMBOL: the-person2
: test-tuples ( -- )
[ person drop-table ] [ drop ] recover
[ ] [ person create-table ] unit-test
[ person create-table ] must-fail
[ ] [ the-person1 get insert-tuple ] unit-test
[ ] [ the-person1 get insert-tuple ] unit-test
[ 1 ] [ the-person1 get person-the-id ] unit-test
@ -66,8 +67,8 @@ person "PERSON"
"billy" 10 3.14 <person> the-person1 set
"johnny" 10 3.14 <person> the-person2 set
! test-sqlite
test-postgresql
test-sqlite
! test-postgresql
person "PERSON"
{
@ -80,8 +81,8 @@ person "PERSON"
1 "billy" 10 3.14 <assigned-person> the-person1 set
2 "johnny" 10 3.14 <assigned-person> the-person2 set
! test-sqlite
test-postgresql
test-sqlite
! test-postgresql
TUPLE: paste n summary author channel mode contents timestamp annotations ;
TUPLE: annotation n paste-id summary author mode contents ;
@ -108,11 +109,11 @@ annotation "ANNOTATION"
{ "contents" "CONTENTS" TEXT }
} define-persistent
{ "localhost" "postgres" "" "factor-test" } postgresql-db [
[ paste drop-table ] [ drop ] recover
[ annotation drop-table ] [ drop ] recover
[ paste drop-table ] [ drop ] recover
[ annotation drop-table ] [ drop ] recover
[ ] [ paste create-table ] unit-test
[ ] [ annotation create-table ] unit-test
] with-db
! { "localhost" "postgres" "" "factor-test" } postgresql-db [
! [ paste drop-table ] [ drop ] recover
! [ annotation drop-table ] [ drop ] recover
! [ paste drop-table ] [ drop ] recover
! [ annotation drop-table ] [ drop ] recover
! [ ] [ paste create-table ] unit-test
! [ ] [ annotation create-table ] unit-test
! ] with-db

49
extra/db/tuples/tuples.factor
View File

@ -26,14 +26,14 @@ IN: db.tuples
HOOK: create-sql-statement db ( class -- obj )
HOOK: drop-sql-statement db ( class -- obj )
HOOK: <insert-native-statement> db ( tuple -- obj )
HOOK: <insert-assigned-statement> db ( tuple -- obj )
HOOK: <insert-native-statement> db ( class -- obj )
HOOK: <insert-assigned-statement> db ( class -- obj )
HOOK: <update-tuple-statement> db ( tuple -- obj )
HOOK: <update-tuples-statement> db ( tuple -- obj )
HOOK: <update-tuple-statement> db ( class -- obj )
HOOK: <update-tuples-statement> db ( class -- obj )
HOOK: <delete-tuple-statement> db ( tuple -- obj )
HOOK: <delete-tuples-statement> db ( tuple -- obj )
HOOK: <delete-tuple-statement> db ( class -- obj )
HOOK: <delete-tuples-statement> db ( class -- obj )
HOOK: <select-by-slots-statement> db ( tuple -- tuple )
@ -63,15 +63,27 @@ HOOK: insert-tuple* db ( tuple statement -- )
: sql-props ( class -- columns table )
dup db-columns swap db-table ;
: create-table ( class -- ) create-sql-statement execute-statement ;
: drop-table ( class -- ) drop-sql-statement execute-statement ;
: with-disposals ( seq quot -- )
over sequence? [
[ with-disposal ] curry each
] [
with-disposal
] if ;
: create-table ( class -- )
create-sql-statement [ execute-statement ] with-disposals ;
: drop-table ( class -- )
drop-sql-statement [ execute-statement ] with-disposals ;
: insert-native ( tuple -- )
dup class <insert-native-statement>
dup class
db get db-insert-statements [ <insert-native-statement> ] cache
[ bind-tuple ] 2keep insert-tuple* ;
: insert-assigned ( tuple -- )
dup class <insert-assigned-statement>
dup class
db get db-insert-statements [ <insert-assigned-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- )
@ -82,19 +94,18 @@ HOOK: insert-tuple* db ( tuple statement -- )
] if ;
: update-tuple ( tuple -- )
dup class <update-tuple-statement>
dup class
db get db-update-statements [ <update-tuple-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: update-tuples ( seq -- )
<update-tuples-statement> execute-statement ;
: delete-tuple ( tuple -- )
dup class <delete-tuple-statement>
dup class
db get db-delete-statements [ <delete-tuple-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: setup-select ( tuple -- statement )
dup dup class <select-by-slots-statement>
[ bind-tuple ] keep ;
: select-tuples ( tuple -- tuple )
dup dup class <select-by-slots-statement> [
[ bind-tuple ] keep query-tuples
] with-disposal ;
: select-tuples ( tuple -- tuple ) setup-select query-tuples ;
: select-tuple ( tuple -- tuple/f ) select-tuples ?first ;

1
extra/help/handbook/handbook.factor
View File

@ -199,6 +199,7 @@ ARTICLE: "tools" "Developer tools"
"Debugging tools:"
{ $subsection "tools.annotations" }
{ $subsection "tools.test" }
{ $subsection "tools.threads" }
"Performance tools:"
{ $subsection "tools.memory" }
{ $subsection "profiling" }

17
extra/help/help.factor
View File

@ -122,18 +122,31 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
: (:help-multi)
"This error has multiple delegates:" print
($index) nl ;
($index) nl
"Use \\ ... help to get help about a specific delegate." print ;
: (:help-none)
drop "No help for this error. " print ;
: (:help-debugger)
nl
"Debugger commands:" print
nl
":help - documentation for this error" print
":s - data stack at exception time" print
":r - retain stack at exception time" print
":c - call stack at exception time" print
":edit - jump to source location (parse errors only)" print
":get ( var -- value ) accesses variables at time of the error" print ;
: :help ( -- )
error get delegates [ error-help ] map [ ] subset
{
{ [ dup empty? ] [ (:help-none) ] }
{ [ dup length 1 = ] [ first help ] }
{ [ t ] [ (:help-multi) ] }
} cond ;
} cond (:help-debugger) ;
: remove-article ( name -- )
dup articles get key? [

2
extra/math/primes/primes.factor
View File

@ -47,3 +47,5 @@ PRIVATE>
primes-upto
>r 1- next-prime r>
[ [ <=> ] binsearch ] keep [ length ] keep <slice> ; foldable
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable

2
extra/opengl/gl/extensions/extensions.factor
View File

@ -17,7 +17,7 @@ SYMBOL: +gl-function-pointers+
: reset-gl-function-pointers ( -- )
100 <hashtable> +gl-function-pointers+ set-global ;
[ reset-gl-function-pointers ] "opengl.gl init hook" add-init-hook
[ reset-gl-function-pointers ] "opengl.gl" add-init-hook
reset-gl-function-pointers
reset-gl-function-number-counter

17
extra/tools/threads/threads-docs.factor Normal file
View File

@ -0,0 +1,17 @@
IN: tools.threads
USING: help.markup help.syntax threads ;
HELP: threads.
{ $description "Prints a list of running threads and their state. The ``Waiting on'' column displays one of the following:"
{ $list
"``running'' if the thread is the current thread"
"``yield'' if the thread is waiting to run"
{ "the string given to " { $link suspend } " if the thread is suspended" }
}
} ;
ARTICLE: "tools.threads" "Listing threads"
"Printing a list of running threads:"
{ $subsection threads. } ;
ABOUT: "tools.threads"

1
extra/ui/gadgets/buttons/buttons.factor
View File

@ -88,7 +88,6 @@ TUPLE: repeat-button ;
repeat-button H{
{ T{ drag } [ button-clicked ] }
{ T{ button-down } [ button-clicked ] }
} set-gestures
: <repeat-button> ( label quot -- button )

20
extra/ui/tools/interactor/interactor.factor
View File

@ -1,18 +1,15 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators continuations documents
ui.tools.workspace hashtables io io.styles kernel math
hashtables io io.styles kernel math
math.vectors models namespaces parser prettyprint quotations
sequences sequences.lib strings threads listener
tuples ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
definitions boxes calendar ;
definitions boxes calendar concurrency.flags ui.tools.workspace ;
IN: ui.tools.interactor
TUPLE: interactor
history output
thread quot
help ;
TUPLE: interactor history output flag thread help ;
: interactor-continuation ( interactor -- continuation )
interactor-thread box-value
@ -35,12 +32,16 @@ help ;
: init-interactor-history ( interactor -- )
V{ } clone swap set-interactor-history ;
: init-interactor-state ( interactor -- )
<flag> over set-interactor-flag
<box> swap set-interactor-thread ;
: <interactor> ( output -- gadget )
<source-editor>
interactor construct-editor
tuck set-interactor-output
<box> over set-interactor-thread
dup init-interactor-history
dup init-interactor-state
dup init-caret-help ;
M: interactor graft*
@ -97,7 +98,10 @@ M: interactor model-changed
] unless drop ;
: interactor-yield ( interactor -- obj )
[ interactor-thread >box ] curry "input" suspend ;
[
[ interactor-thread >box ] keep
interactor-flag raise-flag
] curry "input" suspend ;
M: interactor stream-readln
[ interactor-yield ] keep interactor-finish ?first ;

19
extra/ui/tools/listener/listener.factor
View File

@ -6,7 +6,7 @@ kernel models namespaces parser quotations sequences ui.commands
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 ;
prettyprint listener debugger threads boxes concurrency.flags ;
IN: ui.tools.listener
TUPLE: listener-gadget input output stack ;
@ -40,9 +40,14 @@ M: listener-gadget call-tool* ( input listener -- )
M: listener-gadget tool-scroller
listener-gadget-output find-scroller ;
: wait-for-listener ( listener -- )
#! Wait for the listener to start.
listener-gadget-input interactor-flag wait-for-flag ;
: workspace-busy? ( workspace -- ? )
workspace-listener listener-gadget-input
interactor-busy? ;
workspace-listener
dup wait-for-listener
listener-gadget-input interactor-busy? ;
: get-listener ( -- listener )
[ workspace-busy? not ] get-workspace* workspace-listener ;
@ -131,10 +136,14 @@ M: stack-display tool-scroller
listener
] with-stream* ;
: start-listener-thread ( listener -- )
[ listener-thread ] curry "Listener" spawn drop ;
: restart-listener ( listener -- )
#! Returns when listener is ready to receive input.
dup com-end dup clear-output
[ listener-thread ] curry
"Listener" spawn drop ;
dup start-listener-thread
wait-for-listener ;
: init-listener ( listener -- )
f <model> swap set-listener-gadget-stack ;

23
extra/ui/tools/tools.factor
View File

@ -1,15 +1,14 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs debugger ui.tools.workspace
ui.tools.operations ui.tools.browser ui.tools.inspector
ui.tools.listener ui.tools.profiler
ui.tools.operations ui.tools.traceback ui.tools.browser
ui.tools.inspector ui.tools.listener ui.tools.profiler
ui.tools.operations inspector io kernel math models namespaces
prettyprint quotations sequences ui ui.commands ui.gadgets
ui.gadgets.books ui.gadgets.buttons
ui.gadgets.labelled ui.gadgets.scrollers ui.gadgets.tracks
ui.gadgets.worlds ui.gadgets.presentations ui.gestures words
vocabs.loader tools.test ui.gadgets.buttons
ui.gadgets.status-bar mirrors ;
ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
ui.gadgets.presentations ui.gestures words vocabs.loader
tools.test ui.gadgets.buttons ui.gadgets.status-bar mirrors ;
IN: ui.tools
: <workspace-tabs> ( -- tabs )
@ -85,3 +84,11 @@ workspace "workflow" f {
[
<workspace> "Factor workspace" open-status-window
] workspace-window-hook set-global
: inspect-continuation ( traceback -- )
control-value [ inspect ] curry call-listener ;
traceback-gadget "toolbar" f {
{ T{ key-down f f "v" } variables }
{ T{ key-down f f "n" } inspect-continuation }
} define-command-map

33
extra/ui/tools/traceback/traceback.factor
View File

@ -1,8 +1,10 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations kernel models namespaces prettyprint ui
ui.commands ui.gadgets ui.gadgets.labelled assocs
ui.gadgets.tracks ui.gestures sequences hashtables inspector ;
ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
ui.gadgets.status-bar ui.gadgets.scrollers
ui.gestures sequences hashtables inspector ;
IN: ui.tools.traceback
: <callstack-display> ( model -- gadget )
@ -17,10 +19,6 @@ IN: ui.tools.traceback
[ [ continuation-retain stack. ] when* ]
t "Retain stack" <labelled-pane> ;
: <namestack-display> ( model -- gadget )
[ [ continuation-name namestack. ] when* ]
f "Dynamic variables" <labelled-pane> ;
TUPLE: traceback-gadget ;
M: traceback-gadget pref-dim* drop { 550 600 } ;
@ -31,11 +29,28 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
[
g gadget-model <datastack-display> 1/2 track,
g gadget-model <retainstack-display> 1/2 track,
] { 1 0 } make-track 1/5 track,
g gadget-model <callstack-display> 2/5 track,
g gadget-model <namestack-display> 2/5 track,
] { 1 0 } make-track 1/3 track,
g gadget-model <callstack-display> 2/3 track,
toolbar,
] with-gadget
] keep ;
: <namestack-display> ( model -- gadget )
[ [ continuation-name namestack. ] when* ]
<pane-control> ;
TUPLE: variables-gadget ;
: <variables-gadget> ( model -- gadget )
<namestack-display> <scroller>
variables-gadget construct-empty
[ set-gadget-delegate ] keep ;
M: variables-gadget pref-dim* drop { 400 400 } ;
: variables ( traceback -- )
gadget-model <variables-gadget>
"Dynamic variables" open-status-window ;
: traceback-window ( continuation -- )
<model> <traceback-gadget> "Traceback" open-window ;

1
extra/ui/tools/walker/walker-docs.factor
View File

@ -7,5 +7,4 @@ ARTICLE: "ui-walker" "UI walker"
$nl
"The walker can travel backwards through time, and restore stacks. This does not undo side effects and therefore can only be used reliably on referentially transparent code."
{ $command-map walker-gadget "toolbar" }
{ $command-map walker-gadget "other" }
"Walkers are instances of " { $link walker-gadget } "." ;

19
extra/ui/tools/walker/walker.factor
View File

@ -7,7 +7,7 @@ ui.tools.workspace ui.gestures ui.gadgets.labels ui threads
namespaces tools.walker assocs ;
IN: ui.tools.walker
TUPLE: walker-gadget status continuation thread ;
TUPLE: walker-gadget status continuation thread traceback ;
: walker-command ( walker msg -- )
over walker-gadget-thread thread-registered?
@ -26,13 +26,12 @@ TUPLE: walker-gadget status continuation thread ;
: com-abandon ( walker -- ) abandon walker-command ;
: com-inspect ( walker -- )
walker-continuation model-value
[ inspect ] curry call-listener ;
M: walker-gadget ungraft*
dup delegate ungraft* detach walker-command ;
M: walker-gadget focusable-child*
walker-gadget-traceback ;
: walker-state-string ( status thread -- string )
[
"Thread: " %
@ -52,10 +51,10 @@ M: walker-gadget ungraft*
[ walker-state-string ] curry <filter> <label-control> ;
: <walker-gadget> ( status continuation thread -- gadget )
walker-gadget construct-boa [
over <traceback-gadget> walker-gadget construct-boa [
toolbar,
g walker-gadget-status self <thread-status> f track,
g walker-gadget-continuation <traceback-gadget> 1 track,
g walker-gadget-traceback 1 track,
] { 0 1 } build-track ;
: walker-help "ui-walker" help-window ;
@ -69,12 +68,8 @@ walker-gadget "toolbar" f {
{ T{ key-down f f "b" } com-back }
{ T{ key-down f f "c" } com-continue }
{ T{ key-down f f "a" } com-abandon }
{ T{ key-down f f "F1" } walker-help }
} define-command-map
walker-gadget "other" f {
{ T{ key-down f f "n" } com-inspect }
{ T{ key-down f f "d" } close-window }
{ T{ key-down f f "F1" } walker-help }
} define-command-map
: walker-window ( -- )