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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-02-10 08:31:52 -06:00
parent 43225d2aef e7bf56ad57
commit fcb49a3442
61 changed files with 582 additions and 349 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
core/bootstrap/compiler/compiler.factor
View File

@ -77,3 +77,14 @@ nl
[ compiled-usages recompile ] recompile-hook set-global
" done" print flush
! Load empty test vocabs
USE: compiler.test.curry
USE: compiler.test.float
USE: compiler.test.intrinsics
USE: compiler.test.redefine
USE: compiler.test.simple
USE: compiler.test.stack-trace
USE: compiler.test.templates
USE: compiler.test.templates-early
USE: compiler.test.tuples

40
core/bootstrap/image/image.factor
View File

@ -136,7 +136,7 @@ SYMBOL: undefined-quot
: here-as ( tag -- pointer ) here swap bitor ;
: align-here ( -- )
here 8 mod 4 = [ 0 emit ] when ;
here 8 mod 4 = [ heap-size drop 0 emit ] when ;
: emit-fixnum ( n -- ) tag-fixnum emit ;
@ -177,6 +177,7 @@ GENERIC: ' ( obj -- ptr )
[ dup bignum-bits neg shift swap bignum-radix bitand ]
[ ] unfold nip ;
USE: continuations
: emit-bignum ( n -- )
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
dup length 1+ emit-fixnum
@ -214,10 +215,6 @@ M: f '
: 1, 1 >bignum ' 1-offset fixup ;
: -1, -1 >bignum ' -1-offset fixup ;
! Beginning of the image
: begin-image ( -- ) emit-header t, 0, 1, -1, ;
! Words
: emit-word ( word -- )
@ -385,7 +382,10 @@ M: curry '
: fixup-header ( -- )
heap-size data-heap-size-offset fixup ;
: end-image ( -- )
: build-image ( -- image )
800000 <vector> image set
20000 <hashtable> objects set
emit-header t, 0, 1, -1,
"Serializing words..." print flush
emit-words
"Serializing JIT data..." print flush
@ -400,7 +400,8 @@ M: curry '
fixup-header
"Image length: " write image get length .
"Object cache size: " write objects get assoc-size .
\ word global delete-at ;
\ word global delete-at
image get ;
! Image output
@ -411,28 +412,23 @@ M: curry '
[ >le write ] curry each
] if ;
: write-image ( image filename -- )
"Writing image to " write dup write "..." print flush
: write-image ( image -- )
"Writing image to " write
architecture get boot-image-name resource-path
dup write "..." print flush
<file-writer> [ (write-image) ] with-stream ;
: prepare-image ( -- )
bootstrapping? on
load-help? off
800000 <vector> image set
20000 <hashtable> objects set ;
PRIVATE>
: make-image ( arch -- )
architecture [
prepare-image
begin-image
[
architecture set
bootstrapping? on
load-help? off
"resource:/core/bootstrap/stage1.factor" run-file
end-image
image get
architecture get boot-image-name resource-path
build-image
write-image
] with-variable ;
] with-scope ;
: make-images ( -- )
images [ make-image ] each ;

4
core/classes/classes.factor
View File

@ -20,7 +20,9 @@ PREDICATE: class tuple-class
: classes ( -- seq ) class<map get keys ;
: type>class ( n -- class ) builtins get nth ;
: type>class ( n -- class ) builtins get-global nth ;
: bootstrap-type>class ( n -- class ) builtins get nth ;
: predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ;

7
core/compiler/compiler-tests.factor
View File

@ -1,7 +0,0 @@
IN: temporary
USING: tools.browser tools.test kernel sequences vocabs ;
"compiler.test" child-vocabs empty? [
"compiler.test" load-children
"compiler.test" test
] when

4
core/compiler/test/simple/simple-tests.factor
View File

