Merge branch 'master' of http://factorcode.org/git/factor into semantic-db
Conflicts: extra/db/sqlite/sqlite.factordb4
Alex Chapman
commit
7af882a5fb
core
alien/compiler
bootstrap
continuations
io/files
libc
sequences
threads
extra
benchmark
combinators/lib
concurrency
combinators
locks
mailboxes
db
hello-world
help
handbook
io
files/temporary
monitors
unix/files
temporary
windows/files/temporary
math/primes
opengl/gl/extensions
tools
deploy
disassembler
threads
ui
gadgets/buttons
tools
deploy
interactor
listener
traceback
unix
stat
types
linux
macosx
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
|
|
|||
|
|
@ -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 libc ;
|
||||
IN: debugger
|
||||
|
||||
GENERIC: error. ( error -- )
|
||||
|
|
@ -57,19 +58,6 @@ 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 ]
|
||||
|
|
@ -77,7 +65,12 @@ M: string error. print ;
|
|||
|
||||
SYMBOL: error-hook
|
||||
|
||||
[ print-error restarts. debug-help ] error-hook set-global
|
||||
[
|
||||
print-error
|
||||
restarts.
|
||||
nl
|
||||
"Type :help for debugging help." print flush
|
||||
] error-hook set-global
|
||||
|
||||
: try ( quot -- )
|
||||
[ error-hook get call ] recover ;
|
||||
|
|
@ -260,3 +253,49 @@ M: no-compilation-unit error.
|
|||
|
||||
M: no-vocab summary
|
||||
drop "Vocabulary does not exist" ;
|
||||
|
||||
M: check-ptr summary
|
||||
drop "Memory allocation failed" ;
|
||||
|
||||
M: double-free summary
|
||||
drop "Free failed since memory is not allocated" ;
|
||||
|
||||
M: realloc-error summary
|
||||
drop "Memory reallocation failed" ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
! 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -142,7 +142,6 @@ DEFER: copy-tree-to
|
|||
|
||||
: copy-tree ( from to -- )
|
||||
over directory? [
|
||||
dup make-directories
|
||||
>r dup directory swap r> [
|
||||
>r swap first path+ r> copy-tree-to
|
||||
] 2curry each
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! Copyright (C) 2007 Slava Pestov
|
||||
! Copyright (C) 2007 Doug Coleman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien assocs continuations init inspector kernel namespaces ;
|
||||
USING: alien assocs continuations init kernel namespaces ;
|
||||
IN: libc
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -25,28 +25,22 @@ PRIVATE>
|
|||
|
||||
TUPLE: check-ptr ;
|
||||
|
||||
M: check-ptr summary drop "Memory allocation failed" ;
|
||||
|
||||
: check-ptr ( c-ptr -- c-ptr )
|
||||
[ \ check-ptr construct-boa throw ] unless* ;
|
||||
|
||||
TUPLE: double-free ;
|
||||
|
||||
M: double-free summary drop "Free failed since memory is not allocated" ;
|
||||
|
||||
: double-free ( -- * )
|
||||
\ double-free construct-empty throw ;
|
||||
|
||||
TUPLE: realloc-error ptr size ;
|
||||
|
||||
M: realloc-error summary drop "Memory reallocation failed" ;
|
||||
|
||||
: realloc-error ( alien size -- * )
|
||||
\ realloc-error construct-boa throw ;
|
||||
|
||||
<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 ;
|
||||
|
|
|
|||
|
|
@ -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 )" } } }
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel combinators namespaces quotations hashtables
|
||||
sequences assocs arrays inference effects math math.ranges
|
||||
arrays.lib shuffle macros bake combinators.cleave ;
|
||||
arrays.lib shuffle macros bake combinators.cleave
|
||||
continuations ;
|
||||
|
||||
IN: combinators.lib
|
||||
|
||||
|
|
@ -167,3 +168,6 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
|
|||
|
||||
: and? ( obj quot1 quot2 -- ? )
|
||||
>r keep r> rot [ call ] [ 2drop f ] if ; inline
|
||||
|
||||
: retry ( quot n -- )
|
||||
swap [ drop ] swap compose attempt-all ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ( -- )
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@ USING: alien arrays assocs classes compiler db
|
|||
hashtables io.files io.files.tmp 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 ;
|
||||
|
|
@ -37,14 +38,13 @@ M: sqlite-db <simple-statement> ( str in out -- obj )
|
|||
<prepared-statement> ;
|
||||
|
||||
M: sqlite-db <prepared-statement> ( str in out -- 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 over set-statement-handle
|
||||
db get db-handle over statement-sql sqlite-prepare
|
||||
over set-statement-handle
|
||||
sqlite-statement construct-delegate ;
|
||||
|
||||
M: sqlite-statement dispose ( statement -- )
|
||||
|
|
@ -53,20 +53,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 )
|
||||
|
|
@ -134,7 +146,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 )
|
||||
[
|
||||
|
|
@ -142,7 +154,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 ;
|
||||
|
||||
|
|
@ -151,7 +163,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 -- ) ;
|
||||
|
|
@ -159,8 +171,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 )
|
||||
[
|
||||
|
|
@ -208,7 +218,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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
@ -83,19 +95,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,13 +1,14 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-c-types? f }
|
||||
{ deploy-ui? f }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-io 2 }
|
||||
{ deploy-math? f }
|
||||
{ deploy-threads? f }
|
||||
{ deploy-compiler? f }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-name "Hello world (console)" }
|
||||
{ deploy-reflection 2 }
|
||||
{ deploy-c-types? f }
|
||||
{ deploy-ui? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-compiler? f }
|
||||
{ deploy-io 2 }
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -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? [
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
USING: io.backend ;
|
||||
IN: io.files.temporary.backend
|
||||
|
||||
HOOK: (temporary-file) io-backend ( path prefix suffix -- stream path )
|
||||
HOOK: temporary-path io-backend ( -- path )
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
USING: kernel math math.bitfields combinators.lib math.parser
|
||||
random sequences sequences.lib continuations namespaces
|
||||
io.files io.backend io.nonblocking io arrays
|
||||
io.files.temporary.backend system combinators vocabs.loader ;
|
||||
USE: tools.walker
|
||||
IN: io.files.temporary
|
||||
|
||||
: random-letter ( -- ch )
|
||||
26 random { CHAR: a CHAR: A } random + ;
|
||||
|
||||
: random-ch ( -- ch )
|
||||
{ t f } random
|
||||
[ 10 random CHAR: 0 + ] [ random-letter ] if ;
|
||||
|
||||
: random-name ( n -- string )
|
||||
[ drop random-ch ] "" map-as ;
|
||||
|
||||
: <temporary-file> ( prefix suffix -- path duplex-stream )
|
||||
temporary-path -rot
|
||||
[ 10 random-name swap 3append path+ dup (temporary-file) ] 3curry
|
||||
10 retry ;
|
||||
|
||||
: with-temporary-file ( quot -- path )
|
||||
>r f f <temporary-file> r> with-stream ;
|
||||
|
||||
: temporary-directory ( -- path )
|
||||
[ temporary-path 10 random-name path+ dup make-directory ] 10 retry ;
|
||||
|
||||
: with-temporary-directory ( quot -- )
|
||||
>r temporary-directory r>
|
||||
[ with-directory ] 2keep drop delete-tree ;
|
||||
|
||||
{
|
||||
{ [ unix? ] [ "io.unix.files.temporary" ] }
|
||||
{ [ windows? ] [ "io.windows.files.temporary" ] }
|
||||
} cond require
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.backend kernel continuations namespaces sequences
|
||||
assocs hashtables sorting arrays threads boxes ;
|
||||
assocs hashtables sorting arrays threads boxes io.timeouts ;
|
||||
IN: io.monitors
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -32,7 +32,11 @@ M: monitor dispose
|
|||
|
||||
! Simple monitor; used on Linux and Mac OS X. On Windows,
|
||||
! monitors are full-fledged ports.
|
||||
TUPLE: simple-monitor handle callback ;
|
||||
TUPLE: simple-monitor handle callback timeout ;
|
||||
|
||||
M: simple-monitor timeout simple-monitor-timeout ;
|
||||
|
||||
M: simple-monitor set-timeout set-simple-monitor-timeout ;
|
||||
|
||||
: <simple-monitor> ( handle -- simple-monitor )
|
||||
f (monitor) <box> {
|
||||
|
|
@ -47,9 +51,14 @@ TUPLE: simple-monitor handle callback ;
|
|||
: notify-callback ( simple-monitor -- )
|
||||
simple-monitor-callback ?box [ resume ] [ drop ] if ;
|
||||
|
||||
M: simple-monitor timed-out
|
||||
notify-callback ;
|
||||
|
||||
M: simple-monitor fill-queue ( monitor -- )
|
||||
[ swap simple-monitor-callback >box ]
|
||||
"monitor" suspend drop
|
||||
[
|
||||
[ swap simple-monitor-callback >box ]
|
||||
"monitor" suspend drop
|
||||
] with-timeout
|
||||
check-monitor ;
|
||||
|
||||
M: simple-monitor dispose ( monitor -- )
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.backend io.nonblocking io.unix.backend io.files io
|
||||
unix kernel math continuations math.bitfields byte-arrays
|
||||
unix unix.stat kernel math continuations math.bitfields byte-arrays
|
||||
alien ;
|
||||
|
||||
IN: io.unix.files
|
||||
|
||||
M: unix-io cwd
|
||||
|
|
|
|||
|
|
@ -0,0 +1,12 @@
|
|||
USING: kernel io.nonblocking io.unix.backend math.bitfields
|
||||
unix io.files.temporary.backend ;
|
||||
IN: io.unix.files.temporary
|
||||
|
||||
: open-temporary-flags ( -- flags )
|
||||
{ O_RDWR O_CREAT O_EXCL } flags ;
|
||||
|
||||
M: unix-io (temporary-file) ( path -- duplex-stream )
|
||||
open-temporary-flags file-mode open dup io-error
|
||||
<writer> ;
|
||||
|
||||
M: unix-io temporary-path ( -- path ) "/tmp" ;
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
USING: kernel system ;
|
||||
IN: io.windows.files.temporary
|
||||
|
||||
M: windows-io (temporary-file) ( path -- stream )
|
||||
GENERIC_WRITE CREATE_NEW 0 open-file 0 <writer> ;
|
||||
|
||||
M: windows-io temporary-path ( -- path )
|
||||
"TEMP" os-env ;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -66,6 +66,11 @@ HELP: deploy-math?
|
|||
$nl
|
||||
"On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ;
|
||||
|
||||
HELP: deploy-threads?
|
||||
{ $description "Deploy flag. If set, the deployed image will contain support for threads."
|
||||
$nl
|
||||
"On by default. Often the programmer will use threads without realizing it. A small amount of space can be saved by stripping this feature out, but some code may require changes to work properly." } ;
|
||||
|
||||
HELP: deploy-compiler?
|
||||
{ $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible."
|
||||
$nl
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@ SYMBOL: deploy-name
|
|||
SYMBOL: deploy-ui?
|
||||
SYMBOL: deploy-compiler?
|
||||
SYMBOL: deploy-math?
|
||||
SYMBOL: deploy-threads?
|
||||
|
||||
SYMBOL: deploy-io
|
||||
|
||||
|
|
@ -55,6 +56,7 @@ SYMBOL: deploy-image
|
|||
{ deploy-io 2 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-threads? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-word-defs? f }
|
||||
|
|
|
|||
|
|
@ -0,0 +1,22 @@
|
|||
IN: temporary
|
||||
USING: tools.test system io.files kernel tools.deploy.config
|
||||
tools.deploy.backend math ;
|
||||
|
||||
: shake-and-bake
|
||||
"." resource-path [
|
||||
vm
|
||||
"hello.image" temp-file
|
||||
rot dup deploy-config make-deploy-image
|
||||
] with-directory ;
|
||||
|
||||
[ ] [ "hello-world" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [
|
||||
"hello.image" temp-file file-length 500000 <=
|
||||
] unit-test
|
||||
|
||||
[ ] [ "hello-ui" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [
|
||||
"hello.image" temp-file file-length 2000000 <=
|
||||
] unit-test
|
||||
|
|
@ -11,8 +11,16 @@ IN: tools.deploy.shaker
|
|||
: strip-init-hooks ( -- )
|
||||
"Stripping startup hooks" show
|
||||
"command-line" init-hooks get delete-at
|
||||
"mallocs" init-hooks get delete-at
|
||||
strip-io? [ "io.backend" init-hooks get delete-at ] when ;
|
||||
"libc" init-hooks get delete-at
|
||||
deploy-threads? get [
|
||||
"threads" init-hooks get delete-at
|
||||
] unless
|
||||
native-io? [
|
||||
"io.thread" init-hooks get delete-at
|
||||
] unless
|
||||
strip-io? [
|
||||
"io.backend" init-hooks get delete-at
|
||||
] when ;
|
||||
|
||||
: strip-debugger ( -- )
|
||||
strip-debugger? [
|
||||
|
|
@ -85,6 +93,7 @@ IN: tools.deploy.shaker
|
|||
{ } set-retainstack
|
||||
V{ } set-namestack
|
||||
V{ } set-catchstack
|
||||
|
||||
"Saving final image" show
|
||||
[ save-image-and-exit ] call-clear ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
USING: kernel ;
|
||||
USING: kernel threads threads.private ;
|
||||
IN: debugger
|
||||
|
||||
: print-error die ;
|
||||
|
||||
: error. die ;
|
||||
|
||||
M: thread error-in-thread ( error thread -- ) die 2drop ;
|
||||
|
|
|
|||
|
|
@ -10,10 +10,10 @@ IN: tools.deploy.windows
|
|||
vm over copy-file ;
|
||||
|
||||
: copy-fonts ( bundle-name -- )
|
||||
"fonts/" resource-path swap copy-tree ;
|
||||
"fonts/" resource-path swap copy-tree-to ;
|
||||
|
||||
: copy-dlls ( bundle-name -- )
|
||||
{ "freetype6.dll" "zlib1.dll" "factor-nt.dll" }
|
||||
{ "freetype6.dll" "zlib1.dll" "factor.dll" }
|
||||
[ resource-path ] map
|
||||
swap copy-files-to ;
|
||||
|
||||
|
|
@ -30,10 +30,11 @@ TUPLE: windows-deploy-implementation ;
|
|||
T{ windows-deploy-implementation } deploy-implementation set-global
|
||||
|
||||
M: windows-deploy-implementation deploy*
|
||||
"." resource-path cd
|
||||
dup deploy-config [
|
||||
[ deploy-name get create-exe-dir ] keep
|
||||
[ deploy-name get image-name ] keep
|
||||
[ namespace make-deploy-image ] keep
|
||||
open-in-explorer
|
||||
] bind ;
|
||||
"." resource-path [
|
||||
dup deploy-config [
|
||||
[ deploy-name get create-exe-dir ] keep
|
||||
[ deploy-name get image-name ] keep
|
||||
[ namespace make-deploy-image ] keep
|
||||
open-in-explorer
|
||||
] bind
|
||||
] with-directory ;
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ M: pair make-disassemble-cmd
|
|||
+closed+ +stdin+ set
|
||||
out-file +stdout+ set
|
||||
[ "gdb" , "-x" , in-file , "-batch" , ] { } make +arguments+ set
|
||||
] { } make-assoc run-process drop
|
||||
] { } make-assoc try-process
|
||||
out-file file-lines ;
|
||||
|
||||
: tabs>spaces ( str -- str' )
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -34,9 +34,10 @@ TUPLE: deploy-gadget vocab settings ;
|
|||
"Advanced:" <label> gadget,
|
||||
deploy-compiler? get "Use optimizing compiler" <checkbox> gadget,
|
||||
deploy-math? get "Rational and complex number support" <checkbox> gadget,
|
||||
deploy-word-props? get "Include word properties" <checkbox> gadget,
|
||||
deploy-word-defs? get "Include word definitions" <checkbox> gadget,
|
||||
deploy-c-types? get "Include C types" <checkbox> gadget, ;
|
||||
deploy-threads? get "Threading support" <checkbox> gadget,
|
||||
deploy-word-props? get "Retain all word properties" <checkbox> gadget,
|
||||
deploy-word-defs? get "Retain all word definitions" <checkbox> gadget,
|
||||
deploy-c-types? get "Retain all C types" <checkbox> gadget, ;
|
||||
|
||||
: deploy-settings-theme
|
||||
{ 10 10 } over set-pack-gap
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 } "." ;
|
||||
|
|
|
|||
|
|
@ -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 ( -- )
|
||||
|
|
|
|||
|
|
@ -24,31 +24,10 @@ C-STRUCT: stat
|
|||
{ "ulong" "unused4" }
|
||||
{ "ulong" "unused5" } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
FUNCTION: int __xstat ( int ver, char* pathname, stat* buf ) ;
|
||||
FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
|
||||
|
||||
: stat ( pathname buf -- int ) 3 -rot __xstat ;
|
||||
: lstat ( pathname buf -- int ) 3 -rot __lxstat ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: S_IFMT OCT: 170000 ; ! These bits determine file type.
|
||||
|
||||
: S_IFDIR OCT: 40000 ; ! Directory.
|
||||
: S_IFCHR OCT: 20000 ; ! Character device.
|
||||
: S_IFBLK OCT: 60000 ; ! Block device.
|
||||
: S_IFREG OCT: 100000 ; ! Regular file.
|
||||
: S_IFIFO OCT: 010000 ; ! FIFO.
|
||||
: S_IFLNK OCT: 120000 ; ! Symbolic link.
|
||||
: S_IFSOCK OCT: 140000 ; ! Socket.
|
||||
|
||||
: S_ISTYPE ( mode mask -- val ) >r S_IFMT bitand r> = ;
|
||||
|
||||
: S_ISREG ( mode -- value ) S_IFREG S_ISTYPE ;
|
||||
: S_ISDIR ( mode -- value ) S_IFDIR S_ISTYPE ;
|
||||
: S_ISCHR ( mode -- value ) S_IFCHR S_ISTYPE ;
|
||||
: S_ISBLK ( mode -- value ) S_IFBLK S_ISTYPE ;
|
||||
: S_ISFIFO ( mode -- value ) S_IFIFO S_ISTYPE ;
|
||||
: S_ISLNK ( mode -- value ) S_IFLNK S_ISTYPE ;
|
||||
: S_ISSOCK ( mode -- value ) S_IFSOCK S_ISTYPE ;
|
||||
|
||||
: lstat ( pathname buf -- int ) 3 -rot __lxstat ;
|
||||
|
|
@ -28,27 +28,4 @@ FUNCTION: int __xstat ( int ver, char* pathname, stat* buf ) ;
|
|||
FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
|
||||
|
||||
: stat ( pathname buf -- int ) 3 -rot __xstat ;
|
||||
: lstat ( pathname buf -- int ) 3 -rot __lxstat ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: S_IFMT OCT: 170000 ; ! These bits determine file type.
|
||||
|
||||
: S_IFDIR OCT: 40000 ; ! Directory.
|
||||
: S_IFCHR OCT: 20000 ; ! Character device.
|
||||
: S_IFBLK OCT: 60000 ; ! Block device.
|
||||
: S_IFREG OCT: 100000 ; ! Regular file.
|
||||
: S_IFIFO OCT: 010000 ; ! FIFO.
|
||||
: S_IFLNK OCT: 120000 ; ! Symbolic link.
|
||||
: S_IFSOCK OCT: 140000 ; ! Socket.
|
||||
|
||||
: S_ISTYPE ( mode mask -- val ) >r S_IFMT bitand r> = ;
|
||||
|
||||
: S_ISREG ( mode -- value ) S_IFREG S_ISTYPE ;
|
||||
: S_ISDIR ( mode -- value ) S_IFDIR S_ISTYPE ;
|
||||
: S_ISCHR ( mode -- value ) S_IFCHR S_ISTYPE ;
|
||||
: S_ISBLK ( mode -- value ) S_IFBLK S_ISTYPE ;
|
||||
: S_ISFIFO ( mode -- value ) S_IFIFO S_ISTYPE ;
|
||||
: S_ISLNK ( mode -- value ) S_IFLNK S_ISTYPE ;
|
||||
: S_ISSOCK ( mode -- value ) S_IFSOCK S_ISTYPE ;
|
||||
|
||||
: lstat ( pathname buf -- int ) 3 -rot __lxstat ;
|
||||
|
|
@ -27,26 +27,3 @@ C-STRUCT: stat
|
|||
|
||||
FUNCTION: int stat ( char* pathname, stat* buf ) ;
|
||||
FUNCTION: int lstat ( char* pathname, stat* buf ) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: S_IFMT OCT: 170000 ; ! These bits determine file type.
|
||||
|
||||
: S_IFDIR OCT: 40000 ; ! Directory.
|
||||
: S_IFCHR OCT: 20000 ; ! Character device.
|
||||
: S_IFBLK OCT: 60000 ; ! Block device.
|
||||
: S_IFREG OCT: 100000 ; ! Regular file.
|
||||
: S_IFIFO OCT: 010000 ; ! FIFO.
|
||||
: S_IFLNK OCT: 120000 ; ! Symbolic link.
|
||||
: S_IFSOCK OCT: 140000 ; ! Socket.
|
||||
|
||||
: S_ISTYPE ( mode mask -- val ) >r S_IFMT bitand r> = ;
|
||||
|
||||
: S_ISREG ( mode -- value ) S_IFREG S_ISTYPE ;
|
||||
: S_ISDIR ( mode -- value ) S_IFDIR S_ISTYPE ;
|
||||
: S_ISCHR ( mode -- value ) S_IFCHR S_ISTYPE ;
|
||||
: S_ISBLK ( mode -- value ) S_IFBLK S_ISTYPE ;
|
||||
: S_ISFIFO ( mode -- value ) S_IFIFO S_ISTYPE ;
|
||||
: S_ISLNK ( mode -- value ) S_IFLNK S_ISTYPE ;
|
||||
: S_ISSOCK ( mode -- value ) S_IFSOCK S_ISTYPE ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,62 @@
|
|||
|
||||
USING: system combinators vocabs.loader ;
|
||||
USING: kernel system combinators alien.syntax math vocabs.loader ;
|
||||
|
||||
IN: unix.stat
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! File Types
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: S_IFMT OCT: 170000 ; ! These bits determine file type.
|
||||
|
||||
: S_IFDIR OCT: 40000 ; ! Directory.
|
||||
: S_IFCHR OCT: 20000 ; ! Character device.
|
||||
: S_IFBLK OCT: 60000 ; ! Block device.
|
||||
: S_IFREG OCT: 100000 ; ! Regular file.
|
||||
: S_IFIFO OCT: 010000 ; ! FIFO.
|
||||
: S_IFLNK OCT: 120000 ; ! Symbolic link.
|
||||
: S_IFSOCK OCT: 140000 ; ! Socket.
|
||||
|
||||
: S_ISTYPE ( mode mask -- val ) >r S_IFMT bitand r> = ;
|
||||
|
||||
: S_ISREG ( mode -- value ) S_IFREG S_ISTYPE ;
|
||||
: S_ISDIR ( mode -- value ) S_IFDIR S_ISTYPE ;
|
||||
: S_ISCHR ( mode -- value ) S_IFCHR S_ISTYPE ;
|
||||
: S_ISBLK ( mode -- value ) S_IFBLK S_ISTYPE ;
|
||||
: S_ISFIFO ( mode -- value ) S_IFIFO S_ISTYPE ;
|
||||
: S_ISLNK ( mode -- value ) S_IFLNK S_ISTYPE ;
|
||||
: S_ISSOCK ( mode -- value ) S_IFSOCK S_ISTYPE ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! File Access Permissions
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! Read, write, execute/search by owner
|
||||
: S_IRWXU OCT: 0000700 ; inline ! rwx mask owner
|
||||
: S_IRUSR OCT: 0000400 ; inline ! r owner
|
||||
: S_IWUSR OCT: 0000200 ; inline ! w owner
|
||||
: S_IXUSR OCT: 0000100 ; inline ! x owner
|
||||
! Read, write, execute/search by group
|
||||
: S_IRWXG OCT: 0000070 ; inline ! rwx mask group
|
||||
: S_IRGRP OCT: 0000040 ; inline ! r group
|
||||
: S_IWGRP OCT: 0000020 ; inline ! w group
|
||||
: S_IXGRP OCT: 0000010 ; inline ! x group
|
||||
! Read, write, execute/search by others
|
||||
: S_IRWXO OCT: 0000007 ; inline ! rwx mask other
|
||||
: S_IROTH OCT: 0000004 ; inline ! r other
|
||||
: S_IWOTH OCT: 0000002 ; inline ! w other
|
||||
: S_IXOTH OCT: 0000001 ; inline ! x other
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
FUNCTION: int chmod ( char* path, mode_t mode ) ;
|
||||
|
||||
FUNCTION: int fchmod ( int fd, mode_t mode ) ;
|
||||
|
||||
FUNCTION: int mkdir ( char* path, mode_t mode ) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
{
|
||||
{ [ linux? ] [ "unix.stat.linux" require ] }
|
||||
{ [ t ] [ ] }
|
||||
|
|
|
|||
|
|
@ -7,9 +7,9 @@ IN: unix.types
|
|||
|
||||
TYPEDEF: ulonglong __uquad_type
|
||||
TYPEDEF: ulong __ulongword_type
|
||||
TYPEDEF: uint __uword_type
|
||||
TYPEDEF: long __sword_type
|
||||
TYPEDEF: ulong __uword_type
|
||||
TYPEDEF: long __slongword_type
|
||||
TYPEDEF: int __sword_type
|
||||
TYPEDEF: uint __u32_type
|
||||
TYPEDEF: int __s32_type
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,6 @@
|
|||
|
||||
USING: alien.syntax ;
|
||||
|
||||
IN: unix.types
|
||||
|
||||
! Darwin 9.1.0 ppc
|
||||
|
|
|
|||
|
|
@ -1,37 +1,15 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: unix
|
||||
|
||||
USING: alien alien.c-types alien.syntax kernel libc structs
|
||||
math namespaces system combinators vocabs.loader ;
|
||||
math namespaces system combinators vocabs.loader unix.types ;
|
||||
|
||||
! ! ! Unix types
|
||||
IN: unix
|
||||
|
||||
TYPEDEF: long word
|
||||
TYPEDEF: ulong uword
|
||||
|
||||
TYPEDEF: long longword
|
||||
TYPEDEF: ulong ulongword
|
||||
|
||||
TYPEDEF: long ssize_t
|
||||
TYPEDEF: longword blksize_t
|
||||
TYPEDEF: longword blkcnt_t
|
||||
TYPEDEF: longlong quad_t
|
||||
TYPEDEF: ulonglong dev_t
|
||||
TYPEDEF: uint gid_t
|
||||
TYPEDEF: uint in_addr_t
|
||||
TYPEDEF: ulong ino_t
|
||||
TYPEDEF: int pid_t
|
||||
TYPEDEF: uint socklen_t
|
||||
TYPEDEF: uint time_t
|
||||
TYPEDEF: uint uid_t
|
||||
TYPEDEF: ulong size_t
|
||||
TYPEDEF: ulong u_long
|
||||
TYPEDEF: uint mode_t
|
||||
TYPEDEF: uword nlink_t
|
||||
TYPEDEF: void* caddr_t
|
||||
|
||||
TYPEDEF: ulong off_t
|
||||
TYPEDEF-IF: bsd? ulonglong off_t
|
||||
|
||||
C-STRUCT: tm
|
||||
{ "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?)
|
||||
|
|
@ -56,41 +34,6 @@ C-STRUCT: timespec
|
|||
[ set-timespec-nsec ] keep
|
||||
[ set-timespec-sec ] keep ;
|
||||
|
||||
! ! ! Unix constants
|
||||
|
||||
! File type
|
||||
: S_IFMT OCT: 0170000 ; inline ! type of file
|
||||
: S_IFIFO OCT: 0010000 ; inline ! named pipe (fifo)
|
||||
: S_IFCHR OCT: 0020000 ; inline ! character special
|
||||
: S_IFDIR OCT: 0040000 ; inline ! directory
|
||||
: S_IFBLK OCT: 0060000 ; inline ! block special
|
||||
: S_IFREG OCT: 0100000 ; inline ! regular
|
||||
: S_IFLNK OCT: 0120000 ; inline ! symbolic link
|
||||
: S_IFSOCK OCT: 0140000 ; inline ! socket
|
||||
: S_IFWHT OCT: 0160000 ; inline ! whiteout
|
||||
: S_IFXATTR OCT: 0200000 ; inline ! extended attribute
|
||||
|
||||
! File mode
|
||||
! Read, write, execute/search by owner
|
||||
: S_IRWXU OCT: 0000700 ; inline ! rwx mask owner
|
||||
: S_IRUSR OCT: 0000400 ; inline ! r owner
|
||||
: S_IWUSR OCT: 0000200 ; inline ! w owner
|
||||
: S_IXUSR OCT: 0000100 ; inline ! x owner
|
||||
! Read, write, execute/search by group
|
||||
: S_IRWXG OCT: 0000070 ; inline ! rwx mask group
|
||||
: S_IRGRP OCT: 0000040 ; inline ! r group
|
||||
: S_IWGRP OCT: 0000020 ; inline ! w group
|
||||
: S_IXGRP OCT: 0000010 ; inline ! x group
|
||||
! Read, write, execute/search by others
|
||||
: S_IRWXO OCT: 0000007 ; inline ! rwx mask other
|
||||
: S_IROTH OCT: 0000004 ; inline ! r other
|
||||
: S_IWOTH OCT: 0000002 ; inline ! w other
|
||||
: S_IXOTH OCT: 0000001 ; inline ! x other
|
||||
|
||||
: S_ISUID OCT: 0004000 ; inline ! set user id on execution
|
||||
: S_ISGID OCT: 0002000 ; inline ! set group id on execution
|
||||
: S_ISVTX OCT: 0001000 ; inline ! sticky bit
|
||||
|
||||
: PROT_NONE 0 ; inline
|
||||
: PROT_READ 1 ; inline
|
||||
: PROT_WRITE 2 ; inline
|
||||
|
|
@ -113,7 +56,6 @@ LIBRARY: libc
|
|||
FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ;
|
||||
FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ;
|
||||
FUNCTION: int chdir ( char* path ) ;
|
||||
FUNCTION: int chmod ( char* path, mode_t mode ) ;
|
||||
FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ;
|
||||
FUNCTION: int chroot ( char* path ) ;
|
||||
FUNCTION: void close ( int fd ) ;
|
||||
|
|
@ -124,7 +66,6 @@ FUNCTION: int execv ( char* path, char** argv ) ;
|
|||
FUNCTION: int execvp ( char* path, char** argv ) ;
|
||||
FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
|
||||
FUNCTION: int fchdir ( int fd ) ;
|
||||
FUNCTION: int fchmod ( int fd, mode_t mode ) ;
|
||||
FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
|
||||
FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
|
||||
FUNCTION: int flock ( int fd, int operation ) ;
|
||||
|
|
@ -150,7 +91,6 @@ FUNCTION: int lchown ( char* path, uid_t owner, gid_t group ) ;
|
|||
FUNCTION: int listen ( int s, int backlog ) ;
|
||||
FUNCTION: tm* localtime ( time_t* clock ) ;
|
||||
FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ;
|
||||
FUNCTION: int mkdir ( char* path, mode_t mode ) ;
|
||||
FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_t offset ) ;
|
||||
FUNCTION: int munmap ( void* addr, size_t len ) ;
|
||||
FUNCTION: uint ntohl ( uint n ) ;
|
||||
|
|
|
|||
|
|
@ -161,6 +161,9 @@ DEFINE_PRIMITIVE(save_image_and_exit)
|
|||
for(i = 0; i < FIRST_SAVE_ENV; i++)
|
||||
userenv[i] = F;
|
||||
|
||||
for(i = LAST_SAVE_ENV + 1; i < USER_ENV; i++)
|
||||
userenv[i] = F;
|
||||
|
||||
/* do a full GC + code heap compaction */
|
||||
compact_code_heap();
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue