Merge branch 'master' of git://factorcode.org/git/factor
Aaron Schaefer
commit
8275ae01a7
10
Makefile
10
Makefile
|
|
@ -123,7 +123,15 @@ solaris-x86-32:
|
|||
solaris-x86-64:
|
||||
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64
|
||||
|
||||
winnt-x86-32:
|
||||
freetype6.dll:
|
||||
wget http://factorcode.org/dlls/freetype6.dll
|
||||
chmod 755 freetype6.dll
|
||||
|
||||
zlib1.dll:
|
||||
wget http://factorcode.org/dlls/zlib1.dll
|
||||
chmod 755 zlib1.dll
|
||||
|
||||
winnt-x86-32: freetype6.dll zlib1.dll
|
||||
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
|
||||
|
||||
winnt-x86-64:
|
||||
|
|
|
|||
|
|
@ -7,6 +7,11 @@ math.parser cpu.architecture alien alien.accessors quotations
|
|||
system compiler.units ;
|
||||
IN: alien.c-types
|
||||
|
||||
DEFER: <int>
|
||||
DEFER: *char
|
||||
|
||||
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
|
||||
|
||||
TUPLE: c-type
|
||||
boxer prep unboxer
|
||||
getter setter
|
||||
|
|
|
|||
|
|
@ -1,21 +1,7 @@
|
|||
USING: io.files tools.test sequences namespaces kernel
|
||||
compiler.units ;
|
||||
IN: temporary
|
||||
USING: tools.browser tools.test kernel sequences vocabs ;
|
||||
|
||||
{
|
||||
"templates-early"
|
||||
"simple"
|
||||
"intrinsics"
|
||||
"float"
|
||||
"generic"
|
||||
"ifte"
|
||||
"templates"
|
||||
"optimizer"
|
||||
"redefine"
|
||||
"stack-trace"
|
||||
"alien"
|
||||
"curry"
|
||||
"tuples"
|
||||
}
|
||||
[ "resource:core/compiler/test/" swap ".factor" 3append ] map
|
||||
[ run-test ] map
|
||||
[ failures get push-all ] each
|
||||
"compiler.test" child-vocabs empty? [
|
||||
"compiler.test" load-children
|
||||
"compiler.test" test
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -1,30 +0,0 @@
|
|||
IN: temporary
|
||||
USING: compiler generic tools.test math kernel words arrays
|
||||
sequences quotations ;
|
||||
|
||||
GENERIC: single-combination-test
|
||||
|
||||
M: object single-combination-test drop ;
|
||||
M: f single-combination-test nip ;
|
||||
M: array single-combination-test drop ;
|
||||
M: integer single-combination-test drop ;
|
||||
|
||||
[ 2 3 ] [ 2 3 t single-combination-test ] unit-test
|
||||
[ 2 3 ] [ 2 3 4 single-combination-test ] unit-test
|
||||
[ 2 f ] [ 2 3 f single-combination-test ] unit-test
|
||||
|
||||
DEFER: single-combination-test-2
|
||||
|
||||
: single-combination-test-4
|
||||
dup [ single-combination-test-2 ] when ;
|
||||
|
||||
: single-combination-test-3
|
||||
drop 3 ;
|
||||
|
||||
GENERIC: single-combination-test-2
|
||||
M: object single-combination-test-2 single-combination-test-3 ;
|
||||
M: f single-combination-test-2 single-combination-test-4 ;
|
||||
|
||||
[ 3 ] [ t single-combination-test-2 ] unit-test
|
||||
[ 3 ] [ 3 single-combination-test-2 ] unit-test
|
||||
[ f ] [ f single-combination-test-2 ] unit-test
|
||||
|
|
@ -1,131 +0,0 @@
|
|||
IN: temporary
|
||||
USING: alien strings compiler tools.test math kernel words
|
||||
math.private combinators ;
|
||||
|
||||
: dummy-if-1 t [ ] [ ] if ;
|
||||
|
||||
[ ] [ dummy-if-1 ] unit-test
|
||||
|
||||
: dummy-if-2 f [ ] [ ] if ;
|
||||
|
||||
[ ] [ dummy-if-2 ] unit-test
|
||||
|
||||
: dummy-if-3 t [ 1 ] [ 2 ] if ;
|
||||
|
||||
[ 1 ] [ dummy-if-3 ] unit-test
|
||||
|
||||
: dummy-if-4 f [ 1 ] [ 2 ] if ;
|
||||
|
||||
[ 2 ] [ dummy-if-4 ] unit-test
|
||||
|
||||
: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
|
||||
|
||||
[ 1 ] [ dummy-if-5 ] unit-test
|
||||
|
||||
: dummy-if-6
|
||||
dup 1 fixnum<= [
|
||||
drop 1
|
||||
] [
|
||||
1 fixnum- dup 1 fixnum- fixnum+
|
||||
] if ;
|
||||
|
||||
[ 17 ] [ 10 dummy-if-6 ] unit-test
|
||||
|
||||
: dead-code-rec
|
||||
t [
|
||||
3.2
|
||||
] [
|
||||
dead-code-rec
|
||||
] if ;
|
||||
|
||||
[ 3.2 ] [ dead-code-rec ] unit-test
|
||||
|
||||
: one-rec [ f one-rec ] [ "hi" ] if ;
|
||||
|
||||
[ "hi" ] [ t one-rec ] unit-test
|
||||
|
||||
: after-if-test
|
||||
t [ ] [ ] if 5 ;
|
||||
|
||||
[ 5 ] [ after-if-test ] unit-test
|
||||
|
||||
DEFER: countdown-b
|
||||
|
||||
: countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] if ;
|
||||
: countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] if ;
|
||||
|
||||
[ ] [ 10 countdown-b ] unit-test
|
||||
|
||||
: dummy-when-1 t [ ] when ;
|
||||
|
||||
[ ] [ dummy-when-1 ] unit-test
|
||||
|
||||
: dummy-when-2 f [ ] when ;
|
||||
|
||||
[ ] [ dummy-when-2 ] unit-test
|
||||
|
||||
: dummy-when-3 dup [ dup fixnum* ] when ;
|
||||
|
||||
[ 16 ] [ 4 dummy-when-3 ] unit-test
|
||||
[ f ] [ f dummy-when-3 ] unit-test
|
||||
|
||||
: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ;
|
||||
|
||||
[ 64 f ] [ f 4 dummy-when-4 ] unit-test
|
||||
[ f t ] [ t f dummy-when-4 ] unit-test
|
||||
|
||||
: dummy-when-5 f [ dup fixnum* ] when ;
|
||||
|
||||
[ f ] [ f dummy-when-5 ] unit-test
|
||||
|
||||
: dummy-unless-1 t [ ] unless ;
|
||||
|
||||
[ ] [ dummy-unless-1 ] unit-test
|
||||
|
||||
: dummy-unless-2 f [ ] unless ;
|
||||
|
||||
[ ] [ dummy-unless-2 ] unit-test
|
||||
|
||||
: dummy-unless-3 dup [ drop 3 ] unless ;
|
||||
|
||||
[ 3 ] [ f dummy-unless-3 ] unit-test
|
||||
[ 4 ] [ 4 dummy-unless-3 ] unit-test
|
||||
|
||||
! Test cond expansion
|
||||
[ "even" ] [
|
||||
[
|
||||
2 {
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
} cond
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
||||
[ "odd" ] [
|
||||
[
|
||||
3 {
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
} cond
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
||||
[ "neither" ] [
|
||||
[
|
||||
3 {
|
||||
{ [ dup string? ] [ drop "string" ] }
|
||||
{ [ dup float? ] [ drop "float" ] }
|
||||
{ [ dup alien? ] [ drop "alien" ] }
|
||||
{ [ t ] [ drop "neither" ] }
|
||||
} cond
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
||||
[ 3 ] [
|
||||
[
|
||||
3 {
|
||||
{ [ dup fixnum? ] [ ] }
|
||||
{ [ t ] [ drop t ] }
|
||||
} cond
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
|
@ -1,71 +0,0 @@
|
|||
USING: compiler tools.test kernel kernel.private
|
||||
combinators.private ;
|
||||
IN: temporary
|
||||
|
||||
! Test empty word
|
||||
[ ] [ [ ] compile-call ] unit-test
|
||||
|
||||
! Test literals
|
||||
[ 1 ] [ [ 1 ] compile-call ] unit-test
|
||||
[ 31 ] [ [ 31 ] compile-call ] unit-test
|
||||
[ 255 ] [ [ 255 ] compile-call ] unit-test
|
||||
[ -1 ] [ [ -1 ] compile-call ] unit-test
|
||||
[ 65536 ] [ [ 65536 ] compile-call ] unit-test
|
||||
[ -65536 ] [ [ -65536 ] compile-call ] unit-test
|
||||
[ "hey" ] [ [ "hey" ] compile-call ] unit-test
|
||||
|
||||
! Calls
|
||||
: no-op ;
|
||||
|
||||
[ ] [ [ no-op ] compile-call ] unit-test
|
||||
[ 3 ] [ [ no-op 3 ] compile-call ] unit-test
|
||||
[ 3 ] [ [ 3 no-op ] compile-call ] unit-test
|
||||
|
||||
: bar 4 ;
|
||||
|
||||
[ 4 ] [ [ bar no-op ] compile-call ] unit-test
|
||||
[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test
|
||||
[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test
|
||||
|
||||
[ ] [ no-op ] unit-test
|
||||
|
||||
! Conditionals
|
||||
|
||||
[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
|
||||
[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
|
||||
[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
|
||||
[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
|
||||
|
||||
[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
|
||||
[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
|
||||
|
||||
[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
|
||||
[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
|
||||
|
||||
[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
|
||||
[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
|
||||
[ 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
|
||||
|
||||
! Labels
|
||||
|
||||
: recursive ( ? -- ) [ f recursive ] when ; inline
|
||||
|
||||
[ ] [ t [ recursive ] compile-call ] unit-test
|
||||
|
||||
[ ] [ t recursive ] unit-test
|
||||
|
||||
! Make sure error reporting works
|
||||
|
||||
[ [ dup ] compile-call ] must-fail
|
||||
[ [ drop ] compile-call ] must-fail
|
||||
|
||||
! Regression
|
||||
|
||||
[ ] [ [ callstack ] compile-call drop ] unit-test
|
||||
|
||||
! Regression
|
||||
|
||||
: empty ;
|
||||
|
||||
[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test
|
||||
|
|
@ -0,0 +1,227 @@
|
|||
USING: compiler tools.test kernel kernel.private
|
||||
combinators.private math.private math combinators strings
|
||||
alien arrays ;
|
||||
IN: temporary
|
||||
|
||||
! Test empty word
|
||||
[ ] [ [ ] compile-call ] unit-test
|
||||
|
||||
! Test literals
|
||||
[ 1 ] [ [ 1 ] compile-call ] unit-test
|
||||
[ 31 ] [ [ 31 ] compile-call ] unit-test
|
||||
[ 255 ] [ [ 255 ] compile-call ] unit-test
|
||||
[ -1 ] [ [ -1 ] compile-call ] unit-test
|
||||
[ 65536 ] [ [ 65536 ] compile-call ] unit-test
|
||||
[ -65536 ] [ [ -65536 ] compile-call ] unit-test
|
||||
[ "hey" ] [ [ "hey" ] compile-call ] unit-test
|
||||
|
||||
! Calls
|
||||
: no-op ;
|
||||
|
||||
[ ] [ [ no-op ] compile-call ] unit-test
|
||||
[ 3 ] [ [ no-op 3 ] compile-call ] unit-test
|
||||
[ 3 ] [ [ 3 no-op ] compile-call ] unit-test
|
||||
|
||||
: bar 4 ;
|
||||
|
||||
[ 4 ] [ [ bar no-op ] compile-call ] unit-test
|
||||
[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test
|
||||
[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test
|
||||
|
||||
[ ] [ no-op ] unit-test
|
||||
|
||||
! Conditionals
|
||||
|
||||
[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
|
||||
[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
|
||||
[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
|
||||
[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
|
||||
|
||||
[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
|
||||
[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
|
||||
|
||||
[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
|
||||
[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
|
||||
|
||||
[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
|
||||
[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
|
||||
[ 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
|
||||
|
||||
! Labels
|
||||
|
||||
: recursive ( ? -- ) [ f recursive ] when ; inline
|
||||
|
||||
[ ] [ t [ recursive ] compile-call ] unit-test
|
||||
|
||||
[ ] [ t recursive ] unit-test
|
||||
|
||||
! Make sure error reporting works
|
||||
|
||||
[ [ dup ] compile-call ] must-fail
|
||||
[ [ drop ] compile-call ] must-fail
|
||||
|
||||
! Regression
|
||||
|
||||
[ ] [ [ callstack ] compile-call drop ] unit-test
|
||||
|
||||
! Regression
|
||||
|
||||
: empty ;
|
||||
|
||||
[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test
|
||||
|
||||
: dummy-if-1 t [ ] [ ] if ;
|
||||
|
||||
[ ] [ dummy-if-1 ] unit-test
|
||||
|
||||
: dummy-if-2 f [ ] [ ] if ;
|
||||
|
||||
[ ] [ dummy-if-2 ] unit-test
|
||||
|
||||
: dummy-if-3 t [ 1 ] [ 2 ] if ;
|
||||
|
||||
[ 1 ] [ dummy-if-3 ] unit-test
|
||||
|
||||
: dummy-if-4 f [ 1 ] [ 2 ] if ;
|
||||
|
||||
[ 2 ] [ dummy-if-4 ] unit-test
|
||||
|
||||
: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
|
||||
|
||||
[ 1 ] [ dummy-if-5 ] unit-test
|
||||
|
||||
: dummy-if-6
|
||||
dup 1 fixnum<= [
|
||||
drop 1
|
||||
] [
|
||||
1 fixnum- dup 1 fixnum- fixnum+
|
||||
] if ;
|
||||
|
||||
[ 17 ] [ 10 dummy-if-6 ] unit-test
|
||||
|
||||
: dead-code-rec
|
||||
t [
|
||||
3.2
|
||||
] [
|
||||
dead-code-rec
|
||||
] if ;
|
||||
|
||||
[ 3.2 ] [ dead-code-rec ] unit-test
|
||||
|
||||
: one-rec [ f one-rec ] [ "hi" ] if ;
|
||||
|
||||
[ "hi" ] [ t one-rec ] unit-test
|
||||
|
||||
: after-if-test
|
||||
t [ ] [ ] if 5 ;
|
||||
|
||||
[ 5 ] [ after-if-test ] unit-test
|
||||
|
||||
DEFER: countdown-b
|
||||
|
||||
: countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] if ;
|
||||
: countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] if ;
|
||||
|
||||
[ ] [ 10 countdown-b ] unit-test
|
||||
|
||||
: dummy-when-1 t [ ] when ;
|
||||
|
||||
[ ] [ dummy-when-1 ] unit-test
|
||||
|
||||
: dummy-when-2 f [ ] when ;
|
||||
|
||||
[ ] [ dummy-when-2 ] unit-test
|
||||
|
||||
: dummy-when-3 dup [ dup fixnum* ] when ;
|
||||
|
||||
[ 16 ] [ 4 dummy-when-3 ] unit-test
|
||||
[ f ] [ f dummy-when-3 ] unit-test
|
||||
|
||||
: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ;
|
||||
|
||||
[ 64 f ] [ f 4 dummy-when-4 ] unit-test
|
||||
[ f t ] [ t f dummy-when-4 ] unit-test
|
||||
|
||||
: dummy-when-5 f [ dup fixnum* ] when ;
|
||||
|
||||
[ f ] [ f dummy-when-5 ] unit-test
|
||||
|
||||
: dummy-unless-1 t [ ] unless ;
|
||||
|
||||
[ ] [ dummy-unless-1 ] unit-test
|
||||
|
||||
: dummy-unless-2 f [ ] unless ;
|
||||
|
||||
[ ] [ dummy-unless-2 ] unit-test
|
||||
|
||||
: dummy-unless-3 dup [ drop 3 ] unless ;
|
||||
|
||||
[ 3 ] [ f dummy-unless-3 ] unit-test
|
||||
[ 4 ] [ 4 dummy-unless-3 ] unit-test
|
||||
|
||||
! Test cond expansion
|
||||
[ "even" ] [
|
||||
[
|
||||
2 {
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
} cond
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
||||
[ "odd" ] [
|
||||
[
|
||||
3 {
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
} cond
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
||||
[ "neither" ] [
|
||||
[
|
||||
3 {
|
||||
{ [ dup string? ] [ drop "string" ] }
|
||||
{ [ dup float? ] [ drop "float" ] }
|
||||
{ [ dup alien? ] [ drop "alien" ] }
|
||||
{ [ t ] [ drop "neither" ] }
|
||||
} cond
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
||||
[ 3 ] [
|
||||
[
|
||||
3 {
|
||||
{ [ dup fixnum? ] [ ] }
|
||||
{ [ t ] [ drop t ] }
|
||||
} cond
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
||||
GENERIC: single-combination-test
|
||||
|
||||
M: object single-combination-test drop ;
|
||||
M: f single-combination-test nip ;
|
||||
M: array single-combination-test drop ;
|
||||
M: integer single-combination-test drop ;
|
||||
|
||||
[ 2 3 ] [ 2 3 t single-combination-test ] unit-test
|
||||
[ 2 3 ] [ 2 3 4 single-combination-test ] unit-test
|
||||
[ 2 f ] [ 2 3 f single-combination-test ] unit-test
|
||||
|
||||
DEFER: single-combination-test-2
|
||||
|
||||
: single-combination-test-4
|
||||
dup [ single-combination-test-2 ] when ;
|
||||
|
||||
: single-combination-test-3
|
||||
drop 3 ;
|
||||
|
||||
GENERIC: single-combination-test-2
|
||||
M: object single-combination-test-2 single-combination-test-3 ;
|
||||
M: f single-combination-test-2 single-combination-test-4 ;
|
||||
|
||||
[ 3 ] [ t single-combination-test-2 ] unit-test
|
||||
[ 3 ] [ 3 single-combination-test-2 ] unit-test
|
||||
[ f ] [ f single-combination-test-2 ] unit-test
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -263,3 +263,13 @@ cell-bits 32 = [
|
|||
\ fixnum-shift inlined?
|
||||
] unit-test
|
||||
] when
|
||||
|
||||
[ t ] [
|
||||
[ B{ 1 0 } *short 0 number= ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ B{ 1 0 } *short 0 = ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -414,64 +414,81 @@ t over set-effect-terminated?
|
|||
\ <displaced-alien> make-flushable
|
||||
|
||||
\ alien-signed-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-signed-cell make-flushable
|
||||
|
||||
\ set-alien-signed-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ alien-unsigned-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-unsigned-cell make-flushable
|
||||
|
||||
\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ alien-signed-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-signed-8 make-flushable
|
||||
|
||||
\ set-alien-signed-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ alien-unsigned-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-unsigned-8 make-flushable
|
||||
|
||||
\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ alien-signed-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-signed-4 make-flushable
|
||||
|
||||
\ set-alien-signed-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ alien-unsigned-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-unsigned-4 make-flushable
|
||||
|
||||
\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ alien-signed-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-signed-2 make-flushable
|
||||
|
||||
\ set-alien-signed-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-unsigned-2 make-flushable
|
||||
|
||||
\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ alien-signed-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-signed-1 make-flushable
|
||||
|
||||
\ set-alien-signed-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-unsigned-1 make-flushable
|
||||
|
||||
\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ alien-float { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-float make-flushable
|
||||
|
||||
\ set-alien-float { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ alien-double { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-double make-flushable
|
||||
|
||||
\ set-alien-double { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-cell make-flushable
|
||||
|
||||
\ set-alien-cell { c-ptr c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ alien>char-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
|
||||
\ alien>char-string make-flushable
|
||||
|
||||
\ string>char-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
|
||||
\ string>char-alien make-flushable
|
||||
|
||||
\ alien>u16-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
|
||||
\ alien>u16-string make-flushable
|
||||
|
||||
\ string>u16-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
|
||||
\ string>u16-alien make-flushable
|
||||
|
||||
\ alien-address { alien } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-address make-flushable
|
||||
|
|
|
|||
|
|
@ -54,7 +54,9 @@ M: pair (bitfield-quot) ( spec -- quot )
|
|||
|
||||
\ bitfield [ bitfield-quot ] 1 define-transform
|
||||
|
||||
\ flags [ flags [ ] curry ] 1 define-transform
|
||||
\ flags [
|
||||
[ 0 , [ , \ bitor , ] each ] [ ] make
|
||||
] 1 define-transform
|
||||
|
||||
! Tuple operations
|
||||
: [get-slots] ( slots -- quot )
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: math math.bitfields tools.test kernel ;
|
||||
USING: math math.bitfields tools.test kernel words ;
|
||||
IN: temporary
|
||||
|
||||
[ 0 ] [ { } bitfield ] unit-test
|
||||
|
|
@ -6,3 +6,12 @@ IN: temporary
|
|||
[ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test
|
||||
[ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test
|
||||
[ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test
|
||||
|
||||
: a 1 ; inline
|
||||
: b 2 ; inline
|
||||
|
||||
: foo { a b } flags ;
|
||||
|
||||
[ 3 ] [ foo ] unit-test
|
||||
[ 3 ] [ { a b } flags ] unit-test
|
||||
[ t ] [ \ foo compiled? ] unit-test
|
||||
|
|
|
|||
|
|
@ -300,3 +300,4 @@ TUPLE: silly-tuple a b ;
|
|||
[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
|
||||
[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
|
||||
[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
|
||||
[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
|
||||
|
|
@ -18,7 +18,7 @@ TUPLE: lexer text line line-text line-length column ;
|
|||
|
||||
: <lexer> ( text -- lexer )
|
||||
0 { set-lexer-text set-lexer-line } lexer construct
|
||||
dup lexer-text empty? [ dup next-line ] unless ;
|
||||
dup next-line ;
|
||||
|
||||
: location ( -- loc )
|
||||
file get lexer get lexer-line 2dup and
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
enterprise
|
||||
|
|
@ -9,6 +9,6 @@ IN: benchmark.bootstrap2
|
|||
"-i=" my-boot-image-name append ,
|
||||
"-output-image=foo.image" ,
|
||||
"-no-user-init" ,
|
||||
] { } make run-process drop ;
|
||||
] { } make try-process ;
|
||||
|
||||
MAIN: bootstrap-benchmark
|
||||
|
|
|
|||
|
|
@ -23,3 +23,7 @@ bootstrap.image sequences io ;
|
|||
"Boot image up to date" print
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: download-my-image ( -- ) my-arch download-image ;
|
||||
|
||||
MAIN: download-my-image
|
||||
|
|
|
|||
|
|
@ -16,8 +16,7 @@ bootstrap.image sequences io namespaces io.launcher math ;
|
|||
: upload-images ( -- )
|
||||
[
|
||||
"scp" , boot-image-names % "checksums.txt" , destination ,
|
||||
] { } make run-process
|
||||
wait-for-process zero? [ "Upload failed" throw ] unless ;
|
||||
] { } make try-process ;
|
||||
|
||||
: new-images ( -- )
|
||||
make-images compute-checksums upload-images ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
|
||||
USING: kernel io io.files io.launcher hashtables tools.deploy.backend
|
||||
USING: kernel io io.files io.launcher hashtables
|
||||
system continuations namespaces sequences splitting math.parser
|
||||
prettyprint tools.time calendar bake vars http.client
|
||||
combinators ;
|
||||
combinators bootstrap.image bootstrap.image.download ;
|
||||
|
||||
IN: builder
|
||||
|
||||
|
|
@ -59,8 +59,12 @@ VAR: stamp
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: build-status
|
||||
|
||||
: build ( -- )
|
||||
|
||||
"running" build-status set-global
|
||||
|
||||
datestamp >stamp
|
||||
|
||||
"/builds/factor" cd
|
||||
|
|
@ -70,7 +74,6 @@ VAR: stamp
|
|||
"pull"
|
||||
"--no-summary"
|
||||
"git://factorcode.org/git/factor.git"
|
||||
! "http://dharmatech.onigirihouse.com/factor.git"
|
||||
"master"
|
||||
}
|
||||
run-process process-status
|
||||
|
|
@ -82,6 +85,11 @@ VAR: stamp
|
|||
]
|
||||
if
|
||||
|
||||
{
|
||||
"git" "pull" "--no-summary"
|
||||
"http://dharmatech.onigirihouse.com/factor.git" "master"
|
||||
} run-process drop
|
||||
|
||||
"/builds/" stamp> append make-directory
|
||||
"/builds/" stamp> append cd
|
||||
|
||||
|
|
@ -94,6 +102,8 @@ VAR: stamp
|
|||
|
||||
{ "make" "clean" } run-process drop
|
||||
|
||||
! "vm" build-status set-global
|
||||
|
||||
`{
|
||||
{ +arguments+ { "make" ,[ target ] } }
|
||||
{ +stdout+ "../compile-log" }
|
||||
|
|
@ -107,14 +117,17 @@ VAR: stamp
|
|||
"builder: vm compile" throw
|
||||
] if
|
||||
|
||||
[ "http://factorcode.org/images/latest/" boot-image-name append download ]
|
||||
[ my-arch download-image ]
|
||||
[ ]
|
||||
[ "builder: image download" email-string ]
|
||||
recover
|
||||
cleanup
|
||||
|
||||
! "bootstrap" build-status set-global
|
||||
|
||||
`{
|
||||
{ +arguments+ {
|
||||
,[ factor-binary ]
|
||||
,[ "-i=" boot-image-name append ]
|
||||
,[ "-i=" my-boot-image-name append ]
|
||||
"-no-user-init"
|
||||
} }
|
||||
{ +stdout+ "../boot-log" }
|
||||
|
|
@ -128,6 +141,8 @@ VAR: stamp
|
|||
"builder: bootstrap" throw
|
||||
] if
|
||||
|
||||
! "test" build-status set-global
|
||||
|
||||
`{ ,[ factor-binary ] "-run=builder.test" } run-process drop
|
||||
|
||||
"../load-everything-log" exists?
|
||||
|
|
@ -138,6 +153,8 @@ VAR: stamp
|
|||
[ "builder: failing tests" "../failing-tests" email-file ]
|
||||
when
|
||||
|
||||
! "ready" build-status set-global
|
||||
|
||||
;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
|||
|
|
@ -0,0 +1,68 @@
|
|||
|
||||
USING: kernel continuations namespaces threads match bake concurrency builder ;
|
||||
|
||||
IN: builder.server
|
||||
|
||||
! : build-server ( -- )
|
||||
! receive
|
||||
! {
|
||||
! {
|
||||
! "start"
|
||||
! [ [ build ] in-thread ]
|
||||
! }
|
||||
|
||||
! {
|
||||
! { ?from ?tag "status" }
|
||||
! [ `{ ?tag ,[ build-status get ] } ?from send ]
|
||||
! }
|
||||
! }
|
||||
! match-cond
|
||||
! build-server ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! : build-server ( -- )
|
||||
! receive
|
||||
! {
|
||||
! {
|
||||
! "start"
|
||||
! [
|
||||
! [ [ build ] [ drop ] recover "idle" build-status set-global ] in-thread
|
||||
! ]
|
||||
! }
|
||||
|
||||
! {
|
||||
! { ?from ?tag "status" }
|
||||
! [ `{ ?tag ,[ build-status get ] } ?from send ]
|
||||
! }
|
||||
! }
|
||||
! match-cond
|
||||
! build-server ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: build-server ( -- )
|
||||
receive
|
||||
{
|
||||
{
|
||||
"start"
|
||||
[
|
||||
build-status get "idle" =
|
||||
build-status get f =
|
||||
or
|
||||
[
|
||||
[ [ build ] [ drop ] recover "idle" build-status set-global ]
|
||||
in-thread
|
||||
]
|
||||
when
|
||||
]
|
||||
}
|
||||
|
||||
{
|
||||
{ ?from ?tag "status" }
|
||||
[ `{ ?tag ,[ build-status get ] } ?from send ]
|
||||
}
|
||||
}
|
||||
match-cond
|
||||
build-server ;
|
||||
|
||||
|
|
@ -8,27 +8,17 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader
|
|||
IN: builder.test
|
||||
|
||||
: do-load ( -- )
|
||||
[
|
||||
[ load-everything ]
|
||||
[ require-all-error-vocabs "../load-everything-log" log-object ]
|
||||
recover
|
||||
]
|
||||
"../load-everything-time" log-runtime ;
|
||||
[ try-everything ] "../load-everything-time" log-runtime
|
||||
dup empty?
|
||||
[ drop ]
|
||||
[ "../load-everything-log" log-object ]
|
||||
if ;
|
||||
|
||||
: do-tests ( -- )
|
||||
"" child-vocabs
|
||||
[ vocab-source-loaded? ] subset
|
||||
[ vocab-tests-path ] map
|
||||
[ dup [ ?resource-path exists? ] when ] subset
|
||||
[ dup run-test ] { } map>assoc
|
||||
[ second empty? not ] subset
|
||||
run-all-tests keys
|
||||
dup empty?
|
||||
[ drop ]
|
||||
[
|
||||
"../failing-tests" <file-writer>
|
||||
[ [ nl failures. ] assoc-each ]
|
||||
with-stream
|
||||
]
|
||||
[ "../failing-tests" log-object ]
|
||||
if ;
|
||||
|
||||
: do-all ( -- ) do-load do-tests ;
|
||||
|
|
|
|||
|
|
@ -138,7 +138,7 @@ ARTICLE: { "concurrency" "servers" } "Servers"
|
|||
ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous Sends"
|
||||
{ $link send } " sends a message asynchronously, and the sending process continues immediately. The 'pong server' example shown previously all sent messages to the server and waited for a reply back from the server. This pattern of synchronous sending is made easier with " { $link send-synchronous } ".\n\nThis word will send a message to the given process and immediately block until a reply is received for this particular message send. It leaves the reply on the stack. Note that it doesn't wait for just any reply, it waits for a reply specifically to this send.\n\nTo do this it wraps the requested message inside a tagged message format using " { $link tag-message } ":"
|
||||
{ $code "\"My Message\" tag-message .\n => { ...from... ...tag... \"My Message\" }" }
|
||||
"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag can is used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':"
|
||||
"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag is used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':"
|
||||
{ $code ": pong-server ( -- )\n receive {\n { { ?from ?tag \"ping\" } [ ?tag \"pong\" 2array ?from send pong-server ] }\n { { ?from _ } [ ?tag \"server shutdown\" 2array ?from send ] }\n } match-cond ;\n\n[ pong-server ] spawn \"ping\" swap send-synchronous .\n => \"pong\"" }
|
||||
"Notice that the code to send the reply back to the original caller wraps the reply in an array where the first item is the tag originally sent. 'send-synchronous' only returns if it receives a reply containing that specific tag." ;
|
||||
|
||||
|
|
|
|||
|
|
@ -112,9 +112,9 @@ SYMBOL: value
|
|||
! The following unit test blocks forever if the
|
||||
! exception does not propogate. Uncomment when
|
||||
! this is fixed (via a timeout).
|
||||
! [
|
||||
! [ "this should propogate" throw ] future ?future
|
||||
! ] must-fail
|
||||
[
|
||||
[ "this should propogate" throw ] future ?future
|
||||
] must-fail
|
||||
|
||||
[ ] [
|
||||
[ "this should not propogate" throw ] future drop
|
||||
|
|
@ -128,3 +128,9 @@ SYMBOL: value
|
|||
[ "testing unregistering on error" throw ] spawn
|
||||
100 sleep process-pid get-process
|
||||
] unit-test
|
||||
|
||||
! Race condition with futures
|
||||
[ 3 3 ] [
|
||||
[ 3 ] future
|
||||
dup ?future swap ?future
|
||||
] unit-test
|
||||
|
|
@ -264,19 +264,31 @@ PRIVATE>
|
|||
#! so the server continuation gets its new self updated.
|
||||
self swap call ;
|
||||
|
||||
: 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 ).
|
||||
[ self send ] compose spawn ;
|
||||
TUPLE: future value processes ;
|
||||
|
||||
: ?future ( future -- result )
|
||||
: 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.
|
||||
\ future construct-empty [
|
||||
[
|
||||
>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,
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
enterprise
|
||||
extensions
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
emulator
|
||||
emulators
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
emulator
|
||||
emulators
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
enterprise
|
||||
bindings
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1 @@
|
|||
Relational database abstraction layer
|
||||
|
|
@ -0,0 +1 @@
|
|||
enterprise
|
||||
|
|
@ -8,7 +8,7 @@ IN: editors.emacs
|
|||
"--no-wait" ,
|
||||
"+" swap number>string append ,
|
||||
,
|
||||
] { } make run-process drop ;
|
||||
] { } make try-process ;
|
||||
|
||||
: emacs ( word -- )
|
||||
where first2 emacsclient ;
|
||||
|
|
|
|||
|
|
@ -5,6 +5,6 @@ IN: editors.textmate
|
|||
|
||||
: textmate-location ( file line -- )
|
||||
[ "mate" , "-a" , "-l" , number>string , , ] { } make
|
||||
run-process drop ;
|
||||
try-process ;
|
||||
|
||||
[ textmate-location ] edit-hook set-global
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
enterprise
|
||||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays io kernel namespaces parser prettyprint sequences
|
||||
words assocs definitions generic quotations effects
|
||||
slots continuations tuples debugger combinators
|
||||
vocabs help.stylesheet help.topics help.crossref help.markup
|
||||
sorting classes ;
|
||||
words assocs definitions generic quotations effects slots
|
||||
continuations tuples debugger combinators vocabs help.stylesheet
|
||||
help.topics help.crossref help.markup sorting classes
|
||||
vocabs.loader ;
|
||||
IN: help
|
||||
|
||||
GENERIC: word-help* ( word -- content )
|
||||
|
|
@ -96,6 +96,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
|
|||
article-content print-content nl ;
|
||||
|
||||
: about ( vocab -- )
|
||||
dup require
|
||||
dup vocab [ ] [
|
||||
"No such vocabulary: " swap append throw
|
||||
] ?if
|
||||
|
|
|
|||
|
|
@ -1,2 +1,3 @@
|
|||
enterprise
|
||||
network
|
||||
web
|
||||
|
|
|
|||
|
|
@ -116,6 +116,15 @@ HELP: run-detached
|
|||
"The output value can be passed to " { $link wait-for-process } " to get an exit code."
|
||||
} ;
|
||||
|
||||
HELP: process-failed
|
||||
{ $values { "code" "an exit status" } }
|
||||
{ $description "Throws a " { $link process-failed } " error." }
|
||||
{ $error-description "Thrown by " { $link try-process } " if the process exited with a non-zero status code." } ;
|
||||
|
||||
HELP: try-process
|
||||
{ $values { "desc" "a launch descriptor" } }
|
||||
{ $description "Launches a process and waits for it to complete. If it exits with a non-zero status code, throws a " { $link process-failed } " error." } ;
|
||||
|
||||
HELP: kill-process
|
||||
{ $values { "process" process } }
|
||||
{ $description "Kills a running process. Does nothing if the process has already exited." } ;
|
||||
|
|
@ -175,6 +184,7 @@ $nl
|
|||
"The following words are used to launch processes:"
|
||||
{ $subsection run-process }
|
||||
{ $subsection run-detached }
|
||||
{ $subsection try-process }
|
||||
"Stopping processes:"
|
||||
{ $subsection kill-process }
|
||||
"Redirecting standard input and output to a pipe:"
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! 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 ;
|
||||
continuations math ;
|
||||
IN: io.launcher
|
||||
|
||||
! Non-blocking process exit notification facility
|
||||
|
|
@ -84,6 +84,15 @@ HOOK: run-process* io-backend ( desc -- handle )
|
|||
: run-detached ( desc -- process )
|
||||
>descriptor H{ { +detached+ t } } union run-process ;
|
||||
|
||||
TUPLE: process-failed code ;
|
||||
|
||||
: process-failed ( code -- * )
|
||||
\ process-failed construct-boa throw ;
|
||||
|
||||
: try-process ( desc -- )
|
||||
run-process wait-for-process dup zero?
|
||||
[ drop ] [ process-failed ] if ;
|
||||
|
||||
HOOK: kill-process* io-backend ( handle -- )
|
||||
|
||||
: kill-process ( process -- )
|
||||
|
|
|
|||
|
|
@ -9,8 +9,6 @@ TUPLE: select-mx read-fdset write-fdset ;
|
|||
! Factor's bit-arrays are an array of bytes, OS X expects
|
||||
! FD_SET to be an array of cells, so we have to account for
|
||||
! byte order differences on big endian platforms
|
||||
: little-endian? 1 <int> *char 1 = ; foldable
|
||||
|
||||
: munge ( i -- i' )
|
||||
little-endian? [ BIN: 11000 bitxor ] unless ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
enterprise
|
||||
network
|
||||
|
|
|
|||
|
|
@ -0,0 +1,31 @@
|
|||
USING: help.markup help.syntax assocs logging math ;
|
||||
IN: logging.analysis
|
||||
|
||||
HELP: analyze-entries
|
||||
{ $values { "entries" "a sequence of log entries" } { "word-names" "a sequence of strings" } { "errors" "a sequence of log entries" } { "word-histogram" assoc } { "message-histogram" assoc } }
|
||||
{ $description "Analyzes log entries:"
|
||||
{ $list
|
||||
{ "Errors (entries with level " { $link ERROR } " or " { $link CRITICAL } ") are collected into the " { $snippet "errors" } " sequence." }
|
||||
{ "All logging words are tallied into " { $snippet "word-histogram" } " - for example, this can tell you about HTTP server hit counts." }
|
||||
{ "All words listed in " { $snippet "word-names" } " have their messages tallied into " { $snippet "message-histogram" } " - for example, this can tell you about popular URLs on an HTTP server." }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: analysis.
|
||||
{ $values { "errors" "a sequence of log entries" } { "word-histogram" assoc } { "message-histogram" assoc } }
|
||||
{ $description "Prints a logging report output by " { $link analyze-entries } ". Formatted output words are used, so the report looks nice in the UI or if sent to an HTML stream." } ;
|
||||
|
||||
HELP: analyze-log
|
||||
{ $values { "service" "a log service name" } { "n" integer } { "word-names" "a sequence of strings" } }
|
||||
{ $description "Analyzes a log file and prints a formatted report. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ;
|
||||
|
||||
ARTICLE: "logging.analysis" "Log analysis"
|
||||
"The " { $vocab-link "logging.analysis" } " vocabulary builds on the " { $vocab-link "logging.parser" } " vocabulary. It parses log files and produces formatted summary reports. It is used by the " { $vocab-link "logger.insomniac" } " vocabulary to e-mail daily reports."
|
||||
$nl
|
||||
"Print log file summary:"
|
||||
{ $subsection analyze-log }
|
||||
"Factors:"
|
||||
{ $subsection analyze-entries }
|
||||
{ $subsection analysis. } ;
|
||||
|
||||
ABOUT: "logging.analysis"
|
||||
|
|
@ -11,6 +11,7 @@ SYMBOL: message-histogram
|
|||
|
||||
: analyze-entry ( entry -- )
|
||||
dup second ERROR eq? [ dup errors get push ] when
|
||||
dup second CRITICAL eq? [ dup errors get push ] when
|
||||
1 over third word-histogram get at+
|
||||
dup third word-names get member? [
|
||||
1 over 1 tail message-histogram get at+
|
||||
|
|
@ -65,5 +66,5 @@ SYMBOL: message-histogram
|
|||
"==== ERRORS:" print nl
|
||||
errors. ;
|
||||
|
||||
: log-analysis ( lines word-names -- )
|
||||
: analyze-log ( lines word-names -- )
|
||||
>r parse-log r> analyze-entries analysis. ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
enterprise
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
USING: help.markup help.syntax assocs strings logging
|
||||
logging.analysis smtp ;
|
||||
IN: logging.insomniac
|
||||
|
||||
HELP: insomniac-smtp-host
|
||||
{ $var-description "An SMTP server to use for e-mailing log reports. If not set, the value of " { $link smtp-host } " is used." } ;
|
||||
|
||||
HELP: insomniac-smtp-port
|
||||
{ $var-description "An SMTP server port to use for e-mailing log reports. If not set, the value of " { $link smtp-port } " is used." } ;
|
||||
|
||||
HELP: insomniac-sender
|
||||
{ $var-description "The originating e-mail address for mailing log reports. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ;
|
||||
|
||||
HELP: insomniac-recipients
|
||||
{ $var-description "A sequence of e-mail addresses to mail log reports to. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ;
|
||||
|
||||
HELP: ?analyze-log
|
||||
{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } { "string" string } }
|
||||
{ $description "Analyzes the most recent log and outputs the string analysis, or outputs " { $link f } " if it doesn't exist." }
|
||||
{ $see-also analyze-log } ;
|
||||
|
||||
HELP: email-log-report
|
||||
{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } }
|
||||
{ $description "E-mails a log report for the given log service. The " { $link insomniac-smtp-host } ", " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ;
|
||||
|
||||
HELP: schedule-insomniac
|
||||
{ $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } }
|
||||
{ $description "Starts a thread which e-mails log reports and rotates logs daily." } ;
|
||||
|
||||
ARTICLE: "logging.insomniac" "Automating log analysis and rotation"
|
||||
"The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary."
|
||||
$nl
|
||||
"Required configuration parameters:"
|
||||
{ $subsection insomniac-sender }
|
||||
{ $subsection insomniac-recipients }
|
||||
"Optional configuration parameters:"
|
||||
{ $subsection insomniac-smtp-host }
|
||||
{ $subsection insomniac-smtp-port }
|
||||
"E-mailing a one-off report:"
|
||||
{ $subsection email-log-report }
|
||||
"E-mailing reports and rotating logs on a daily basis:"
|
||||
{ $subsection schedule-insomniac } ;
|
||||
|
||||
ABOUT: "logging.insomniac"
|
||||
|
|
@ -1,19 +1,17 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: logging.analysis logging.server logging smtp io.sockets
|
||||
kernel io.files io.streams.string namespaces raptor.cron ;
|
||||
kernel io.files io.streams.string namespaces raptor.cron assocs ;
|
||||
IN: logging.insomniac
|
||||
|
||||
SYMBOL: insomniac-config
|
||||
|
||||
SYMBOL: insomniac-smtp-host
|
||||
SYMBOL: insomniac-smtp-port
|
||||
SYMBOL: insomniac-sender
|
||||
SYMBOL: insomniac-recipients
|
||||
|
||||
: ?log-analysis ( service word-names -- string/f )
|
||||
: ?analyze-log ( service word-names -- string/f )
|
||||
>r log-path 1 log# dup exists? [
|
||||
file-lines r> [ log-analysis ] string-out
|
||||
file-lines r> [ analyze-log ] string-out
|
||||
] [
|
||||
r> 2drop f
|
||||
] if ;
|
||||
|
|
@ -31,7 +29,7 @@ SYMBOL: insomniac-recipients
|
|||
: (email-log-report) ( service word-names -- )
|
||||
[
|
||||
over >r
|
||||
?log-analysis dup [
|
||||
?analyze-log dup [
|
||||
r> email-subject
|
||||
insomniac-recipients get
|
||||
insomniac-sender get
|
||||
|
|
@ -39,11 +37,12 @@ SYMBOL: insomniac-recipients
|
|||
] [ r> 2drop ] if
|
||||
] with-insomniac-smtp ;
|
||||
|
||||
\ (email-log-report) NOTICE add-error-logging
|
||||
|
||||
: email-log-report ( service word-names -- )
|
||||
(email-log-report) ;
|
||||
"logging.insomniac" [ (email-log-report) ] with-logging ;
|
||||
|
||||
\ email-log-report NOTICE add-error-logging
|
||||
|
||||
: schedule-insomniac ( service word-names -- )
|
||||
{ 25 } { 6 } f f f <when> -rot
|
||||
[ email-log-report ] 2curry schedule ;
|
||||
: schedule-insomniac ( alist -- )
|
||||
{ 25 } { 6 } f f f <when> -rot [
|
||||
[ email-log-report ] assoc-each rotate-logs
|
||||
] 2curry schedule ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
enterprise
|
||||
|
|
@ -0,0 +1,130 @@
|
|||
IN: logging
|
||||
USING: help.markup help.syntax assocs math calendar
|
||||
logging.server strings words quotations ;
|
||||
|
||||
HELP: DEBUG
|
||||
{ $description "Log level for debug messages." } ;
|
||||
|
||||
HELP: NOTICE
|
||||
{ $description "Log level for ordinary messages." } ;
|
||||
|
||||
HELP: ERROR
|
||||
{ $description "Log level for error messages." } ;
|
||||
|
||||
HELP: CRITICAL
|
||||
{ $description "Log level for critical errors which require immediate attention." } ;
|
||||
|
||||
ARTICLE: "logging.levels" "Log levels"
|
||||
"Several log levels are supported, from lowest to highest:"
|
||||
{ $subsection DEBUG }
|
||||
{ $subsection NOTICE }
|
||||
{ $subsection ERROR }
|
||||
{ $subsection CRITICAL } ;
|
||||
|
||||
ARTICLE: "logging.files" "Log files"
|
||||
"Each application that wishes to use logging must choose a log service name; the following combinator should wrap the top level of the application:"
|
||||
{ $subsection with-logging }
|
||||
"Log messages are written to " { $snippet "log-root/service/1.log" } ", where"
|
||||
{ $list
|
||||
{ { $snippet "log-root" } " is the Factor source directory by default, but can be overriden with the " { $link log-root } " variable" }
|
||||
{ { $snippet "service" } " is the service name" }
|
||||
}
|
||||
"You can get the log path for a service:"
|
||||
{ $subsection log-path }
|
||||
{ $subsection log# }
|
||||
"New log entries are always sent to " { $snippet "1.log" } " but " { $link "logging.rotation" } " moves " { $snippet "1.log" } " to " { $snippet "2.log" } ", " { $snippet "2.log" } " to " { $snippet "3.log" } ", and so on." ;
|
||||
|
||||
HELP: log-message
|
||||
{ $values { "msg" string } { "word" word } { "level" "a log level" } }
|
||||
{ $description "Sends a message to the current log. Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ;
|
||||
|
||||
HELP: add-logging
|
||||
{ $values { "word" word } }
|
||||
{ $description "Causes the word to log a message every time it is called." } ;
|
||||
|
||||
HELP: add-input-logging
|
||||
{ $values { "word" word } }
|
||||
{ $description "Causes the word to log its input values every time it is called. The word must have a stack effect declaration." } ;
|
||||
|
||||
HELP: add-output-logging
|
||||
{ $values { "word" word } }
|
||||
{ $description "Causes the word to log its output values every time it is called. The word must have a stack effect declaration." } ;
|
||||
|
||||
HELP: add-error-logging
|
||||
{ $values { "word" word } }
|
||||
{ $description "Causes the word to log its input values and any errors it throws."
|
||||
$nl
|
||||
"If the word is not executed in a dynamic scope established by " { $link with-logging } ", its behavior is unchanged, and any errors it throws are passed to the caller."
|
||||
$nl
|
||||
"If called from a logging context, its input values are logged, and if it throws an error, the error is logged and the word returns normally. Any inputs are popped from the stack and " { $link f } " is pushed in place of each output." } ;
|
||||
|
||||
HELP: log-error
|
||||
{ $values { "error" "an error" } { "word" word } }
|
||||
{ $description "Logs an error." } ;
|
||||
|
||||
HELP: log-critical
|
||||
{ $values { "critical" "an critical" } { "word" word } }
|
||||
{ $description "Logs a critical error." } ;
|
||||
|
||||
HELP: LOG:
|
||||
{ $syntax "LOG: name level" }
|
||||
{ $values { "name" "a new word name" } { "level" "a log level" } }
|
||||
{ $description "Creates a word with stack effect " { $snippet "( object -- )" } " which logs its input and does nothing else." } ;
|
||||
|
||||
ARTICLE: "logging.messages" "Logging messages"
|
||||
"Logging messages explicitly:"
|
||||
{ $subsection log-message }
|
||||
{ $subsection log-error }
|
||||
{ $subsection log-critical }
|
||||
"A utility for defining words which just log and do nothing else:"
|
||||
{ $subsection POSTPONE: LOG: }
|
||||
"Annotating words to log; this uses the " { $link "tools.annotations" } " feature:"
|
||||
{ $subsection add-input-logging }
|
||||
{ $subsection add-output-logging }
|
||||
{ $subsection add-error-logging } ;
|
||||
|
||||
HELP: rotate-logs
|
||||
{ $description "Rotates all logs. The highest numbered log file in each log directory is deleted, and each file is renamed so that its number increments by one. Subsequent logging calls will create a new #1 log file. This keeps log files from getting too large and makes them easier to search." } ;
|
||||
|
||||
HELP: close-logs
|
||||
{ $description "Closes all open log streams. Subsequent logging will re-open the streams. This should be used before moving or deleting log files." } ;
|
||||
|
||||
HELP: with-logging
|
||||
{ $values { "service" "a log service name" } { "quot" quotation } }
|
||||
{ $description "Calls the quotation a new dynamic scope where all logging calls are sent to the log file for " { $snippet "service" } "." } ;
|
||||
|
||||
ARTICLE: "logging.rotation" "Log rotation"
|
||||
"Log files should be rotated periodically to prevent unbounded growth."
|
||||
{ $subsection rotate-logs }
|
||||
{ $subsection close-logs }
|
||||
"The " { $vocab-link "logging.insomniac" } " vocabulary automates log rotation." ;
|
||||
|
||||
ARTICLE: "logging.server" "Log implementation"
|
||||
"The " { $vocab-link "logging.server" } " vocabulary implements a concurrent log server using " { $vocab-link "concurrency" } ". User code never interacts with the server directly, instead ot uses the words in the " { $link "logging" } " vocabulary. The server is used to synchronize access to log files and ensure that log rotation can proceed in an orderly fashion."
|
||||
$nl
|
||||
"The " { $link log-message } " word sends a message to the server which results in the server executing an internal word:"
|
||||
{ $subsection (log-message) }
|
||||
"The " { $link rotate-logs } " word sends a message to the server which results in the server executing an internal word:"
|
||||
{ $subsection (rotate-logs) }
|
||||
"The " { $link close-logs } " word sends a message to the server which results in the server executing an internal word:"
|
||||
{ $subsection (close-logs) } ;
|
||||
|
||||
ARTICLE: "logging" "Logging framework"
|
||||
"The " { $vocab-link "logging" } " vocabulary implements a comprehensive logging framework suitable for server-side production applications."
|
||||
{ $subsection "logging.files" }
|
||||
{ $subsection "logging.levels" }
|
||||
{ $subsection "logging.messages" }
|
||||
{ $subsection "logging.rotation" }
|
||||
{ $subsection "logging.parser" }
|
||||
{ $subsection "logging.analysis" }
|
||||
{ $subsection "logging.insomniac" }
|
||||
{ $subsection "logging.server" } ;
|
||||
|
||||
ABOUT: "logging"
|
||||
|
||||
! A workaround for circular dependency prohibition
|
||||
USING: threads vocabs.loader ;
|
||||
[
|
||||
yield
|
||||
"logging.insomniac" require
|
||||
] in-thread
|
||||
|
|
@ -39,8 +39,8 @@ SYMBOL: log-service
|
|||
: rotate-logs ( -- )
|
||||
{ } "rotate-logs" send-to-log-server ;
|
||||
|
||||
: close-log-files ( -- )
|
||||
{ } "close-log-files" send-to-log-server ;
|
||||
: close-logs ( -- )
|
||||
{ } "close-logs" send-to-log-server ;
|
||||
|
||||
: with-logging ( service quot -- )
|
||||
log-service swap with-variable ; inline
|
||||
|
|
@ -56,7 +56,7 @@ SYMBOL: log-service
|
|||
[ dup first string? ]
|
||||
} && nip ;
|
||||
|
||||
: inputs>message ( obj -- inputs>message )
|
||||
: stack>message ( obj -- inputs>message )
|
||||
dup one-string? [ first ] [
|
||||
H{
|
||||
{ string-limit f }
|
||||
|
|
@ -77,9 +77,9 @@ PRIVATE>
|
|||
: add-logging ( word level -- )
|
||||
[ call-logging-quot ] (define-logging) ;
|
||||
|
||||
: log-inputs ( n word level -- )
|
||||
: log-stack ( n word level -- )
|
||||
log-service get [
|
||||
>r >r [ ndup ] keep narray inputs>message
|
||||
>r >r [ ndup ] keep narray stack>message
|
||||
r> r> log-message
|
||||
] [
|
||||
3drop
|
||||
|
|
@ -88,11 +88,19 @@ PRIVATE>
|
|||
: input# stack-effect effect-in length ;
|
||||
|
||||
: input-logging-quot ( quot word level -- quot' )
|
||||
over input# -rot [ log-inputs ] 3curry swap compose ;
|
||||
over input# -rot [ log-stack ] 3curry swap compose ;
|
||||
|
||||
: add-input-logging ( word level -- )
|
||||
[ input-logging-quot ] (define-logging) ;
|
||||
|
||||
: output# stack-effect effect-out length ;
|
||||
|
||||
: output-logging-quot ( quot word level -- quot' )
|
||||
over output# -rot [ log-stack ] 3curry compose ;
|
||||
|
||||
: add-output-logging ( word level -- )
|
||||
[ output-logging-quot ] (define-logging) ;
|
||||
|
||||
: (log-error) ( object word level -- )
|
||||
log-service get [
|
||||
>r >r [ print-error ] string-out r> r> log-message
|
||||
|
|
@ -100,9 +108,9 @@ PRIVATE>
|
|||
2drop rethrow
|
||||
] if ;
|
||||
|
||||
: log-error ( object word -- ) ERROR (log-error) ;
|
||||
: log-error ( error word -- ) ERROR (log-error) ;
|
||||
|
||||
: log-critical ( object word -- ) CRITICAL (log-error) ;
|
||||
: log-critical ( error word -- ) CRITICAL (log-error) ;
|
||||
|
||||
: error-logging-quot ( quot word -- quot' )
|
||||
dup stack-effect effect-in length
|
||||
|
|
@ -118,5 +126,5 @@ PRIVATE>
|
|||
CREATE
|
||||
dup reset-generic
|
||||
dup scan-word
|
||||
[ >r >r 1array inputs>message r> r> log-message ] 2curry
|
||||
[ >r >r 1array stack>message r> r> log-message ] 2curry
|
||||
define ; parsing
|
||||
|
|
|
|||
|
|
@ -0,0 +1,21 @@
|
|||
IN: logging.parser
|
||||
USING: help.markup help.syntax assocs logging math calendar ;
|
||||
|
||||
HELP: parse-log
|
||||
{ $values { "lines" "a sequence of strings" } { "entries" "a sequence of log entries" } }
|
||||
{ $description "Parses a sequence of log entries. Malformed entries are printed out and ignore. The result is a sequence of arrays of the shape " { $snippet "{ timestamp level word-name message }" } ", where"
|
||||
{ $list
|
||||
{ { $snippet "timestamp" } " is a " { $link timestamp } }
|
||||
{ { $snippet "level" } " is a log level; see " { $link "logger.levels" } }
|
||||
{ { $snippet "word-name" } " is a string" }
|
||||
{ { $snippet "message" } " is a string" }
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "logging.parser" "Log file parser"
|
||||
"The " { $vocab-link "logging.parser" } " vocabulary parses log files output by the " { $vocab-link "logging" } " vocabulary. It is used by " { $link "logging.analysis" } " and " { $link "logging.insomniac" } " to analyze logs."
|
||||
$nl
|
||||
"There is only one primary entry point:"
|
||||
{ $subsection parse-log } ;
|
||||
|
||||
ABOUT: "logging.parser"
|
||||
|
|
@ -2,13 +2,17 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser-combinators memoize kernel sequences
|
||||
logging arrays words strings vectors io io.files
|
||||
namespaces combinators combinators.lib logging.server ;
|
||||
namespaces combinators combinators.lib logging.server
|
||||
calendar ;
|
||||
IN: logging.parser
|
||||
|
||||
: string-of satisfy <!*> [ >string ] <@ ;
|
||||
|
||||
SYMBOL: multiline
|
||||
|
||||
: 'date'
|
||||
[ CHAR: ] eq? not ] string-of
|
||||
multiline-header token [ drop multiline ] <@
|
||||
[ CHAR: ] eq? not ] string-of [ rfc3339>timestamp ] <@ <|>
|
||||
"[" "]" surrounded-by ;
|
||||
|
||||
: 'log-level'
|
||||
|
|
@ -41,7 +45,7 @@ MEMO: 'log-line' ( -- parser )
|
|||
first malformed eq? ;
|
||||
|
||||
: multiline? ( line -- ? )
|
||||
first first CHAR: - = ;
|
||||
first multiline eq? ;
|
||||
|
||||
: malformed-line
|
||||
"Warning: malformed log line:" print
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
enterprise
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
IN: logging.server
|
||||
USING: help.syntax ;
|
||||
|
||||
ABOUT: "logging.server"
|
||||
|
|
@ -25,9 +25,11 @@ SYMBOL: log-files
|
|||
: log-stream ( service -- stream )
|
||||
log-files get [ open-log-stream ] cache ;
|
||||
|
||||
: multiline-header 20 CHAR: - <string> ; foldable
|
||||
|
||||
: (write-message) ( msg word-name level multi? -- )
|
||||
[
|
||||
"[" write 20 CHAR: - <string> write "] " write
|
||||
"[" write multiline-header write "] " write
|
||||
] [
|
||||
"[" write now (timestamp>rfc3339) "] " write
|
||||
] if
|
||||
|
|
@ -50,11 +52,11 @@ SYMBOL: log-files
|
|||
: try-dispose ( stream -- )
|
||||
[ dispose ] curry [ error. ] recover ;
|
||||
|
||||
: close-log-file ( service -- )
|
||||
: close-log ( service -- )
|
||||
log-files get delete-at*
|
||||
[ try-dispose ] [ drop ] if ;
|
||||
|
||||
: (close-log-files) ( -- )
|
||||
: (close-logs) ( -- )
|
||||
log-files get
|
||||
dup values [ try-dispose ] each
|
||||
clear-assoc ;
|
||||
|
|
@ -73,13 +75,13 @@ SYMBOL: log-files
|
|||
[ 1- log# ] 2keep log# ?rename-file ;
|
||||
|
||||
: rotate-log ( service -- )
|
||||
dup close-log-file
|
||||
dup close-log
|
||||
log-path
|
||||
dup delete-oldest
|
||||
keep-logs 1 [a,b] [ advance-log ] with each ;
|
||||
|
||||
: (rotate-logs) ( -- )
|
||||
(close-log-files)
|
||||
(close-logs)
|
||||
log-root directory [ drop rotate-log ] assoc-each ;
|
||||
|
||||
: log-server-loop
|
||||
|
|
@ -87,9 +89,9 @@ SYMBOL: log-files
|
|||
receive unclip {
|
||||
{ "log-message" [ (log-message) ] }
|
||||
{ "rotate-logs" [ drop (rotate-logs) ] }
|
||||
{ "close-log-files" [ drop (close-log-files) ] }
|
||||
{ "close-logs" [ drop (close-logs) ] }
|
||||
} case
|
||||
] [ error. (close-log-files) ] recover
|
||||
] [ error. (close-logs) ] recover
|
||||
log-server-loop ;
|
||||
|
||||
: log-server ( -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
enterprise
|
||||
|
|
@ -1 +1 @@
|
|||
AOP Logging framework with support for log rotation and machine-readable logs
|
||||
Logging framework with support for log rotation and machine-readable logs
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
enterprise
|
||||
|
|
@ -84,3 +84,15 @@ METHOD: hook-test { hashtable number } assoc-size ;
|
|||
[ fixnum ] [ 3 hook-test ] unit-test
|
||||
5.0 some-var set
|
||||
[ 0 ] [ H{ } hook-test ] unit-test
|
||||
|
||||
MIXIN: busted
|
||||
|
||||
TUPLE: busted-1 ;
|
||||
TUPLE: busted-2 ; INSTANCE: busted-2 busted
|
||||
TUPLE: busted-3 ;
|
||||
|
||||
GENERIC: busted-sort
|
||||
|
||||
METHOD: busted-sort { busted-1 busted-2 } ;
|
||||
METHOD: busted-sort { busted-2 busted-3 } ;
|
||||
METHOD: busted-sort { busted busted } ;
|
||||
|
|
|
|||
|
|
@ -3,12 +3,12 @@
|
|||
USING: kernel math sequences vectors classes combinators
|
||||
arrays words assocs parser namespaces definitions
|
||||
prettyprint prettyprint.backend quotations arrays.lib
|
||||
debugger io compiler.units ;
|
||||
debugger io compiler.units kernel.private effects ;
|
||||
IN: multi-methods
|
||||
|
||||
TUPLE: method loc def ;
|
||||
GENERIC: generic-prologue ( combination -- quot )
|
||||
|
||||
: <method> { set-method-def } \ method construct ;
|
||||
GENERIC: method-prologue ( combination -- quot )
|
||||
|
||||
: maximal-element ( seq quot -- n elt )
|
||||
dupd [
|
||||
|
|
@ -25,6 +25,7 @@ TUPLE: method loc def ;
|
|||
[
|
||||
{
|
||||
{ [ 2dup eq? ] [ 0 ] }
|
||||
{ [ 2dup [ class< ] 2keep swap class< and ] [ 0 ] }
|
||||
{ [ 2dup class< ] [ -1 ] }
|
||||
{ [ 2dup swap class< ] [ 1 ] }
|
||||
{ [ t ] [ 0 ] }
|
||||
|
|
@ -54,8 +55,37 @@ TUPLE: method loc def ;
|
|||
: methods ( word -- alist )
|
||||
"multi-methods" word-prop >alist ;
|
||||
|
||||
: method-defs ( methods -- methods' )
|
||||
[ method-def ] assoc-map ;
|
||||
: make-method-def ( quot classes generic -- quot )
|
||||
[
|
||||
swap [ declare ] curry %
|
||||
"multi-combination" word-prop method-prologue %
|
||||
%
|
||||
] [ ] make ;
|
||||
|
||||
TUPLE: method word def classes generic loc ;
|
||||
|
||||
PREDICATE: word method-body "multi-method" word-prop >boolean ;
|
||||
|
||||
M: method-body stack-effect
|
||||
"multi-method" word-prop method-generic stack-effect ;
|
||||
|
||||
: method-word-name ( classes generic -- string )
|
||||
[
|
||||
word-name %
|
||||
"-(" % [ "," % ] [ word-name % ] interleave ")" %
|
||||
] "" make ;
|
||||
|
||||
: <method-word> ( quot classes generic -- word )
|
||||
#! We xref here because the "multi-method" word-prop isn't
|
||||
#! set yet so crossref? yields f.
|
||||
[ make-method-def ] 2keep
|
||||
method-word-name f <word>
|
||||
dup rot define
|
||||
dup xref ;
|
||||
|
||||
: <method> ( quot classes generic -- method )
|
||||
[ <method-word> ] 3keep f \ method construct-boa
|
||||
dup method-word over "multi-method" set-word-prop ;
|
||||
|
||||
TUPLE: no-method arguments generic ;
|
||||
|
||||
|
|
@ -68,8 +98,11 @@ TUPLE: no-method arguments generic ;
|
|||
] if ;
|
||||
|
||||
: multi-dispatch-quot ( methods generic -- quot )
|
||||
>r
|
||||
[ [ >r multi-predicate r> ] assoc-map ] keep argument-count
|
||||
>r [
|
||||
[
|
||||
>r multi-predicate r> method-word 1quotation
|
||||
] assoc-map
|
||||
] keep argument-count
|
||||
r> [ no-method ] 2curry
|
||||
swap reverse alist>quot ;
|
||||
|
||||
|
|
@ -98,36 +131,36 @@ M: no-method error.
|
|||
methods congruify-methods sorted-methods keys
|
||||
[ niceify-method ] map stack. ;
|
||||
|
||||
GENERIC: perform-combination ( word combination -- quot )
|
||||
|
||||
TUPLE: standard-combination ;
|
||||
|
||||
: standard-combination ( methods generic -- quot )
|
||||
>r congruify-methods sorted-methods r> multi-dispatch-quot ;
|
||||
M: standard-combination method-prologue drop [ ] ;
|
||||
|
||||
M: standard-combination perform-combination
|
||||
drop [ methods method-defs ] keep standard-combination ;
|
||||
M: standard-combination generic-prologue drop [ ] ;
|
||||
|
||||
: make-generic ( generic -- quot )
|
||||
dup "multi-combination" word-prop generic-prologue swap
|
||||
[ methods congruify-methods sorted-methods ] keep
|
||||
multi-dispatch-quot append ;
|
||||
|
||||
TUPLE: hook-combination var ;
|
||||
|
||||
M: hook-combination perform-combination
|
||||
hook-combination-var [ get ] curry swap methods
|
||||
[ method-defs [ [ drop ] swap append ] assoc-map ] keep
|
||||
standard-combination append ;
|
||||
M: hook-combination method-prologue
|
||||
drop [ drop ] ;
|
||||
|
||||
: make-generic ( word -- )
|
||||
dup dup "multi-combination" word-prop perform-combination
|
||||
define ;
|
||||
M: hook-combination generic-prologue
|
||||
hook-combination-var [ get ] curry ;
|
||||
|
||||
: init-methods ( word -- )
|
||||
dup "multi-methods" word-prop
|
||||
H{ } assoc-like
|
||||
"multi-methods" set-word-prop ;
|
||||
: update-generic ( word -- )
|
||||
dup make-generic define ;
|
||||
|
||||
: define-generic ( word combination -- )
|
||||
dupd "multi-combination" set-word-prop
|
||||
dup init-methods
|
||||
make-generic ;
|
||||
over "multi-combination" word-prop over = [
|
||||
2drop
|
||||
] [
|
||||
dupd "multi-combination" set-word-prop
|
||||
dup H{ } clone "multi-methods" set-word-prop
|
||||
update-generic
|
||||
] if ;
|
||||
|
||||
: define-standard-generic ( word -- )
|
||||
T{ standard-combination } define-generic ;
|
||||
|
|
@ -146,29 +179,31 @@ M: hook-combination perform-combination
|
|||
|
||||
: with-methods ( word quot -- )
|
||||
over >r >r "multi-methods" word-prop
|
||||
r> call r> make-generic ; inline
|
||||
r> call r> update-generic ; inline
|
||||
|
||||
: add-method ( method classes word -- )
|
||||
: define-method ( quot classes generic -- )
|
||||
>r [ bootstrap-word ] map r>
|
||||
[ <method> ] 2keep
|
||||
[ set-at ] with-methods ;
|
||||
|
||||
: forget-method ( classes word -- )
|
||||
: forget-method ( classes generic -- )
|
||||
[ delete-at ] with-methods ;
|
||||
|
||||
: parse-method ( -- method classes word method-spec )
|
||||
parse-definition 2 cut
|
||||
over >r
|
||||
>r first2 swap r> <method> -rot
|
||||
r> first2 swap add* >array ;
|
||||
: method>spec ( method -- spec )
|
||||
dup method-classes swap method-generic add* ;
|
||||
|
||||
: parse-method ( -- quot classes generic )
|
||||
parse-definition dup 2 tail over second rot first ;
|
||||
|
||||
: METHOD:
|
||||
location
|
||||
>r parse-method >r add-method r> r>
|
||||
>r parse-method [ define-method ] 2keep add* r>
|
||||
remember-definition ; parsing
|
||||
|
||||
! For compatibility
|
||||
: M:
|
||||
scan-word 1array scan-word parse-definition <method>
|
||||
-rot add-method ; parsing
|
||||
scan-word 1array scan-word parse-definition
|
||||
-rot define-method ; parsing
|
||||
|
||||
! Definition protocol. We qualify core generics here
|
||||
USE: qualified
|
||||
|
|
@ -202,7 +237,7 @@ PREDICATE: array method-spec
|
|||
unclip generic? >r [ class? ] all? r> and ;
|
||||
|
||||
syntax:M: method-spec where
|
||||
dup unclip method method-loc [ ] [ second where ] ?if ;
|
||||
dup unclip method [ method-loc ] [ second where ] ?if ;
|
||||
|
||||
syntax:M: method-spec set-where
|
||||
unclip method set-method-loc ;
|
||||
|
|
@ -211,11 +246,11 @@ syntax:M: method-spec definer
|
|||
drop \ METHOD: \ ; ;
|
||||
|
||||
syntax:M: method-spec definition
|
||||
unclip method method-def ;
|
||||
unclip method dup [ method-def ] when ;
|
||||
|
||||
syntax:M: method-spec synopsis*
|
||||
dup definer.
|
||||
unclip pprint* pprint* ;
|
||||
|
||||
syntax:M: method-spec forget*
|
||||
unclip [ delete-at ] with-methods ;
|
||||
unclip forget-method ;
|
||||
|
|
|
|||
|
|
@ -1,2 +1,3 @@
|
|||
enterprise
|
||||
network
|
||||
bindings
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
enterprise
|
||||
network
|
||||
|
|
|
|||
|
|
@ -22,7 +22,10 @@ IN: tools.deploy.backend
|
|||
+stdout+ +stderr+ set
|
||||
] H{ } make-assoc <process-stream>
|
||||
dup duplex-stream-out dispose
|
||||
copy-lines ;
|
||||
dup copy-lines
|
||||
process-stream-process wait-for-process zero? [
|
||||
"Deployment failed" throw
|
||||
] unless ;
|
||||
|
||||
: make-boot-image ( -- )
|
||||
#! If stage1 image doesn't exist, create one.
|
||||
|
|
|
|||
|
|
@ -8,10 +8,10 @@ QUALIFIED: unix
|
|||
IN: tools.deploy.macosx
|
||||
|
||||
: touch ( path -- )
|
||||
{ "touch" } swap add run-process drop ;
|
||||
{ "touch" } swap add try-process ;
|
||||
|
||||
: rm ( path -- )
|
||||
{ "rm" "-rf" } swap add run-process drop ;
|
||||
{ "rm" "-rf" } swap add try-process ;
|
||||
|
||||
: bundle-dir ( -- dir )
|
||||
vm parent-directory parent-directory ;
|
||||
|
|
|
|||
|
|
@ -61,9 +61,14 @@ M: expected-error summary
|
|||
dup vocab-source-loaded? [
|
||||
vocab-tests-path dup [
|
||||
dup ?resource-path exists? [
|
||||
[ "temporary" forget-vocab ] with-compilation-unit
|
||||
[
|
||||
"temporary" forget-vocab
|
||||
] with-compilation-unit
|
||||
dup run-file
|
||||
[ dup forget-source ] with-compilation-unit
|
||||
[
|
||||
dup forget-source
|
||||
"temporary" forget-vocab
|
||||
] with-compilation-unit
|
||||
] when
|
||||
] when
|
||||
] when drop ;
|
||||
|
|
@ -81,7 +86,7 @@ M: expected-error summary
|
|||
"Traceback" swap third write-object ;
|
||||
|
||||
: test-failures. ( assoc -- )
|
||||
dup [
|
||||
[
|
||||
nl
|
||||
dup empty? [
|
||||
drop
|
||||
|
|
@ -90,15 +95,15 @@ M: expected-error summary
|
|||
"==== FAILING TESTS:" print
|
||||
[
|
||||
swap vocab-heading.
|
||||
[ nl failure. nl ] each
|
||||
[ failure. nl ] each
|
||||
] assoc-each
|
||||
] if
|
||||
] [
|
||||
drop "==== NOTHING TO TEST" print
|
||||
] if ;
|
||||
"==== NOTHING TO TEST" print
|
||||
] if* ;
|
||||
|
||||
: run-tests ( prefix -- failures )
|
||||
child-vocabs dup empty? [ f ] [
|
||||
child-vocabs dup empty? [ drop f ] [
|
||||
[ dup run-test ] { } map>assoc
|
||||
[ second empty? not ] subset
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
enterprise
|
||||
web
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
enterprise
|
||||
web
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -154,6 +174,10 @@
|
|||
(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)
|
||||
(beginning-of-line)
|
||||
|
|
|
|||
|
|
@ -1,28 +0,0 @@
|
|||
USING: tools.deploy sequences io.files io.launcher io
|
||||
kernel concurrency prettyprint ;
|
||||
|
||||
"." resource-path cd
|
||||
|
||||
"deploy-log" make-directory
|
||||
|
||||
{
|
||||
"automata.ui"
|
||||
"boids.ui"
|
||||
"bunny"
|
||||
"color-picker"
|
||||
"gesture-logger"
|
||||
"golden-section"
|
||||
"hello-world"
|
||||
"hello-ui"
|
||||
"lsys.ui"
|
||||
"maze"
|
||||
"nehe"
|
||||
"tetris"
|
||||
"catalyst-talk"
|
||||
} [
|
||||
dup
|
||||
"deploy-log/" over append <file-writer>
|
||||
[ deploy ] with-stream
|
||||
dup file-length 1024 /f
|
||||
2array
|
||||
] parallel-map .
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
USING: tools.deploy.app sequences io.files io.launcher io
|
||||
kernel concurrency ;
|
||||
|
||||
"." resource-path cd
|
||||
|
||||
"deploy-log" make-directory
|
||||
|
||||
{
|
||||
"automata.ui"
|
||||
"boids.ui"
|
||||
"bunny"
|
||||
"color-picker"
|
||||
"gesture-logger"
|
||||
"golden-section"
|
||||
"hello-ui"
|
||||
"lsys.ui"
|
||||
"maze"
|
||||
"nehe"
|
||||
"tetris"
|
||||
"catalyst-talk"
|
||||
} [
|
||||
"deploy-log/" over append <file-writer>
|
||||
[ deploy.app ] with-stream
|
||||
] parallel-each
|
||||
|
|
@ -1,43 +0,0 @@
|
|||
CPU=$1
|
||||
|
||||
if [ "$CPU" = "x86.32" ]; then
|
||||
TARGET="macosx-x86"
|
||||
elif [ "$CPU" = "ppc" ]; then
|
||||
TARGET="macosx-ppc"
|
||||
CPU = "macosx-ppc"
|
||||
else
|
||||
echo "Specify a CPU"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
EXE=factor
|
||||
|
||||
bash misc/integration/test.sh \
|
||||
$EXE \
|
||||
$CPU \
|
||||
$TARGET \
|
||||
no \
|
||||
no \
|
||||
no \
|
||||
"X11=1" \
|
||||
"-ui-backend=x11" \
|
||||
"-x11" || exit 1
|
||||
|
||||
echo "Testing deployment"
|
||||
$EXE "misc/integration/x11-deploy.factor" -run=none </dev/null
|
||||
|
||||
EXE=Factor.app/Contents/MacOS/factor
|
||||
|
||||
bash misc/integration/test.sh \
|
||||
$EXE \
|
||||
$CPU \
|
||||
$TARGET \
|
||||
yes \
|
||||
yes \
|
||||
yes \
|
||||
"" \
|
||||
"" \
|
||||
""
|
||||
|
||||
echo "Testing deployment"
|
||||
$EXE "misc/integration/macosx-deploy.factor" -run=none </dev/null
|
||||
|
|
@ -1,93 +0,0 @@
|
|||
EXE=$1
|
||||
CPU=$2
|
||||
TARGET=$3
|
||||
LOAD_P=$4
|
||||
TEST_P=$5
|
||||
BENCHMARK_P=$6
|
||||
MAKE_FLAGS=$7
|
||||
BOOT_FLAGS=$8
|
||||
VARIANT=$9
|
||||
|
||||
PREFIX=misc/integration/results-$CPU$VARIANT
|
||||
|
||||
mkdir -p $PREFIX
|
||||
|
||||
VM_LOG=$PREFIX/vm.log
|
||||
BOOT_LOG=$PREFIX/boot.log
|
||||
LOAD_LOG=$PREFIX/load.log
|
||||
TEST_LOG=$PREFIX/test.log
|
||||
BENCHMARK_LOG=$PREFIX/benchmark.log
|
||||
|
||||
echo "Output files:"
|
||||
echo "VM compilation: $VM_LOG"
|
||||
echo "Bootstrap: $BOOT_LOG"
|
||||
echo "Load everything: $LOAD_LOG"
|
||||
echo "Unit tests: $TEST_LOG"
|
||||
echo "Benchmarks: $BENCHMARK_LOG"
|
||||
|
||||
IMAGE=factor.image
|
||||
|
||||
echo
|
||||
echo
|
||||
echo
|
||||
|
||||
echo "Compiling VM"
|
||||
${MAKE-make} clean $TARGET $MAKE_FLAGS >$VM_LOG </dev/null
|
||||
|
||||
if [ "$?" -ne 0 ]; then
|
||||
echo "VM compile failed"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
echo "Bootstrap"
|
||||
rm -f $IMAGE
|
||||
|
||||
$EXE -i=boot.$CPU.image \
|
||||
-no-user-init \
|
||||
$BOOT_FLAGS \
|
||||
-output-image=$IMAGE >$BOOT_LOG </dev/null
|
||||
|
||||
if [ ! -e "factor.image" ]; then
|
||||
echo "Bootstrap failed"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
# Load all modules; run tests
|
||||
if [ "$LOAD_P" = "yes" ]; then
|
||||
echo "Testing loading of all modules"
|
||||
|
||||
echo "USE: tools.browser load-everything USE: memory save USE: system 123 exit" \
|
||||
>/tmp/factor-$$
|
||||
|
||||
$EXE -i=$IMAGE \
|
||||
/tmp/factor-$$ \
|
||||
-run=none \
|
||||
>$LOAD_LOG </dev/null
|
||||
|
||||
if [ "$?" -ne 123 ]; then
|
||||
echo "Load-everything failed"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
# Check for parser notes
|
||||
grep "automatically using" $LOAD_LOG
|
||||
|
||||
if [ "$?" -eq 0 ]; then
|
||||
echo "Missing USE: declarations"
|
||||
# exit 1
|
||||
fi
|
||||
fi
|
||||
|
||||
# Run unit tests
|
||||
if [ "$TEST_P" = "yes" ]; then
|
||||
echo "Running all unit tests"
|
||||
|
||||
$EXE -i=$IMAGE "-e=test-all" -run=none >$TEST_LOG </dev/null
|
||||
fi
|
||||
|
||||
# Run benchmarks
|
||||
if [ "$BENCHMARK_P" = "yes" ]; then
|
||||
echo "Running all benchmarks"
|
||||
|
||||
$EXE -i=$IMAGE "-run=benchmark" >$BENCHMARK_LOG </dev/null
|
||||
fi
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
bash misc/integration/test.sh \
|
||||
./factor \
|
||||
ppc \
|
||||
$1-arm \
|
||||
no \
|
||||
yes \
|
||||
yes \
|
||||
"" \
|
||||
"" \
|
||||
""
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
bash misc/integration/test.sh \
|
||||
./factor \
|
||||
ppc \
|
||||
$1-ppc \
|
||||
yes \
|
||||
yes \
|
||||
yes \
|
||||
"" \
|
||||
"" \
|
||||
""
|
||||
|
|
@ -1,21 +0,0 @@
|
|||
bash misc/integration/test.sh \
|
||||
./factor \
|
||||
x86.32 \
|
||||
$1-x86 \
|
||||
yes \
|
||||
yes \
|
||||
yes \
|
||||
"" \
|
||||
"" \
|
||||
"" || exit 1
|
||||
|
||||
bash misc/integration/test.sh \
|
||||
./factor \
|
||||
x86.32 \
|
||||
$1-x86 \
|
||||
yes \
|
||||
yes \
|
||||
yes \
|
||||
"" \
|
||||
"-no-sse2" \
|
||||
"-no-sse2"
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
bash misc/integration/test.sh \
|
||||
./factor \
|
||||
x86.64 \
|
||||
$1-amd64 \
|
||||
yes \
|
||||
yes \
|
||||
yes \
|
||||
"" \
|
||||
"" \
|
||||
""
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
USING: tools.deploy sequences io.files io kernel ;
|
||||
|
||||
"." resource-path cd
|
||||
|
||||
"mkdir deploy-log" run-process
|
||||
|
||||
"factory" "deploy-log/" over append
|
||||
<file-writer> [ deploy ] with-stream
|
||||
35
vm/debug.c
35
vm/debug.c
|
|
@ -38,6 +38,9 @@ void print_array(F_ARRAY* array, CELL nesting)
|
|||
CELL length = array_capacity(array);
|
||||
CELL i;
|
||||
|
||||
if(length > 10)
|
||||
length = 10;
|
||||
|
||||
for(i = 0; i < length; i++)
|
||||
{
|
||||
printf(" ");
|
||||
|
|
@ -201,7 +204,7 @@ void dump_objects(F_FIXNUM type)
|
|||
if(type == -1 || type_of(obj) == type)
|
||||
{
|
||||
printf("%lx ",obj);
|
||||
print_nested_obj(obj,3);
|
||||
print_nested_obj(obj,1);
|
||||
printf("\n");
|
||||
}
|
||||
}
|
||||
|
|
@ -210,6 +213,36 @@ void dump_objects(F_FIXNUM type)
|
|||
gc_off = false;
|
||||
}
|
||||
|
||||
CELL obj;
|
||||
CELL look_for;
|
||||
|
||||
void find_references_step(CELL *scan)
|
||||
{
|
||||
if(look_for == *scan)
|
||||
{
|
||||
printf("%lx ",obj);
|
||||
print_nested_obj(obj,1);
|
||||
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);
|
||||
}
|
||||
|
||||
/* end scan */
|
||||
gc_off = false;
|
||||
}
|
||||
|
||||
void factorbug(void)
|
||||
{
|
||||
reset_stdio();
|
||||
|
|
|
|||
Loading…
Reference in New Issue