@ -1,6 +1,6 @@
USING: compiler tools.test kernel kernel.private
combinators.private math.private math combinators strings
alien arrays ;
alien arrays memory ;
IN: temporary
! Test empty word
@ -48,6 +48,8 @@ IN: temporary
[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
[ 2 3 ] [ 1 [ { [ code-gc 1 ] [ code-gc 2 ] } dispatch 3 ] compile-call ] unit-test
! Labels
: recursive ( ? -- ) [ f recursive ] when ; inline

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

@ -169,7 +169,7 @@ HELP: rethrow
HELP: throw-restarts
{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link condition } " with the object associated to the chosen restart on the stack." }
{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." }
{ $examples
"Try invoking one of the two restarts which are offered after the below code throws an error:"
{ $code

4
core/cpu/architecture/architecture.factor
View File

@ -60,9 +60,7 @@ HOOK: %jump-label compiler-backend ( label -- )
! Test if vreg is 'f' or not
HOOK: %jump-t compiler-backend ( label -- )
HOOK: %call-dispatch compiler-backend ( -- label )
HOOK: %jump-dispatch compiler-backend ( -- )
HOOK: %dispatch compiler-backend ( -- )
HOOK: %dispatch-label compiler-backend ( word -- )

23
core/cpu/ppc/architecture/architecture.factor
View File

@ -111,20 +111,15 @@ M: ppc-backend %jump-label ( label -- ) B ;
M: ppc-backend %jump-t ( label -- )
0 "flag" operand f v>operand CMPI BNE ;
: (%dispatch) ( len -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
"offset" operand "n" operand 1 SRAWI
11 11 "offset" operand ADD
11 dup rot cells LWZ ;
M: ppc-backend %call-dispatch ( word-table# -- )
[ 7 (%dispatch) (%call) <label> dup B ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ;
M: ppc-backend %jump-dispatch ( -- )
[ %epilogue-later 6 (%dispatch) (%jump) ] H{
M: ppc-backend %dispatch ( -- )
[
%epilogue-later
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
"offset" operand "n" operand 1 SRAWI
11 11 "offset" operand ADD
11 dup 6 cells LWZ
(%jump)
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ;

3
core/cpu/x86/64/64.factor
View File

@ -4,7 +4,8 @@ USING: alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture kernel kernel.private math
namespaces sequences generator.registers generator.fixup system
alien alien.compiler alien.structs slots splitting assocs ;
alien alien.accessors alien.compiler alien.structs slots
splitting assocs ;
IN: cpu.x86.64
PREDICATE: x86-backend amd64-backend

39
core/cpu/x86/architecture/architecture.factor
View File

@ -77,26 +77,29 @@ M: x86-backend %jump-label ( label -- ) JMP ;
M: x86-backend %jump-t ( label -- )
"flag" operand f v>operand CMP JNE ;
: (%dispatch) ( n -- operand )
! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
! Untag and multiply to get a jump table offset
"n" operand fixnum>slot@
! Add jump table base
"offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
"n" operand "offset" operand ADD
"n" operand swap bootstrap-cell 8 = 14 9 ? + [+] ;
: code-alignment ( -- n )
building get length dup cell align swap - ;
M: x86-backend %call-dispatch ( word-table# -- )
[ 5 (%dispatch) CALL <label> dup JMP ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
{ +clobber+ { "n" } }
} with-template ;
: align-code ( n -- )
0 <repetition> % ;
M: x86-backend %jump-dispatch ( -- )
[ %epilogue-later 0 (%dispatch) JMP ] H{
M: x86-backend %dispatch ( -- )
[
%epilogue-later
! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
! Untag and multiply to get a jump table offset
"n" operand fixnum>slot@
! Add jump table base
"offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
"n" operand "offset" operand ADD
"n" operand HEX: 7f [+] JMP
! Fix up the displacement above
code-alignment dup bootstrap-cell 8 = 15 9 ? +
building get dup pop* push
align-code
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
{ +clobber+ { "n" } }

29
core/generator/generator.factor
View File

@ -56,13 +56,16 @@ GENERIC: generate-node ( node -- next )
: generate-nodes ( node -- )
[ node@ generate-node ] iterate-nodes end-basic-block ;
: init-generate-nodes ( -- )
init-templates
%save-word-xt
%prologue-later
current-label-start define-label
current-label-start resolve-label ;
: generate ( word label node -- )
[
init-templates
%save-word-xt
%prologue-later
current-label-start define-label
current-label-start resolve-label
init-generate-nodes
[ generate-nodes ] with-node-iterator
] generate-1 ;
@ -168,17 +171,23 @@ M: #if generate-node
] if %dispatch-label
] each ;
: generate-dispatch ( node -- )
%dispatch dispatch-branches init-templates ;
M: #dispatch generate-node
#! The order here is important, dispatch-branches must
#! run after %dispatch, so that each branch gets the
#! correct register state
tail-call? [
%jump-dispatch dispatch-branches
generate-dispatch iterate-next
] [
0 frame-required
%call-dispatch >r dispatch-branches r> resolve-label
] if
init-templates iterate-next ;
compiling-word get gensym [
rot [
init-generate-nodes
generate-dispatch
] generate-1
] keep generate-call
] if ;
! #call
: define-intrinsics ( word intrinsics -- )

2
core/generic/math/math.factor
View File

@ -61,7 +61,7 @@ TUPLE: no-math-method left right generic ;
: math-vtable* ( picker max quot -- quot )
[
rot , \ tag ,
[ >r [ type>class ] map r> map % ] { } make ,
[ >r [ bootstrap-type>class ] map r> map % ] { } make ,
\ dispatch ,
] [ ] make ; inline

2
core/generic/standard/standard.factor
View File

@ -97,7 +97,7 @@ TUPLE: no-method object generic ;
[ small-generic ] picker class-hash-dispatch-quot ;
: vtable-class ( n -- class )
type>class [ hi-tag bootstrap-word ] unless* ;
bootstrap-type>class [ hi-tag bootstrap-word ] unless* ;
: group-methods ( assoc -- vtable )
#! Input is a predicate -> method association.

1
core/inference/backend/backend.factor
View File

@ -370,6 +370,7 @@ TUPLE: effect-error word effect ;
init-inference
dependencies off
dup word-def over dup infer-quot-recursive
end-infer
finish-word
current-effect
] with-scope

8
core/inference/inference-tests.factor
View File

@ -4,7 +4,8 @@ math.parser math.private namespaces namespaces.private parser
sequences strings vectors words quotations effects tools.test
continuations generic.standard sorting assocs definitions
prettyprint io inspector tuples classes.union classes.predicate
debugger threads.private io.streams.string combinators.private ;
debugger threads.private io.streams.string io.timeouts
combinators.private ;
IN: temporary
{ 0 2 } [ 2 "Hello" ] must-infer-as
@ -536,3 +537,8 @@ TUPLE: custom-error ;
! This was a false trigger of the undecidable quotation
! recursion bug
{ 2 1 } [ find-last-sep ] must-infer-as
! Regression
: missing->r-check >r ;
[ [ missing->r-check ] infer ] must-fail

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

@ -22,8 +22,7 @@ $nl
{ $subsection make-block-stream }
{ $subsection make-cell-stream }
{ $subsection stream-write-table }
"Optional word for network streams:"
{ $subsection set-timeout } ;
{ $see-also "io.timeouts" } ;
ARTICLE: "stdio" "The default stream"
"Various words take an implicit stream parameter from a variable to reduce stack shuffling."
@ -73,11 +72,6 @@ ARTICLE: "streams" "Streams"
ABOUT: "streams"
HELP: set-timeout
{ $values { "n" "an integer" } { "stream" "a stream" } }
{ $contract "Sets a timeout, in milliseconds, for input and output operations on the stream. If a read or a write is initiated and no activity is seen before the timeout expires, an error will be thrown to the caller of the operation being performed." }
{ $notes "Whether or not the stream is closed when the error is thrown is implementation-specific, and user code should take care to close the stream on all error conditions in any case." } ;
HELP: stream-readln
{ $values { "stream" "an input stream" } { "str" string } }
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }

1
core/io/io.factor
View File

@ -4,7 +4,6 @@ USING: hashtables generic kernel math namespaces sequences strings
continuations assocs io.styles sbufs ;
IN: io
GENERIC: set-timeout ( n stream -- )
GENERIC: stream-readln ( stream -- str )
GENERIC: stream-read1 ( stream -- ch/f )
GENERIC: stream-read ( n stream -- str/f )

5
core/io/streams/duplex/duplex.factor
View File

@ -74,8 +74,3 @@ M: duplex-stream dispose
[ dup duplex-stream-out dispose ]
[ dup duplex-stream-in dispose ] [ ] cleanup
] unless drop ;
M: duplex-stream set-timeout
2dup
duplex-stream-in set-timeout
duplex-stream-out set-timeout ;

11
core/math/parser/parser.factor
View File

@ -41,6 +41,9 @@ DEFER: base>
<PRIVATE
SYMBOL: radix
SYMBOL: negative?
: sign negative? get "-" "+" ? ;
: with-radix ( radix quot -- )
radix swap with-variable ; inline
@ -48,7 +51,7 @@ SYMBOL: radix
: (base>) ( str -- n ) radix get base> ;
: whole-part ( str -- m n )
"+" split1 >r (base>) r>
sign split1 >r (base>) r>
dup [ (base>) ] [ drop 0 swap ] if ;
: string>ratio ( str -- a/b )
@ -70,7 +73,7 @@ PRIVATE>
: base> ( str radix -- n/f )
[
"-" ?head >r
"-" ?head dup negative? set >r
{
{ [ CHAR: / over member? ] [ string>ratio ] }
{ [ CHAR: . over member? ] [ string>float ] }
@ -114,9 +117,9 @@ M: integer >base
M: ratio >base
[
[
dup 0 < [ "-" % neg ] when
dup 0 < dup negative? set [ "-" % neg ] when
1 /mod
>r dup zero? [ drop ] [ (>base) % "+" % ] if r>
>r dup zero? [ drop ] [ (>base) % sign % ] if r>
dup numerator (>base) %
"/" %
denominator (>base) %

138
extra/builder/builder.factor
View File

@ -1,8 +1,9 @@
USING: kernel io io.files io.launcher hashtables
USING: kernel io io.files io.launcher io.sockets hashtables
system continuations namespaces sequences splitting math.parser
prettyprint tools.time calendar bake vars http.client
combinators bootstrap.image bootstrap.image.download ;
combinators bootstrap.image bootstrap.image.download
combinators.cleave ;
IN: builder
@ -29,16 +30,34 @@ IN: builder
SYMBOL: builder-recipients
: host-name* ( -- name ) host-name "." split first ;
: tag-subject ( str -- str ) `{ "builder@" ,[ host-name* ] ": " , } concat ;
: email-string ( subject -- )
`{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] }
[ ] with-process-stream drop ;
: email-file ( subject file -- )
`{
{ +stdin+ , }
{ +arguments+ { "mutt" "-s" , %[ builder-recipients get ] } }
{ +arguments+
{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] } }
}
>hashtable run-process drop ;
: email-string ( subject -- )
`{ "mutt" "-s" , %[ builder-recipients get ] }
[ ] with-process-stream drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: run-or-notify ( desc message -- )
[ [ try-process ] curry ]
[ [ email-string throw ] curry ]
bi*
recover ;
: run-or-send-file ( desc message file -- )
>r >r [ try-process ] curry
r> r> [ email-file throw ] 2curry
recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -59,71 +78,44 @@ VAR: stamp
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: build-status
: build ( -- )
"running" build-status set-global
datestamp >stamp
"/builds/factor" cd
: git-pull ( -- desc )
{
"git"
"pull"
"--no-summary"
"git://factorcode.org/git/factor.git"
"master"
}
run-process process-status
0 =
[ ]
[
"builder: git pull" email-string
"builder: git pull" throw
]
if
} ;
{
"git" "pull" "--no-summary"
"http://dharmatech.onigirihouse.com/factor.git" "master"
} run-process drop
: git-clone ( -- desc ) { "git" "clone" "../factor" } ;
"/builds/" stamp> append make-directory
"/builds/" stamp> append cd
{ "git" "clone" "../factor" } run-process drop
"factor" cd
: enter-build-dir ( -- )
datestamp >stamp
"/builds" cd
stamp> make-directory
stamp> cd ;
: record-git-id ( -- )
{ "git" "show" } <process-stream> [ readln ] with-stream " " split second
"../git-id" log-object
"../git-id" log-object ;
{ "make" "clean" } run-process drop
! "vm" build-status set-global
: make-clean ( -- desc ) { "make" "clean" } ;
: make-vm ( -- )
`{
{ +arguments+ { "make" ,[ target ] } }
{ +stdout+ "../compile-log" }
{ +stderr+ +stdout+ }
}
>hashtable run-process process-status
0 =
[ ]
[
"builder: vm compile" "../compile-log" email-file
"builder: vm compile" throw
] if
>hashtable ;
: retrieve-boot-image ( -- )
[ my-arch download-image ]
[ ]
[ "builder: image download" email-string ]
cleanup
! "bootstrap" build-status set-global
cleanup ;
: bootstrap ( -- desc )
`{
{ +arguments+ {
,[ factor-binary ]
@ -133,29 +125,49 @@ SYMBOL: build-status
{ +stdout+ "../boot-log" }
{ +stderr+ +stdout+ }
}
>hashtable [ run-process ] "../boot-time" log-runtime process-status
0 =
[ ]
[
"builder: bootstrap" "../boot-log" email-file
"builder: bootstrap" throw
] if
>hashtable ;
! "test" build-status set-global
: builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
`{ ,[ factor-binary ] "-run=builder.test" } run-process drop
SYMBOL: build-status
: build ( -- )
"running" build-status set-global
"/builds/factor" cd
git-pull "git pull error" run-or-notify
enter-build-dir
git-clone "git clone error" run-or-notify
"factor" cd
record-git-id
make-clean "make clean error" run-or-notify
make-vm "vm compile error" "../compile-log" run-or-send-file
retrieve-boot-image
bootstrap "bootstrap error" "../boot-log" run-or-send-file
builder-test "builder.test fatal error" run-or-notify
"../load-everything-log" exists?
[ "builder: load-everything" "../load-everything-log" email-file ]
[ "load-everything" "../load-everything-log" email-file ]
when
"../failing-tests" exists?
[ "builder: failing tests" "../failing-tests" email-file ]
[ "failing tests" "../failing-tests" email-file ]
when
! "ready" build-status set-global
;
"ready" build-status set-global ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

1
extra/cocoa/cocoa.factor
View File

@ -58,6 +58,7 @@ SYMBOL: super-sent-messages
"NSPasteboard"
"NSResponder"
"NSSavePanel"
"NSScreen"
"NSView"
"NSWindow"
"NSWorkspace"

5
extra/concurrency/concurrency-tests.factor
View File

@ -133,4 +133,9 @@ SYMBOL: value
[ 3 3 ] [
[ 3 ] future
dup ?future swap ?future
] unit-test
! Another race
[ 3 ] [
[ 3 yield ] future ?future
] unit-test

29
extra/concurrency/concurrency.factor
View File

@ -264,26 +264,31 @@ PRIVATE>
#! so the server continuation gets its new self updated.
self swap call ;
TUPLE: future status value processes ;
TUPLE: future value processes ;
: notify-future ( value future -- )
tuck set-future-value
dup future-processes [ schedule-thread ] each
f swap set-future-processes ;
: future ( quot -- future )
#! Spawn a process to call the quotation and immediately return
#! a 'future' on the stack. The future can later be queried with
#! ?future. If the quotation has completed the result will be returned.
#! If not, the process will block until the quotation completes.
#! 'quot' must have stack effect ( -- X ).
[
#! Spawn a process to call the quotation and immediately return.
f V{ } clone \ future construct-boa [
[
t
] compose
] spawn drop
[ self send ] compose spawn ;
>r [ t 2array ] compose [ f 2array ] recover r>
notify-future
] 2curry spawn drop
] keep ;
: ?future ( future -- result )
#! Block the process until the future has completed and then
#! place the result on the stack. Return the result
#! immediately if the future has completed.
process-mailbox mailbox-get ;
dup future-value [
first2 [ throw ] unless
] [
dup [ future-processes push stop ] curry callcc0 ?future
] ?if ;
: parallel-map ( seq quot -- newseq )
#! Spawn a process to apply quot to each element of seq,

2
extra/delegate/protocols/protocols.factor
View File

@ -18,7 +18,7 @@ PROTOCOL: stream-protocol
stream-read1 stream-read stream-read-until
stream-flush stream-write1 stream-write stream-format
stream-nl make-span-stream make-block-stream stream-readln
make-cell-stream stream-write-table set-timeout ;
make-cell-stream stream-write-table ;
PROTOCOL: definition-protocol
where set-where forget uses redefined*

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

@ -157,7 +157,8 @@ ARTICLE: "io" "Input and output"
"Advanced features:"
{ $subsection "io.launcher" }
{ $subsection "io.mmap" }
{ $subsection "io.monitors" } ;
{ $subsection "io.monitors" }
{ $subsection "io.timeouts" } ;
ARTICLE: "tools" "Developer tools"
{ $subsection "tools.annotations" }

4
extra/http/client/client.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files strings splitting
continuations assocs.lib ;
io io.sockets io.streams.string io.files io.timeouts strings
splitting continuations assocs.lib ;
IN: http.client
: parse-host ( url -- host port )

2
extra/http/server/server.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io strings splitting
USING: assocs kernel namespaces io io.timeouts strings splitting
threads http http.server.responders sequences prettyprint
io.server logging ;

40
extra/io/launcher/launcher-docs.factor
View File

@ -76,6 +76,9 @@ HELP: +append-environment+
$nl
"This is used in situations where you want a spawn child process with some overridden environment variables." } ;
HELP: +timeout+
{ $description "Launch descriptor key. If set, specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ;
HELP: default-descriptor
{ $description "Association storing default values for launch descriptor keys." } ;
@ -94,22 +97,16 @@ HELP: run-process*
HELP: >descriptor
{ $values { "desc" "a launch descriptor" } { "desc" "a launch descriptor" } }
{ $description "Creates a launch descriptor from an object, which must be one of the following:"
{ $list
{ "a string -- this is wrapped in a launch descriptor with a single " { $link +command+ } " key" }
{ "a sequence of strings -- this is wrapped in a launch descriptor with a single " { $link +arguments+ } " key" }
{ "an association, used to set launch parameters for additional control" }
}
} ;
{ $description "Creates a launch descriptor from an object. See " { $link "io.launcher.descriptors" } " for details." } ;
HELP: run-process
{ $values { "desc" "a launch descriptor" } { "process" process } }
{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." }
{ $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ;
HELP: run-detached
{ $values { "desc" "a launch descriptor" } { "process" process } }
{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." }
{ $notes
"This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set."
$nl
@ -162,25 +159,27 @@ HELP: wait-for-process
{ $values { "process" process } { "status" integer } }
{ $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ;
ARTICLE: "io.launcher" "Launching OS processes"
"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
$nl
"Words which launch processes can take either a command line string, a sequence of command line arguments, or a launch descriptor:"
ARTICLE: "io.launcher.descriptors" "Launch descriptors"
"Words which launch processes can take either a command line string, a sequence of command line arguments, or an assoc:"
{ $list
{ "strings are wrapped in a launch descriptor with a single " { $link +command+ } " key" }
{ "sequences of strings are wrapped in a launch descriptor with a single " { $link +arguments+ } " key" }
{ "launch descriptors are associations, which can set extra launch parameters for finer control" }
{ "strings are wrapped in an assoc with a single " { $link +command+ } " key" }
{ "sequences of strings are wrapped in an assoc with a single " { $link +arguments+ } " key" }
{ "associations can be passed in, which allows finer control over launch parameters" }
}
"A launch descriptor is an association containing keys from the below set:"
"The associations can contain the following keys:"
{ $subsection +command+ }
{ $subsection +arguments+ }
{ $subsection +detached+ }
{ $subsection +environment+ }
{ $subsection +environment-mode+ }
"Redirecting standard input and output to files:"
{ $subsection +timeout+ }
{ $subsection +stdin+ }
{ $subsection +stdout+ }
{ $subsection +stderr+ }
{ $subsection +stderr+ } ;
ARTICLE: "io.launcher" "Launching OS processes"
"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
{ $subsection "io.launcher.descriptors" }
"The following words are used to launch processes:"
{ $subsection run-process }
{ $subsection run-detached }
@ -193,6 +192,7 @@ $nl
"A class representing an active or finished process:"
{ $subsection process }
"Waiting for a process to end, or getting the exit code of a finished process:"
{ $subsection wait-for-process } ;
{ $subsection wait-for-process }
"Processes support the " { $link "io.timeouts" } "; the timeout specifies an upper bound on the running time of the process." ;
ABOUT: "io.launcher"

42
extra/io/launcher/launcher.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.backend system kernel namespaces strings hashtables
sequences assocs combinators vocabs.loader init threads
continuations math ;
USING: io io.backend io.timeouts system kernel namespaces
strings hashtables sequences assocs combinators vocabs.loader
init threads continuations math ;
IN: io.launcher
! Non-blocking process exit notification facility
@ -10,14 +10,14 @@ SYMBOL: processes
[ H{ } clone processes set-global ] "io.launcher" add-init-hook
TUPLE: process handle status ;
TUPLE: process handle status killed? lapse ;
HOOK: register-process io-backend ( process -- )
M: object register-process drop ;
: <process> ( handle -- process )
f process construct-boa
f f <lapse> process construct-boa
V{ } clone over processes get set-at
dup register-process ;
@ -25,6 +25,8 @@ M: process equal? 2drop f ;
M: process hashcode* process-handle hashcode* ;
: process-running? ( process -- ? ) process-status not ;
SYMBOL: +command+
SYMBOL: +arguments+
SYMBOL: +detached+
@ -34,6 +36,7 @@ SYMBOL: +stdin+
SYMBOL: +stdout+
SYMBOL: +stderr+
SYMBOL: +closed+
SYMBOL: +timeout+
SYMBOL: +prepend-environment+
SYMBOL: +replace-environment+
@ -63,22 +66,30 @@ SYMBOL: +append-environment+
{ +replace-environment+ [ ] }
} case ;
GENERIC: >descriptor ( desc -- desc )
: string-array? ( obj -- ? )
dup sequence? [ [ string? ] all? ] [ drop f ] if ;
M: string >descriptor +command+ associate ;
M: sequence >descriptor +arguments+ associate ;
M: assoc >descriptor >hashtable ;
: >descriptor ( desc -- desc )
{
{ [ dup string? ] [ +command+ associate ] }
{ [ dup string-array? ] [ +arguments+ associate ] }
{ [ dup assoc? ] [ >hashtable ] }
} cond ;
HOOK: run-process* io-backend ( desc -- handle )
: wait-for-process ( process -- status )
dup process-handle [
dup [ processes get at push stop ] curry callcc0
] when process-status ;
[
dup process-handle
[ dup [ processes get at push stop ] curry callcc0 ] when
dup process-killed?
[ "Process was killed" throw ] [ process-status ] if
] with-timeout ;
: run-process ( desc -- process )
>descriptor
dup run-process*
+timeout+ pick at [ over set-timeout ] when*
+detached+ rot at [ dup wait-for-process drop ] unless ;
: run-detached ( desc -- process )
@ -87,7 +98,7 @@ HOOK: run-process* io-backend ( desc -- handle )
TUPLE: process-failed code ;
: process-failed ( code -- * )
process-failed construct-boa throw ;
\ process-failed construct-boa throw ;
: try-process ( desc -- )
run-process wait-for-process dup zero?
@ -96,8 +107,13 @@ TUPLE: process-failed code ;
HOOK: kill-process* io-backend ( handle -- )
: kill-process ( process -- )
t over set-process-killed?
process-handle [ kill-process* ] when* ;
M: process get-lapse process-lapse ;
M: process timed-out kill-process ;
HOOK: process-stream* io-backend ( desc -- stream process )
TUPLE: process-stream process ;

2
extra/io/nonblocking/nonblocking-docs.factor
View File

@ -38,8 +38,6 @@ $nl
{ $list
{ { $link port-handle } " - a native handle identifying the underlying native resource used by the port" }
{ { $link port-error } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
{ { $link port-timeout } " - a timeout, specifying the maximum length of time, in milliseconds, for which input operations can block before throwing an error. A value of 0 denotes no timeout is desired." }
{ { $link port-cutoff } " - the time when the current timeout expires; if no input data arrives before this time, an error is thrown" }
{ { $link port-type } " - a symbol identifying the port's intended purpose" }
{ { $link port-eof? } " - a flag indicating if the port has reached the end of file while reading" }
} } ;

56
extra/io/nonblocking/nonblocking.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
IN: io.nonblocking
USING: math kernel io sequences io.buffers generic sbufs system
io.streams.lines io.streams.plain io.streams.duplex io.backend
continuations debugger classes byte-arrays namespaces splitting
dlists assocs ;
USING: math kernel io sequences io.buffers io.timeouts generic
sbufs system io.streams.lines io.streams.plain io.streams.duplex
io.backend continuations debugger classes byte-arrays namespaces
splitting dlists assocs ;
SYMBOL: default-buffer-size
64 1024 * default-buffer-size set-global
@ -13,9 +13,12 @@ SYMBOL: default-buffer-size
TUPLE: port
handle
error
timeout-entry timeout cutoff
lapse
type eof? ;
! Ports support the lapse protocol
M: port get-lapse port-lapse ;
SYMBOL: closed
PREDICATE: port input-port port-type input-port eq? ;
@ -26,12 +29,11 @@ GENERIC: close-handle ( handle -- )
: <port> ( handle buffer type -- port )
pick init-handle
0 0 {
<lapse> {
set-port-handle
set-delegate
set-port-type
set-port-timeout
set-port-cutoff
set-port-lapse
} port construct ;
: <buffered-port> ( handle type -- port )
@ -48,50 +50,14 @@ GENERIC: close-handle ( handle -- )
[ >r <reader> r> <duplex-stream> ] [ ] [ dispose ]
cleanup ;
: timeout? ( port -- ? )
port-cutoff dup zero? not swap millis < and ;
: pending-error ( port -- )
dup port-error f rot set-port-error [ throw ] when* ;
SYMBOL: timeout-queue
timeout-queue global [ [ <dlist> ] unless* ] change-at
: unqueue-timeout ( port -- )
port-timeout-entry [
timeout-queue get-global swap delete-node
] when* ;
: queue-timeout ( port -- )
dup timeout-queue get-global push-front*
swap set-port-timeout-entry ;
HOOK: cancel-io io-backend ( port -- )
M: object cancel-io drop ;
: expire-timeouts ( -- )
timeout-queue get-global dup dlist-empty? [ drop ] [
dup peek-back timeout?
[ pop-back cancel-io expire-timeouts ] [ drop ] if
] if ;
: begin-timeout ( port -- )
dup port-timeout dup zero? [
2drop
] [
millis + over set-port-cutoff
dup unqueue-timeout queue-timeout
] if ;
: end-timeout ( port -- )
unqueue-timeout ;
: with-port-timeout ( port quot -- )
over begin-timeout keep end-timeout ; inline
M: port set-timeout set-port-timeout ;
M: port timed-out cancel-io ;
GENERIC: (wait-to-read) ( port -- )

4
extra/io/streams/null/null.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.streams.null
USING: kernel io continuations ;
USING: kernel io io.timeouts continuations ;
TUPLE: null-stream ;
M: null-stream dispose drop ;
M: null-stream set-timeout 2drop ;
M: null-stream set-timeout drop ;
M: null-stream stream-readln drop f ;
M: null-stream stream-read1 drop f ;
M: null-stream stream-read-until 2drop f f ;

32
extra/io/timeouts/timeouts-docs.factor Executable file
View File

@ -0,0 +1,32 @@
IN: io.timeouts
USING: help.markup help.syntax math kernel ;
HELP: get-lapse
{ $values { "obj" object } { "lapse" lapse } }
{ $contract "Outputs an object's timeout lapse descriptor." } ;
HELP: set-timeout
{ $values { "ms" integer } { "obj" object } }
{ $contract "Sets an object's timeout, in milliseconds." }
{ $notes "The default implementation delegates the call to the object's timeout lapse descriptor." } ;
HELP: timed-out
{ $values { "obj" object } }
{ $contract "Handles a timeout, usually by waking up all threads waiting on the object." } ;
HELP: with-timeout
{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link timed-out } " is called on the object." } ;
ARTICLE: "io.timeouts" "I/O timeout protocol"
"Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."
{ $subsection set-timeout }
"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."
{ $subsection get-lapse }
{ $subsection timed-out }
"A combinator to be used in operations which can time out:"
{ $subsection with-timeout }
{ $see-also "stream-protocol" "io.launcher" }
;
ABOUT: "io.timeouts"

76
extra/io/timeouts/timeouts.factor Executable file
View File

@ -0,0 +1,76 @@
! Copyright (C) 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math system dlists namespaces assocs init threads
io.streams.duplex ;
IN: io.timeouts
TUPLE: lapse entry timeout cutoff ;
: <lapse> f 0 0 \ lapse construct-boa ;
! Won't need this with new slot accessors
GENERIC: get-lapse ( obj -- lapse )
GENERIC: set-timeout ( ms obj -- )
M: object set-timeout get-lapse set-timeout ;
M: lapse set-timeout set-lapse-timeout ;
: timeout ( obj -- ms ) get-lapse lapse-timeout ;
: entry ( obj -- dlist-node ) get-lapse lapse-entry ;
: set-entry ( obj dlist-node -- ) get-lapse set-lapse-entry ;
: cutoff ( obj -- ms ) get-lapse lapse-cutoff ;
: set-cutoff ( ms obj -- ) get-lapse set-lapse-cutoff ;
! Won't need this with inheritance
TUPLE: duplex-stream-lapse stream ;
M: duplex-stream-lapse set-timeout
duplex-stream-lapse-stream 2dup
duplex-stream-in set-timeout
duplex-stream-out set-timeout ;
M: duplex-stream get-lapse duplex-stream-lapse construct-boa ;
SYMBOL: timeout-queue
: timeout? ( lapse -- ? )
cutoff dup zero? not swap millis < and ;
timeout-queue global [ [ <dlist> ] unless* ] change-at
: unqueue-timeout ( obj -- )
entry [
timeout-queue get-global swap delete-node
] when* ;
: queue-timeout ( obj -- )
dup timeout-queue get-global push-front*
swap set-entry ;
GENERIC: timed-out ( obj -- )
M: object timed-out drop ;
: expire-timeouts ( -- )
timeout-queue get-global dup dlist-empty? [ drop ] [
dup peek-back timeout?
[ pop-back timed-out expire-timeouts ] [ drop ] if
] if ;
: begin-timeout ( obj -- )
dup timeout dup zero? [
2drop
] [
millis + over set-cutoff
dup unqueue-timeout queue-timeout
] if ;
: with-timeout ( obj quot -- )
over begin-timeout keep unqueue-timeout ; inline
: expiry-thread ( -- )
expire-timeouts 5000 sleep expiry-thread ;
[ [ expiry-thread ] in-thread ] "io.timeouts" add-init-hook

6
extra/io/unix/backend/backend.factor
View File

@ -3,7 +3,7 @@
USING: alien generic assocs kernel kernel.private math
io.nonblocking sequences strings structs sbufs threads unix
vectors io.buffers io.backend io.streams.duplex math.parser
continuations system libc qualified namespaces ;
continuations system libc qualified namespaces io.timeouts ;
QUALIFIED: io
IN: io.unix.backend
@ -61,7 +61,7 @@ M: mx register-io-task ( task mx -- )
mx get-global register-io-task stop ;
: with-port-continuation ( port quot -- port )
[ callcc0 ] curry with-port-timeout ; inline
[ callcc0 ] curry with-timeout ; inline
M: mx unregister-io-task ( task mx -- )
fd/container delete-at drop ;
@ -178,7 +178,7 @@ M: port port-flush ( port -- )
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
M: unix-io io-multiplex ( ms -- )
expire-timeouts mx get-global wait-for-events ;
mx get-global wait-for-events ;
M: unix-io init-stdio ( -- )
0 1 handle>duplex-stream io:stdio set-global

2
extra/io/unix/launcher/launcher.factor
View File

@ -49,7 +49,7 @@ MEMO: 'arguments' ( -- parser )
: redirect ( obj mode fd -- )
{
{ [ pick not ] [ 3drop ] }
{ [ pick not ] [ 2nip F_SETFL 0 fcntl io-error ] }
{ [ pick +closed+ eq? ] [ close 2drop ] }
{ [ pick string? ] [ (redirect) ] }
} cond ;

9
extra/io/unix/linux/linux.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.backend io.monitors io.monitors.private io.files
io.buffers io.nonblocking io.unix.backend io.unix.select
io.unix.launcher unix.linux.inotify assocs namespaces threads
continuations init math alien.c-types alien vocabs.loader ;
USING: kernel io.backend io.monitors io.monitors.private
io.files io.buffers io.nonblocking io.timeouts io.unix.backend
io.unix.select io.unix.launcher unix.linux.inotify assocs
namespaces threads continuations init math alien.c-types alien
vocabs.loader ;
IN: io.unix.linux
TUPLE: linux-io ;

2
extra/io/unix/unix.factor
View File

@ -1,4 +1,4 @@
USING: io.unix.backend io.unix.files io.unix.sockets
USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
io.unix.launcher io.unix.mmap io.backend combinators namespaces
system vocabs.loader ;

2
extra/io/windows/ce/sockets/sockets.factor
View File

@ -55,7 +55,7 @@ M: windows-ce-io accept ( server -- client )
] keep
] keep server-port-addr parse-sockaddr swap
<win32-socket> dup handle>duplex-stream <client-stream>
] with-port-timeout ;
] with-timeout ;
M: windows-ce-io <datagram> ( addrspec -- datagram )
[

2
extra/io/windows/nt/backend/backend.factor
View File

@ -91,7 +91,7 @@ M: windows-nt-io cancel-io
port-handle win32-file-handle CancelIo drop ;
M: windows-nt-io io-multiplex ( ms -- )
expire-timeouts drain-overlapped ;
drain-overlapped ;
M: windows-nt-io init-io ( -- )
<master-completion-port> master-completion-port set-global

12
extra/io/windows/nt/files/files.factor
View File

@ -1,8 +1,8 @@
USING: continuations destructors io.buffers io.files io.backend
io.nonblocking io.windows io.windows.nt.backend kernel libc math
threads windows windows.kernel32 alien.c-types alien.arrays
sequences combinators combinators.lib sequences.lib ascii
splitting alien strings ;
io.timeouts io.nonblocking io.windows io.windows.nt.backend
kernel libc math threads windows windows.kernel32 alien.c-types
alien.arrays sequences combinators combinators.lib sequences.lib
ascii splitting alien strings ;
IN: io.windows.nt.files
M: windows-nt-io cwd
@ -98,7 +98,7 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
] if ;
: flush-output ( port -- )
[ [ (flush-output) ] with-port-timeout ] with-destructors ;
[ [ (flush-output) ] with-timeout ] with-destructors ;
M: port port-flush
dup buffer-empty? [ dup flush-output ] unless drop ;
@ -122,4 +122,4 @@ M: port port-flush
] [ 2drop ] if ;
M: input-port (wait-to-read) ( port -- )
[ [ ((wait-to-read)) ] with-port-timeout ] with-destructors ;
[ [ ((wait-to-read)) ] with-timeout ] with-destructors ;

7
extra/io/windows/nt/monitors/monitors.factor
View File

@ -3,8 +3,9 @@
USING: alien.c-types destructors io.windows
io.windows.nt.backend kernel math windows windows.kernel32
windows.types libc assocs alien namespaces continuations
io.monitors io.monitors.private io.nonblocking io.buffers io.files
io sequences hashtables sorting arrays combinators ;
io.monitors io.monitors.private io.nonblocking io.buffers
io.files io.timeouts io sequences hashtables sorting arrays
combinators ;
IN: io.windows.nt.monitors
: open-directory ( path -- handle )
@ -52,7 +53,7 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
swap [ save-callback ] 2keep
dup check-monitor ! we may have closed it...
get-overlapped-result
] with-port-timeout
] with-timeout
] with-destructors ;
: parse-action ( action -- changed )

6
extra/io/windows/nt/sockets/sockets.factor
View File

@ -1,6 +1,6 @@
USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.nonblocking io io.sockets
io.sockets.impl namespaces io.streams.duplex io.windows
continuations destructors io.nonblocking io.timeouts io.sockets
io.sockets.impl io namespaces io.streams.duplex io.windows
io.windows.nt.backend windows.winsock kernel libc math sequences
threads tuples.lib ;
IN: io.windows.nt.sockets
@ -139,7 +139,7 @@ M: windows-nt-io accept ( server -- client )
AcceptEx-args-port pending-error
dup duplex-stream-in pending-error
dup duplex-stream-out pending-error
] with-port-timeout
] with-timeout
] with-destructors ;
M: windows-nt-io <server> ( addrspec -- server )

2
extra/logging/insomniac/insomniac.factor
View File

@ -42,7 +42,7 @@ SYMBOL: insomniac-recipients
: email-log-report ( service word-names -- )
"logging.insomniac" [ (email-log-report) ] with-logging ;
: schedule-insomniac ( alist -- )
: schedule-insomniac ( service word-names -- )
{ 25 } { 6 } f f f <when> -rot [
[ email-log-report ] assoc-each rotate-logs
] 2curry schedule ;

10
extra/logging/logging.factor
View File

@ -4,7 +4,7 @@ USING: logging.server sequences namespaces concurrency
words kernel arrays shuffle tools.annotations
prettyprint.config prettyprint debugger io.streams.string
splitting continuations effects arrays.lib parser strings
combinators.lib ;
combinators.lib quotations ;
IN: logging
SYMBOL: DEBUG
@ -112,9 +112,13 @@ PRIVATE>
: log-critical ( error word -- ) CRITICAL (log-error) ;
: stack-balancer ( effect word -- quot )
>r dup effect-in length r> [ over >r ERROR log-stack r> ndrop ] 2curry
swap effect-out length f <repetition> append >quotation ;
: error-logging-quot ( quot word -- quot' )
dup stack-effect effect-in length
[ >r log-error r> ndrop ] 2curry
[ [ log-error ] curry ] keep
[ stack-effect ] keep stack-balancer compose
[ recover ] 2curry ;
: add-error-logging ( word level -- )

2
extra/logging/server/server.factor
View File

@ -84,7 +84,7 @@ SYMBOL: log-files
(close-logs)
log-root directory [ drop rotate-log ] assoc-each ;
: log-server-loop
: log-server-loop ( -- )
[
receive unclip {
{ "log-message" [ (log-message) ] }

2
extra/math/ratios/ratios-tests.factor
View File

@ -107,6 +107,6 @@ unit-test
unit-test
[ 3 ] [ "1+1/2" string>number 2 * ] unit-test
[ -3 ] [ "-1+1/2" string>number 2 * ] unit-test
[ -3 ] [ "-1-1/2" string>number 2 * ] unit-test
[ "2+1/7" ] [ 1 7 / 2 + number>string ] unit-test
[ "1/8" ] [ 1 8 / number>string ] unit-test

4
extra/smtp/server/server.factor Normal file → Executable file
View File

@ -27,8 +27,8 @@
! bye
! Connection closed by foreign host.
USING: combinators kernel prettyprint io io.server sequences
namespaces io.sockets continuations ;
USING: combinators kernel prettyprint io io.timeouts io.server
sequences namespaces io.sockets continuations ;
SYMBOL: data-mode

9
extra/smtp/smtp.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov.
! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces io kernel logging io.sockets sequences
combinators sequences.lib splitting assocs strings math.parser
random system calendar ;
USING: namespaces io io.timeouts kernel logging io.sockets
sequences combinators sequences.lib splitting assocs strings
math.parser random system calendar ;
IN: smtp

13
extra/tools/annotations/annotations.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words parser io inspector quotations sequences
prettyprint continuations effects definitions compiler.units ;
prettyprint continuations effects definitions compiler.units
namespaces assocs ;
IN: tools.annotations
: reset ( word -- )
@ -49,6 +50,16 @@ IN: tools.annotations
: watch ( word -- )
dup [ (watch) ] annotate ;
: (watch-vars) ( quot word vars -- newquot )
[
"--- Entering: " write swap .
"--- Variable values:" print
[ dup get ] H{ } map>assoc describe
] 2curry swap compose ;
: watch-vars ( word vars -- )
dupd [ (watch-vars) ] 2curry annotate ;
: breakpoint ( word -- )
[ \ break add* ] annotate ;

8
extra/tools/test/test.factor
View File

@ -40,14 +40,8 @@ SYMBOL: this-test
dup word? [ 1quotation ] when
[ infer drop ] curry [ ] swap unit-test ;
TUPLE: expected-error ;
M: expected-error summary
drop
"The unit test expected the quotation to throw an error" ;
: must-fail-with ( quot pred -- )
>r [ expected-error construct-empty throw ] compose r>
>r [ f ] compose r>
[ recover ] 2curry
[ t ] swap unit-test ;

4
extra/ui/backend/backend.factor
View File

@ -7,6 +7,10 @@ SYMBOL: ui-backend
HOOK: set-title ui-backend ( string world -- )
HOOK: set-fullscreen? ui-backend ( ? world -- )
HOOK: fullscreen? ui-backend ( world -- ? )
HOOK: (open-window) ui-backend ( world -- )
HOOK: (close-window) ui-backend ( handle -- )

14
extra/ui/cocoa/cocoa.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays cocoa cocoa.application command-line
USING: math arrays cocoa cocoa.application command-line
kernel memory namespaces cocoa.messages cocoa.runtime
cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows
cocoa.classes cocoa.application sequences system ui ui.backend
@ -53,6 +53,18 @@ M: pasteboard set-clipboard-contents
M: cocoa-ui-backend set-title ( string world -- )
world-handle second swap <NSString> -> setTitle: ;
: enter-fullscreen ( world -- )
world-handle first NSScreen -> mainScreen f -> enterFullScreenMode:withOptions: drop ;
: exit-fullscreen ( world -- )
world-handle first f -> exitFullScreenModeWithOptions: ;
M: cocoa-ui-backend set-fullscreen? ( ? world -- )
swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
M: cocoa-ui-backend fullscreen? ( world -- ? )
world-handle first -> isInFullScreenMode zero? not ;
: auto-position ( world -- )
dup world-loc { 0 0 } = [
world-handle second -> center

16
extra/ui/gadgets/editors/editors.factor
View File

@ -363,9 +363,21 @@ editor "clipboard" f {
{ T{ cut-action } cut }
} define-command-map
: previous-character T{ char-elt } editor-prev ;
: previous-character ( editor -- )
dup gadget-selection? [
dup selection-start/end drop
over set-caret mark>caret
] [
T{ char-elt } editor-prev
] if ;
: next-character T{ char-elt } editor-next ;
: next-character ( editor -- )
dup gadget-selection? [
dup selection-start/end nip
over set-caret mark>caret
] [
T{ char-elt } editor-next
] if ;
: previous-line T{ line-elt } editor-prev ;

9
extra/ui/gadgets/worlds/worlds-docs.factor
View File

@ -13,6 +13,15 @@ HELP: set-title
{ $description "Sets the title bar of the native window containing the world." }
{ $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ;
HELP: set-fullscreen?
{ $values { "?" "a boolean" } { "world" world } }
{ $description "Sets and unsets fullscreen mode for the world." }
{ $notes "Find a world using " { $link find-world } "." } ;
HELP: fullscreen?
{ $values { "world" world } { "?" "a boolean" } }
{ $description "Queries the world to see if it is running in fullscreen mode." } ;
HELP: raise-window
{ $values { "world" world } }
{ $description "Makes the native window containing the given world the front-most window." }

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

@ -21,21 +21,21 @@ TUPLE: walker model interpreter history ;
: walker-active? ( walker -- ? )
walker-interpreter interpreter-continuation >boolean ;
: walker-command ( gadget quot -- )
over walker-active? [ with-walker ] [ 2drop ] if ; inline
: save-interpreter ( walker -- )
dup walker-interpreter interpreter-continuation clone
swap walker-history push ;
: com-step ( walker -- )
dup save-interpreter [ step ] walker-command ;
: walker-command ( gadget quot -- )
over walker-active? [
over save-interpreter
with-walker
] [ 2drop ] if ; inline
: com-into ( walker -- )
dup save-interpreter [ step-into ] walker-command ;
: com-step ( walker -- ) [ step ] walker-command ;
: com-out ( walker -- )
dup save-interpreter [ step-out ] walker-command ;
: com-into ( walker -- ) [ step-into ] walker-command ;
: com-out ( walker -- ) [ step-out ] walker-command ;
: com-back ( walker -- )
dup walker-history

7
extra/webapps/planet/planet.factor
View File

@ -86,8 +86,8 @@ SYMBOL: last-update
\ fetch-feed DEBUG add-error-logging
: fetch-blogroll ( blogroll -- entries )
dup 0 <column>
swap [ fetch-feed ] parallel-map
dup 0 <column> swap 1 <column>
[ fetch-feed ] parallel-map
[ [ <posting> ] with map ] 2map concat ;
: sort-entries ( entries -- entries' )
@ -120,9 +120,6 @@ SYMBOL: last-update
{ "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
{ "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
{ "Gavin Harrison" "http://gmh33.blogspot.com/feeds/posts/default" "http://gmh33.blogspot.com/" }
{ "Kevin Marshall"
"http://blog.botfu.com/?cat=9&feed=atom"
"http://blog.botfu.com/" }
{ "Kio M. Smallwood"
"http://sekenre.wordpress.com/feed/atom/"
"http://sekenre.wordpress.com/" }

28
misc/factor.el
View File

@ -131,10 +131,30 @@
(comint-send-string "*factor*" (format "\"%s\"" (buffer-file-name)))
(comint-send-string "*factor*" " run-file\n"))
;; (defun factor-send-region (start end)
;; (interactive "r")
;; (comint-send-region "*factor*" start end)
;; (comint-send-string "*factor*" "\n"))
(defun factor-send-string (str)
(let ((n (length (split-string str "\n"))))
(save-excursion
(set-buffer "*factor*")
(goto-char (point-max))
(if (> n 1) (newline))
(insert str)
(comint-send-input))))
(defun factor-send-region (start end)
(interactive "r")
(comint-send-region "*factor*" start end)
(comint-send-string "*factor*" "\n"))
(let ((str (buffer-substring start end))
(n (count-lines start end)))
(save-excursion
(set-buffer "*factor*")
(goto-char (point-max))
(if (> n 1) (newline))
(insert str)
(comint-send-input))))
(defun factor-see ()
(interactive)
@ -153,6 +173,10 @@
(comint-send-string "*factor*" "\\ ")
(comint-send-string "*factor*" (thing-at-point 'sexp))
(comint-send-string "*factor*" " edit\n"))
(defun factor-clear ()
(interactive)
(factor-send-string "clear"))
(defun factor-comment-line ()
(interactive)

91
vm/debug.c
View File

@ -21,7 +21,7 @@ void print_word(F_WORD* word, CELL nesting)
else
{
printf("#<not a string: ");
print_nested_obj(word->name,nesting - 1);
print_nested_obj(word->name,nesting);
printf(">");
}
}
@ -44,13 +44,13 @@ void print_array(F_ARRAY* array, CELL nesting)
for(i = 0; i < length; i++)
{
printf(" ");
print_nested_obj(array_nth(array,i),nesting - 1);
print_nested_obj(array_nth(array,i),nesting);
}
}
void print_nested_obj(CELL obj, CELL nesting)
void print_nested_obj(CELL obj, F_FIXNUM nesting)
{
if(nesting == 0)
if(nesting <= 0)
{
printf(" ... ");
return;
@ -204,7 +204,7 @@ void dump_objects(F_FIXNUM type)
if(type == -1 || type_of(obj) == type)
{
printf("%lx ",obj);
print_nested_obj(obj,1);
print_nested_obj(obj,2);
printf("\n");
}
}
@ -213,36 +213,58 @@ void dump_objects(F_FIXNUM type)
gc_off = false;
}
CELL obj;
CELL look_for;
void find_references_step(CELL *scan)
void find_data_references(CELL look_for)
{
if(look_for == *scan)
CELL obj;
void find_references_step(CELL *scan)
{
printf("%lx ",obj);
print_nested_obj(obj,1);
printf("\n");
if(look_for == *scan)
{
printf("%lx ",obj);
print_nested_obj(obj,2);
printf("\n");
}
}
}
void find_references(CELL look_for_)
{
look_for = look_for_;
begin_scan();
CELL obj_;
while((obj_ = next_object()) != F)
{
obj = obj_;
do_slots(obj_,find_references_step);
}
while((obj = next_object()) != F)
do_slots(UNTAG(obj),find_references_step);
/* end scan */
gc_off = false;
}
void find_code_references(CELL look_for)
{
void find_references_step(F_COMPILED *compiled, CELL code_start,
CELL reloc_start, CELL literals_start)
{
CELL scan;
CELL literal_end = literals_start + compiled->literals_length;
for(scan = literals_start; scan < literal_end; scan += CELLS)
{
CELL code_start = (CELL)(compiled + 1);
CELL literal_start = code_start
+ compiled->code_length
+ compiled->reloc_length;
CELL obj = get(literal_start);
if(look_for == get(scan))
{
printf("%lx ",obj);
print_nested_obj(obj,2);
printf("\n");
}
}
}
iterate_code_heap(find_references_step);
}
void factorbug(void)
{
reset_stdio();
@ -265,6 +287,9 @@ void factorbug(void)
printf("addr <card> -- print address containing card\n");
printf("data -- data heap dump\n");
printf("words -- words dump\n");
printf("tuples -- tuples dump\n");
printf("refs <addr> -- find data heap references to object\n");
printf("push <addr> -- push object on data stack - NOT SAFE\n");
printf("code -- code heap dump\n");
for(;;)
@ -335,8 +360,26 @@ void factorbug(void)
save_image(STR_FORMAT("fep.image"));
else if(strcmp(cmd,"data") == 0)
dump_objects(-1);
else if(strcmp(cmd,"refs") == 0)
{
CELL addr;
scanf("%lx",&addr);
printf("Data heap references:\n");
find_data_references(addr);
printf("Code heap references:\n");
find_code_references(addr);
printf("\n");
}
else if(strcmp(cmd,"words") == 0)
dump_objects(WORD_TYPE);
else if(strcmp(cmd,"tuples") == 0)
dump_objects(TUPLE_TYPE);
else if(strcmp(cmd,"push") == 0)
{
CELL addr;
scanf("%lx",&addr);
dpush(addr);
}
else if(strcmp(cmd,"code") == 0)
dump_heap(&code_heap);
else

2
vm/debug.h Normal file → Executable file
View File

@ -1,5 +1,5 @@
void print_obj(CELL obj);
void print_nested_obj(CELL obj, CELL nesting);
void print_nested_obj(CELL obj, F_FIXNUM nesting);
void dump_generations(void);
void factorbug(void);

4
vm/factor.c
View File

@ -154,6 +154,8 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
init_factor(&p);
nest_stacks();
F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F);
for(i = 1; i < argc; i++)
@ -173,8 +175,6 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
userenv[EXECUTABLE_ENV] = tag_object(from_native_string(executable_path));
userenv[EMBEDDED_ENV] = (embedded ? T : F);
nest_stacks();
if(p.console)
open_console();