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

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

release
U-C4\Administrator 2007-10-06 17:09:41 -05:00
parent cd3a354d91 b23e109447
commit 95ac4fe29b
102 changed files with 793 additions and 855 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -11,7 +11,7 @@ CFLAGS = -Wall
ifdef DEBUG
CFLAGS += -g
else
CFLAGS += -O3 $(SITE_CFLAGS)
CFLAGS += -O3 -fomit-frame-pointer $(SITE_CFLAGS)
endif
ifdef CONFIG

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

@ -3,7 +3,7 @@ parser kernel kernel.private classes classes.private
arrays hashtables vectors tuples sbufs inference.dataflow
hashtables.private sequences.private math tuples.private
growable namespaces.private alien.remote-control assocs
words generator command-line vocabs io prettyprint ;
words generator command-line vocabs io prettyprint libc ;
"bootstrap.math" vocab [
"cpu." cpu append require
@ -44,6 +44,8 @@ words generator command-line vocabs io prettyprint ;
new nth push pop peek hashcode* = get set
. lines
malloc free memcpy
} [ compile ] each
[ recompile ] parse-hook set-global

1
core/bootstrap/primitives.factor
View File

@ -270,6 +270,7 @@ H{ } clone update-map set
{ "innermost-frame-quot" "kernel.private" }
{ "innermost-frame-scan" "kernel.private" }
{ "set-innermost-frame-quot" "kernel.private" }
{ "call-clear" "kernel" }
}
dup length [ >r first2 r> make-primitive ] 2each

12
core/bootstrap/stage2.factor
View File

@ -29,6 +29,13 @@ IN: bootstrap.stage2
wince? [ "windows.ce" require ] when
winnt? [ "windows.nt" require ] when
"deploy-vocab" get [
"stage2: deployment mode" print
] [
"listener" require
"none" require
] if
[
! Compile everything if compiler is loaded
all-words [ changed-word ] each
@ -54,11 +61,8 @@ IN: bootstrap.stage2
f error-continuation set-global
"deploy-vocab" get [
"tools.deploy" run
"tools.deploy.shaker" run
] [
"listener" require
"none" require
[
boot
do-init-hooks

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

@ -153,7 +153,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
alien-invoke code-gc 3 ;
! [ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
FUNCTION: longlong ffi_test_21 long x long y ;

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

@ -102,24 +102,6 @@ HELP: callcc1
{ $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }
{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ;
HELP: set-walker-hook
{ $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } ", or " { $link f } } }
{ $description "Sets a quotation to be called when a continuation is resumed." }
{ $notes "The single-stepper uses this hook to support single-stepping through code which makes use of continuations." } ;
HELP: walker-hook
{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } ", or " { $link f } } }
{ $description "Outputs a quotation to be called when a continuation is resumed, or " { $link f } " if no hook is set. If a hook was set prior to this word being called, it will be reset to " { $link f } "."
$nl
"The following words do not perform their usual action and instead just call the walker hook if one is set:"
{ $list
{ { $link callcc0 } " will call the hook, passing it the continuation to resume." }
{ { $link callcc1 } " will call the hook, passing it a " { $snippet "{ obj continuation }" } " pair." }
{ { $link stop } " will call the hook, passing it " { $link f } "." }
}
"The walker hook must take appropriate action so that the callers of these words see the behavior that they expect." }
{ $notes "The single-stepper uses this hook to support single-stepping through code which makes use of continuations." } ;
HELP: (continue-with)
{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } }
{ $description "Resumes a continuation reified by " { $link callcc1 } " without invoking " { $link walker-hook } ". The object will be placed on the data stack when the continuation resumes." } ;
@ -214,3 +196,6 @@ $low-level-note ;
HELP: init-error-handler
{ $description "Called on startup to initialize the catch stack and set a pair of hooks which allow the Factor VM to signal errors to library code." } ;
HELP: break
{ $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ;

41
core/continuations/continuations.factor
View File

@ -20,9 +20,12 @@ SYMBOL: restarts
: (catch) ( quot -- newquot )
[ swap >c call c> drop ] curry ; inline
: dummy
#! Defeat an optimization.
f ;
: dummy ( -- obj )
#! Optimizing compiler assumes stack won't be messed with
#! in-transit. To ensure that a value is actually reified
#! on the stack, we put it in a non-inline word together
#! with a declaration.
f { object } declare ;
PRIVATE>
@ -70,12 +73,16 @@ C: <continuation> continuation
: callcc1 ( quot -- obj ) [ ] ifcc ; inline
: set-walker-hook ( quot -- ) 3 setenv ; inline
: walker-hook ( -- quot ) 3 getenv f set-walker-hook ; inline
<PRIVATE
: (continue) ( continuation -- )
>continuation<
set-catchstack
set-namestack
set-retainstack
>r set-datastack r>
set-callstack ;
: (continue-with) ( obj continuation -- )
swap 4 setenv
>continuation<
@ -87,6 +94,10 @@ C: <continuation> continuation
PRIVATE>
: set-walker-hook ( quot -- ) 3 setenv ; inline
: walker-hook ( -- quot ) 3 getenv f set-walker-hook ; inline
: continue-with ( obj continuation -- )
[
walker-hook [ >r 2array r> ] when* (continue-with)
@ -170,3 +181,19 @@ M: condition compute-restarts
"kernel-error" 6 setenv ;
PRIVATE>
! Debugging support
: with-walker-hook ( continuation -- )
[ swap set-walker-hook (continue) ] curry callcc1 ;
SYMBOL: break-hook
: break ( -- )
continuation callstack
over set-continuation-call
walker-hook [ (continue-with) ] [ break-hook get call ] if* ;
GENERIC: (step-into) ( obj -- )
M: wrapper (step-into) wrapped break ;
M: object (step-into) break ;

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

@ -9,17 +9,16 @@ IN: cpu.ppc.architecture
TUPLE: ppc-backend ;
! PowerPC register assignments
! r3-r10, r17-r31: integer vregs
! r3-r10, r16-r31: integer vregs
! f0-f13: float vregs
! r11, r12: scratch
! r14: data stack
! r15: retain stack
! For stack frame layout, see vm/os-{macosx,linux}-ppc.h.
! For stack frame layout, see vm/cpu-ppc.h.
: ds-reg 14 ;
: rs-reg 15 ;
: stack-chain-reg 16 ;
: reserved-area-size
os {
@ -37,13 +36,17 @@ TUPLE: ppc-backend ;
: param-save-size 8 cells ; foldable
: xt-save reserved-area-size param-save-size + 2 cells + ; foldable
: local@ ( n -- x )
reserved-area-size param-save-size + + ; inline
: local-area-start xt-save cell + ; foldable
: factor-area-size 4 cells ;
: local@ ( n -- x ) local-area-start + ; inline
: next-save ( n -- i ) cell - ;
M: ppc-backend stack-frame ( n -- i ) local@ 4 cells align ;
: xt-save ( n -- i ) 2 cells - ;
M: ppc-backend stack-frame ( n -- i )
local@ factor-area-size + 4 cells align ;
M: temp-reg v>operand drop 11 ;
@ -85,17 +88,19 @@ M: ppc-backend %save-xt ( -- )
M: ppc-backend %prologue ( n -- )
0 MFLR
1 1 pick stack-frame neg STWU
11 1 xt-save STW
0 1 rot stack-frame lr-save + STW ;
1 1 pick neg ADDI
11 1 pick xt-save STW
dup 11 LI
11 1 pick next-save STW
0 1 rot lr-save + STW ;
M: ppc-backend %epilogue ( n -- )
#! At the end of each word that calls a subroutine, we store
#! the previous link register value in r0 by popping it off
#! the stack, set the link register to the contents of r0,
#! and jump to the link register.
0 1 pick stack-frame lr-save + LWZ
1 1 rot stack-frame ADDI
0 1 pick lr-save + LWZ
1 1 rot ADDI
0 MTLR ;
: %load-dlsym ( symbol dll register -- )
@ -236,7 +241,7 @@ M: ppc-backend %box-long-long ( n func -- )
4 1 rot cell + local@ LWZ
] when* r> f %alien-invoke ;
: temp@ stack-frame* swap - ;
: temp@ stack-frame* factor-area-size - swap - ;
: struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;

100
core/cpu/ppc/bootstrap.factor
View File

@ -17,85 +17,85 @@ big-endian on
: temp-reg 6 ;
: xt-reg 11 ;
: param-save-size 8 bootstrap-cells ;
: local@
bootstrap-cells reserved-area-size param-save-size + + ;
: array-save 0 local@ ;
: scan-save 1 local@ ;
: xt-save 2 local@ ;
: factor-area-size 4 bootstrap-cells ;
: stack-frame
3 local@ 4 bootstrap-cells align ;
factor-area-size c-area-size + 4 bootstrap-cells align ;
: next-save stack-frame bootstrap-cell - ;
: xt-save stack-frame 2 bootstrap-cells - ;
: array-save stack-frame 3 bootstrap-cells - ;
: scan-save stack-frame 4 bootstrap-cells - ;
[
temp-reg quot-reg quot-array@ LWZ ! load array
scan-reg temp-reg scan@ ADDI ! initialize scan pointer
temp-reg quot-reg quot-array@ LWZ ! load array
scan-reg temp-reg scan@ ADDI ! initialize scan pointer
] { } make jit-setup set
[
1 1 stack-frame neg STWU ! store back link
0 MFLR ! load return address into r0
temp-reg 1 array-save STW ! save array
xt-reg 1 xt-save STW ! save XT
0 1 lr-save stack-frame + STW ! save return address
0 MFLR
1 1 stack-frame neg ADDI
xt-reg 1 xt-save STW ! save XT
stack-frame xt-reg LI
xt-reg 1 next-save STW ! save frame size
temp-reg 1 array-save STW ! save array
0 1 lr-save stack-frame + STW ! save return address
] { } make jit-prolog set
[
temp-reg scan-reg 4 LWZU ! load literal and advance
temp-reg ds-reg 4 STWU ! push literal
temp-reg scan-reg 4 LWZU ! load literal and advance
temp-reg ds-reg 4 STWU ! push literal
] { } make jit-push-literal set
[
temp-reg scan-reg 4 LWZU ! load wrapper and advance
temp-reg dup wrapper@ LWZ ! load wrapped object
temp-reg ds-reg 4 STWU ! push wrapped object
temp-reg scan-reg 4 LWZU ! load wrapper and advance
temp-reg dup wrapper@ LWZ ! load wrapped object
temp-reg ds-reg 4 STWU ! push wrapped object
] { } make jit-push-wrapper set
[
4 1 MR ! pass stack pointer to primitive
4 1 MR ! pass stack pointer to primitive
] { } make jit-word-primitive-jump set
[
4 1 MR ! pass stack pointer to primitive
4 1 MR ! pass stack pointer to primitive
] { } make jit-word-primitive-call set
: load-xt ( -- )
xt-reg word-reg word-xt@ LWZ ;
: jit-call
scan-reg 1 scan-save STW ! save scan pointer
xt-reg MTLR ! pass XT to callee
BLRL ! call
scan-reg 1 scan-save LWZ ! restore scan pointer
scan-reg 1 scan-save STW ! save scan pointer
xt-reg MTLR ! pass XT to callee
BLRL ! call
scan-reg 1 scan-save LWZ ! restore scan pointer
;
: jit-jump
xt-reg MTCTR BCTR ;
[
word-reg scan-reg 4 LWZU ! load word and advance
word-reg scan-reg 4 LWZU ! load word and advance
load-xt
jit-call
] { } make jit-word-call set
[
word-reg scan-reg 4 LWZ ! load word
load-xt ! jump to word XT
word-reg scan-reg 4 LWZ ! load word
load-xt ! jump to word XT
jit-jump
] { } make jit-word-jump set
: load-branch
temp-reg ds-reg 0 LWZ ! load boolean
0 temp-reg \ f tag-number CMPI ! compare it with f
quot-reg scan-reg MR ! point quot-reg at false branch
2 BNE ! skip next insn if its not f
quot-reg dup 4 ADDI ! point quot-reg at true branch
quot-reg dup 4 LWZ ! load the branch
ds-reg dup 4 SUBI ! pop boolean
scan-reg dup 12 ADDI ! advance scan pointer
xt-reg quot-reg quot-xt@ LWZ ! load quotation-xt
temp-reg ds-reg 0 LWZ ! load boolean
0 temp-reg \ f tag-number CMPI ! compare it with f
quot-reg scan-reg MR ! point quot-reg at false branch
2 BNE ! skip next insn if its not f
quot-reg dup 4 ADDI ! point quot-reg at true branch
quot-reg dup 4 LWZ ! load the branch
ds-reg dup 4 SUBI ! pop boolean
scan-reg dup 12 ADDI ! advance scan pointer
xt-reg quot-reg quot-xt@ LWZ ! load quotation-xt
;
[
@ -107,20 +107,20 @@ big-endian on
] { } make jit-if-call set
[
temp-reg ds-reg 0 LWZ ! load index
temp-reg dup 1 SRAWI ! turn it into an array offset
ds-reg dup 4 SUBI ! pop index
scan-reg dup 4 LWZ ! load array
temp-reg dup scan-reg ADD ! compute quotation location
quot-reg temp-reg array-start LWZ ! load quotation
xt-reg quot-reg quot-xt@ LWZ ! load quotation-xt
jit-jump ! execute quotation
temp-reg ds-reg 0 LWZ ! load index
temp-reg dup 1 SRAWI ! turn it into an array offset
ds-reg dup 4 SUBI ! pop index
scan-reg dup 4 LWZ ! load array
temp-reg dup scan-reg ADD ! compute quotation location
quot-reg temp-reg array-start LWZ ! load quotation
xt-reg quot-reg quot-xt@ LWZ ! load quotation-xt
jit-jump ! execute quotation
] { } make jit-dispatch set
[
0 1 lr-save stack-frame + LWZ ! load return address
1 1 stack-frame ADDI ! pop stack frame
0 MTLR ! get ready to return
0 1 lr-save stack-frame + LWZ ! load return address
1 1 stack-frame ADDI ! pop stack frame
0 MTLR ! get ready to return
] { } make jit-epilog set
[ BLR ] { } make jit-return set

2
core/cpu/ppc/linux/bootstrap.factor
View File

@ -3,7 +3,7 @@
USING: parser layouts system ;
IN: bootstrap.ppc
: reserved-area-size 2 bootstrap-cells ;
: c-area-size 10 bootstrap-cells ;
: lr-save bootstrap-cell ;
"resource:core/cpu/ppc/bootstrap.factor" run-file

2
core/cpu/ppc/macosx/bootstrap.factor
View File

@ -3,7 +3,7 @@
USING: parser layouts system ;
IN: bootstrap.ppc
: reserved-area-size 6 bootstrap-cells ;
: c-area-size 14 bootstrap-cells ;
: lr-save 2 bootstrap-cells ;
"resource:core/cpu/ppc/bootstrap.factor" run-file

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

@ -47,14 +47,15 @@ M: x86-backend stack-frame ( n -- i )
M: x86-backend %save-xt ( -- )
xt-reg compiling-label get MOV ;
: factor-area-size 4 cells ;
M: x86-backend %prologue ( n -- )
dup cell + PUSH
xt-reg PUSH
xt-reg stack-reg pick stack-frame 4 cells + neg [+] LEA
xt-reg PUSH
stack-reg swap stack-frame 2 cells - SUB ;
stack-reg swap 2 cells - SUB ;
M: x86-backend %epilogue ( n -- )
stack-reg swap stack-frame ADD ;
stack-reg swap ADD ;
: %alien-global ( symbol dll register -- )
[ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
@ -65,6 +66,7 @@ M: x86-backend %prepare-alien-invoke
#! all roots.
"stack_chain" f temp-reg v>operand %alien-global
temp-reg v>operand [] stack-reg MOV
temp-reg v>operand [] cell SUB
temp-reg v>operand 2 cells [+] ds-reg MOV
temp-reg v>operand 3 cells [+] rs-reg MOV ;

13
core/cpu/x86/bootstrap.factor
View File

@ -10,15 +10,16 @@ big-endian off
: scan-save stack-reg 3 bootstrap-cells [+] ;
: stack-frame-size 8 bootstrap-cells ;
[
arg0 arg0 quot-array@ [+] MOV ! load array
scan-reg arg0 scan@ [+] LEA ! initialize scan pointer
] { } make jit-setup set
[
[
stack-frame-size PUSH ! save stack frame size
xt-reg PUSH ! save XT
xt-reg stack-reg next-frame@ [+] LEA ! compute forward chain pointer
xt-reg PUSH ! save forward chain pointer
arg0 PUSH ! save array
stack-reg 4 bootstrap-cells SUB ! reserve space for scan-save
] { } make jit-prolog set
@ -31,7 +32,7 @@ big-endian off
arg0 scan-reg [] MOV ! load literal
ds-reg [] arg0 MOV ! store literal on datastack
] { } make jit-push-literal set
[
advance-scan
ds-reg bootstrap-cell ADD ! increment datastack pointer
@ -94,7 +95,7 @@ big-endian off
] { } make jit-dispatch set
[
stack-reg 7 bootstrap-cells ADD ! unwind stack frame
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
] { } make jit-epilog set
[ 0 RET ] { } make jit-return set

3
core/generator/fixup/fixup.factor
View File

@ -35,7 +35,8 @@ M: label fixup*
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
: if-stack-frame ( frame-size quot -- )
over no-stack-frame = [ 2drop ] [ call ] if ; inline
swap dup no-stack-frame =
[ 2drop ] [ stack-frame swap call ] if ; inline
M: word fixup*
{

20
core/io/streams/nested/nested-tests.factor
View File

@ -1,23 +1,3 @@
USING: io io.streams.string io.streams.nested kernel math
namespaces io.styles tools.test ;
IN: temporary
[ "=>a<=" ] [
[
[
H{ { highlight t } } [
H{ } [ "a" write ] with-nesting
] with-style
] string-out
] with-scope
] unit-test
[ "a" ] [
[
[
H{ } [
H{ { highlight t } } [ "a" write ] with-nesting
] with-style
] string-out
] with-scope
] unit-test

7
core/io/streams/plain/plain.factor
View File

@ -9,12 +9,11 @@ TUPLE: plain-writer ;
: <plain-writer> ( stream -- new-stream )
plain-writer construct-delegate ;
M: plain-writer stream-nl CHAR: \n swap stream-write1 ;
M: plain-writer stream-nl
CHAR: \n swap stream-write1 ;
M: plain-writer stream-format
highlight rot at
[ >r "=>" swap "<=" 3append r> ] when
stream-write ;
nip stream-write ;
M: plain-writer make-span-stream
<style-stream> <ignore-close-stream> ;

4
core/io/styles/styles-docs.factor
View File

@ -106,10 +106,6 @@ HELP: presented-path
HELP: presented-printer
{ $description "Character and paragraph style. A quotation with stack effect " { $snippet "( obj -- )" } " which is applied to the value at the " { $link presented-path } " if the presentation needs to be re-displayed after the object has been edited." } ;
HELP: highlight
{ $description "Character style. Used to mark up text on streams that otherwise do not support different colors or font styles." }
{ $examples "Instances of " { $link plain-writer } " uppercases highlighted text." } ;
HELP: page-color
{ $description "Paragraph style. Background color of the paragraph block, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." }
{ $examples

3
core/io/styles/styles.factor
View File

@ -19,9 +19,6 @@ SYMBOL: presented
SYMBOL: presented-path
SYMBOL: presented-printer
! Only for plain-stream
SYMBOL: highlight
! Paragraph styles
SYMBOL: page-color
SYMBOL: border-color

5
core/kernel/kernel-docs.factor
View File

@ -338,6 +338,11 @@ $nl
{ $code "2 [ 2 + 3 * ] call" "2 2 + 3 *" }
} ;
HELP: call-clear ( quot -- )
{ $values { "quot" callable } }
{ $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." }
{ $notes "Used to implement " { $link "threads" } "." } ;
HELP: slip
{ $values { "quot" quotation } { "x" object } }
{ $description "Calls a quotation while hiding the top of the stack." } ;

2
core/math/functions/functions-tests.factor
View File

@ -72,3 +72,5 @@ IN: temporary
[ 3 ] [ 5 7 mod-inv ] unit-test
[ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test
[ 2 10 mod-inv ] unit-test-fails

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

@ -50,7 +50,7 @@ M: integer (^)
tuck gcd 1 = [
dup 0 < [ + ] [ nip ] if
] [
[ "Non-trivial divisor found" throw ] unless
"Non-trivial divisor found" throw
] if ; foldable
: ^mod ( x y n -- z )

22
core/prettyprint/backend/backend.factor
View File

@ -22,11 +22,13 @@ GENERIC: pprint* ( obj -- )
! Atoms
: word-style ( word -- style )
[
dup presented set
dup parsing? over delimiter? rot t eq? or or
[ bold font-style set ] when
] H{ } make-assoc ;
dup "word-style" word-prop >hashtable [
[
dup presented set
dup parsing? over delimiter? rot t eq? or or
[ bold font-style set ] when
] bind
] keep ;
: word-name* ( word -- str )
word-name "( no name )" or ;
@ -129,15 +131,9 @@ M: pathname pprint* dup pathname-string "P\" " pprint-string ;
dup zero? [ 2drop f ] [ >r head r> ] if
] when ;
: pprint-hilite ( n object -- )
pprint* hilite-index get = [ hilite ] when ;
: pprint-elements ( seq -- )
do-length-limit >r dup hilite-quotation get eq? [
[ length ] keep [ pprint-hilite ] 2each
] [
[ pprint* ] each
] if
do-length-limit >r
[ pprint* ] each
r> [ "~" swap number>string " more~" 3append text ] when* ;
GENERIC: pprint-delims ( obj -- start end )

6
core/prettyprint/config/config-docs.factor
View File

@ -27,9 +27,3 @@ HELP: line-limit
HELP: string-limit
{ $var-description "Toggles whether printed strings are truncated to the margin." } ;
HELP: hilite-quotation
{ $var-description "If set, printing this quotation will highlight the element with index " { $link hilite-index } " in an output stream-specific manner." } ;
HELP: hilite-index
{ $var-description "If set, printing the quotation stored in " { $link hilite-quotation } " will highlight the element with this index in an output stream-specific manner." } ;

4
core/prettyprint/config/config.factor
View File

@ -13,10 +13,6 @@ SYMBOL: length-limit
SYMBOL: line-limit
SYMBOL: string-limit
! Special trick to highlight a word in a quotation
SYMBOL: hilite-quotation
SYMBOL: hilite-index
global [
4 tab-size set
64 margin set

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

@ -204,7 +204,7 @@ HELP: stack.
HELP: callstack.
{ $values { "callstack" callstack } }
{ $description "Displays a sequence output by " { $link callstack } " in a nice way, by highlighting the current execution point in every call frame." } ;
{ $description "Displays a sequence output by " { $link callstack } " in a nice way, by highlighting the current execution point in every call frame with " { $link -> } "." } ;
HELP: .c
{ $description "Displays the contents of the call stack, with the top of the stack printed first." } ;

30
core/prettyprint/prettyprint-tests.factor
View File

@ -1,7 +1,8 @@
USING: arrays definitions io.streams.string io.streams.duplex
kernel math namespaces parser prettyprint prettyprint.config
prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard ;
effects splitting generic.standard prettyprint.private
continuations ;
IN: temporary
[ "4" ] [ 4 unparse ] unit-test
@ -53,12 +54,6 @@ unit-test
[ "W{ \\ + }" ] [ [ W{ \ + } ] first unparse ] unit-test
[ "[ 1 2 =>dup<= ]" ]
[
[ 1 2 dup ] dup hilite-quotation set 2 hilite-index set
[ pprint ] string-out
] unit-test
[ t ] [
"[ >r \"alloc\" add 0 0 r> ]" dup parse first unparse =
] unit-test
@ -283,3 +278,24 @@ unit-test
] unit-test
[ ] [ \ effect-in synopsis drop ] unit-test
[ [ + ] ] [
[ \ + (step-into) ] (remove-breakpoints)
] unit-test
[ [ (step-into) ] ] [
[ (step-into) ] (remove-breakpoints)
] unit-test
[ [ 3 ] ] [
[ 3 (step-into) ] (remove-breakpoints)
] unit-test
[ [ 2 2 + . ] ] [
[ 2 2 \ + (step-into) . ] (remove-breakpoints)
] unit-test
[ [ 2 2 + . ] ] [
[ 2 break 2 \ + (step-into) . ] (remove-breakpoints)
] unit-test

49
core/prettyprint/prettyprint.factor
View File

@ -6,7 +6,8 @@ math namespaces sequences strings io.styles io.streams.string
vectors words prettyprint.backend prettyprint.sections
prettyprint.config sorting splitting math.parser vocabs
definitions effects tuples io.files classes continuations
hashtables classes.mixin classes.union classes.predicate ;
hashtables classes.mixin classes.union classes.predicate
combinators quotations ;
: make-pprint ( obj quot -- block in use )
[
@ -85,20 +86,48 @@ hashtables classes.mixin classes.union classes.predicate ;
: .s ( -- ) datastack stack. ;
: .r ( -- ) retainstack stack. ;
: callframe. ( seq pos -- )
SYMBOL: ->
\ ->
{ { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } }
"word-style" set-word-prop
<PRIVATE
! This code is ugly and could probably be simplified
: remove-step-into
building get dup empty? [
drop \ (step-into) ,
] [
pop dup wrapper? [ wrapped ] when ,
] if ;
: (remove-breakpoints) ( quot -- newquot )
[
[
hilite-index set
dup hilite-quotation set
2 nesting-limit set
.
] with-scope
{
{ break [ ] }
{ (step-into) [ remove-step-into ] }
[ , ]
} case
] each
] [ ] make ;
: remove-breakpoints ( quot pos -- quot' )
over quotation? [
1+ swap cut [ (remove-breakpoints) ] 2apply
[ -> ] swap 3append
] [
.
] if* ;
drop
] if ;
PRIVATE>
: callstack. ( callstack -- )
callstack>array 2 <groups> [ callframe. ] assoc-each ;
callstack>array 2 <groups> [
remove-breakpoints
2 nesting-limit [ . ] with-variable
] assoc-each ;
: .c ( -- ) callstack callstack. ;

1
core/prettyprint/sections/sections-docs.factor
View File

@ -74,7 +74,6 @@ HELP: section
{ $link block }
{ $link inset }
{ $link flow }
{ $link hilite }
{ $link colon }
}
"Instances of this class have the following slots:"

11
core/prettyprint/sections/sections.factor
View File

@ -151,17 +151,6 @@ TUPLE: block sections ;
: last-section ( -- section )
pprinter-block block-sections [ break? not ] find-last nip ;
: hilite-style ( -- hash )
H{
{ background { 0.9 0.9 0.9 1 } }
{ highlight t }
} ;
: hilite ( -- )
last-section
dup section-style hilite-style union
swap set-section-style ;
: start-group ( -- )
t last-section set-section-start-group? ;

2
core/sbufs/sbufs.factor
View File

@ -9,7 +9,7 @@ IN: sbufs
M: sbuf set-nth-unsafe
underlying >r >r >fixnum r> >fixnum r> set-char-slot ;
M: sbuf new drop [ 0 <string> ] keep string>sbuf ;
M: sbuf new drop [ 0 <string> ] keep >fixnum string>sbuf ;
: >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline

2
core/threads/threads.factor
View File

@ -51,7 +51,7 @@ PRIVATE>
>r schedule-thread r> [
V{ } set-catchstack
{ } set-retainstack
[ print-error ] recover stop
[ [ print-error ] recover stop ] call-clear
] (throw)
] curry callcc0 ;

6
core/vectors/vectors-tests.factor
View File

@ -1,6 +1,6 @@
USING: arrays kernel kernel.private math namespaces
sequences sequences.private strings tools.test vectors
continuations random growable ;
continuations random growable classes ;
IN: temporary
[ ] [ 10 [ [ -1000000 <vector> ] catch drop ] times ] unit-test
@ -93,3 +93,7 @@ IN: temporary
[ t ] [
100 >array dup >vector <reversed> >array >r reverse r> =
] unit-test
[ fixnum ] [ 1 >bignum V{ } new length class ] unit-test
[ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test

2
core/vectors/vectors.factor
View File

@ -14,7 +14,7 @@ M: vector like
dup array? [ dup length array>vector ] [ >vector ] if
] unless ;
M: vector new drop [ f <array> ] keep array>vector ;
M: vector new drop [ f <array> ] keep >fixnum array>vector ;
M: vector equal?
over vector? [ sequence= ] [ 2drop f ] if ;

2
extra/asn1/asn1-tests.factor
View File

@ -1,4 +1,4 @@
USING: asn1 asn1.ldap io.streams.string tools.test ;
USING: asn1 asn1.ldap io io.streams.string tools.test ;
[ 6 ] [
"\u0002\u0001\u0006" <string-reader> [ asn-syntax read-ber ] with-stream

2
extra/bunny/deploy.factor
View File

@ -1,4 +1,4 @@
USING: tools.deploy ;
USING: tools.deploy.config ;
V{
{ strip-word-props? t }
{ strip-word-names? t }

2
extra/channels/channels-tests.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test math channels channels.private
sequences threads ;
sequences threads sorting ;
IN: temporary
{ 3 t } [

3
extra/channels/remote/remote-tests.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2005 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test math assocs channels channels.remote ;
USING: kernel tools.test math assocs channels channels.remote
channels.remote.private ;
IN: temporary
{ t } [

24
extra/cocoa/messages/messages.factor
View File

@ -3,7 +3,8 @@
USING: alien alien.c-types alien.compiler
arrays assocs combinators compiler inference.transforms kernel
math namespaces parser prettyprint prettyprint.sections
quotations sequences strings words cocoa.runtime io macros ;
quotations sequences strings words cocoa.runtime io macros
memoize ;
IN: cocoa.messages
: make-sender ( method function -- quot )
@ -20,10 +21,8 @@ IN: cocoa.messages
SYMBOL: message-senders
SYMBOL: super-message-senders
global [
message-senders [ H{ } assoc-like ] change
super-message-senders [ H{ } assoc-like ] change
] bind
message-senders global [ H{ } assoc-like ] change-at
super-message-senders global [ H{ } assoc-like ] change-at
: cache-stub ( method function hash -- )
[
@ -56,14 +55,14 @@ TUPLE: selector name object ;
SYMBOL: selectors
H{ } clone selectors set-global
selectors global [ H{ } assoc-like ] change-at
: cache-selector ( string -- selector )
selectors get-global [ <selector> ] cache ;
SYMBOL: objc-methods
H{ } clone objc-methods set-global
objc-methods global [ H{ } assoc-like ] change-at
: lookup-method ( selector -- method )
dup objc-methods get at
@ -74,7 +73,7 @@ H{ } clone objc-methods set-global
\ >r <repetition> >quotation -rot
\ r> <repetition> >quotation 3append ;
: make-prepare-send ( selector method super? -- quot )
MEMO: make-prepare-send ( selector method super? -- quot )
[
[ \ <super> , ] when
swap cache-selector , \ selector ,
@ -82,11 +81,10 @@ H{ } clone objc-methods set-global
swap second length 2 - make-dip ;
MACRO: (send) ( selector super? -- quot )
[
>r dup lookup-method r>
[ make-prepare-send % ] 2keep
super-message-senders message-senders ? get at ,
] [ ] make ;
>r dup lookup-method r>
[ make-prepare-send ] 2keep
super-message-senders message-senders ? get at
[ slip execute ] 2curry ;
: send ( args... receiver selector -- return... ) f (send) ; inline

2
extra/color-picker/deploy.factor
View File

@ -1,4 +1,4 @@
USING: tools.deploy ;
USING: tools.deploy.config ;
V{
{ strip-word-props? t }
{ strip-word-names? t }

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

@ -3,7 +3,7 @@
!
USING: kernel concurrency threads vectors arrays sequences
namespaces tools.test continuations dlists strings math words
match quotations ;
match quotations concurrency.private ;
IN: temporary
[ V{ 1 2 3 } ] [

2
extra/coroutines/coroutines.factor
View File

@ -40,5 +40,5 @@ TUPLE: coroutine resumecc exitcc ;
: coterminate ( v -- )
current-coro get
f over set-coroutine-resumecc
[ ] over set-coroutine-resumecc
coroutine-exitcc continue-with ;

2
extra/crypto/timing/timing-tests.factor
View File

@ -1,4 +1,4 @@
USING: crypto.timing kernel tools.test ;
USING: crypto.timing kernel tools.test system math ;
IN: temporary
[ t ] [ millis [ ] 1000 with-timing millis swap - 1000 >= ] unit-test

2
extra/destructors/destructors-tests.factor
View File

@ -1,4 +1,4 @@
USING: destructors kernel tools.test ;
USING: destructors kernel tools.test continuations ;
IN: temporary
TUPLE: dummy-obj destroyed? ;

2
extra/factory/deploy.factor
View File

@ -1,4 +1,4 @@
USING: tools.deploy ;
USING: tools.deploy.config ;
V{
{ strip-globals? f }
{ strip-word-props? f }

2
extra/gesture-logger/deploy.factor
View File

@ -1,4 +1,4 @@
USING: tools.deploy ;
USING: tools.deploy.config ;
V{
{ strip-word-props? t }
{ strip-word-names? f }

2
extra/golden-section/deploy.factor
View File

@ -1,4 +1,4 @@
USING: tools.deploy ;
USING: tools.deploy.config ;
V{
{ strip-word-props? t }
{ strip-word-names? t }

2
extra/hello-ui/deploy.factor
View File

@ -1,4 +1,4 @@
USING: tools.deploy ;
USING: tools.deploy.config ;
V{
{ strip-word-props? t }
{ strip-word-names? t }

2
extra/hello-world/deploy.factor
View File

@ -1,4 +1,4 @@
USING: tools.deploy ;
USING: tools.deploy.config ;
V{
{ strip-word-props? t }
{ strip-word-names? t }

3
extra/inverse/inverse-tests.factor
View File

@ -1,4 +1,5 @@
USING: inverse tools.test arrays math kernel sequences ;
USING: inverse tools.test arrays math kernel sequences
math.functions ;
[ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
[ { 3 4 } [ dup 2array ] undo ] unit-test-fails

3
extra/io/mmap/mmap-tests.factor
View File

@ -1,4 +1,5 @@
USING: io io.mmap kernel tools.test ;
USING: io io.mmap io.files kernel tools.test continuations
sequences ;
IN: temporary
[ "mmap-test-file.txt" resource-path delete-file ] catch drop

4
extra/koszul/koszul-tests.factor
View File

@ -7,7 +7,7 @@ IN: temporary
{ { 1 } { 2 3 } { 4 5 6 } { 7 8 } { } } graded
] unit-test
SYMBOLS: x1 x2 x3 x4 z1 z2 ;
SYMBOLS: x1 x2 x3 x4 x5 x6 z1 z2 ;
[ H{ { { x1 } 3 } } ] [ x1 3 wedge ] unit-test
@ -23,7 +23,7 @@ x3 x4 wedge z2 d=
! Unimodular example
boundaries get clear-assoc
SYMBOLS: x y z ;
SYMBOLS: x y w z ;
x y wedge z d=
y z wedge x d=

3
extra/math/analysis/analysis-tests.factor
View File

@ -1,4 +1,5 @@
USING: kernel math math.functions tools.test ;
USING: kernel math math.functions tools.test math.analysis
math.constants ;
IN: temporary
: eps

2
extra/math/matrices/elimination/elimination-tests.factor
View File

@ -1,6 +1,6 @@
IN: temporary
USING: kernel math.matrices math.matrices.elimination
tools.test ;
tools.test sequences ;
[
{

3
extra/math/numerical-integration/numerical-integration-tests.factor
View File

@ -1,4 +1,5 @@
USING: kernel math.numerical-integration ;
USING: kernel math.numerical-integration tools.test math
math.constants math.functions ;
IN: temporary
[ 50 ] [ 0 10 [ ] integrate-simpson ] unit-test

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

@ -1,5 +1,5 @@
IN: temporary
USING: kernel math tools.test ;
USING: kernel math math.polynomials tools.test ;
! Tests
[ { 0 1 } ] [ { 0 1 0 0 } ptrim ] unit-test

1
extra/math/statistics/authors.txt
View File

@ -1 +1,2 @@
Doug Coleman
Michael Judge

58
extra/math/statistics/statistics-docs.factor Normal file
View File

@ -0,0 +1,58 @@
USING: math.statistics help.markup help.syntax debugger ;
HELP: geometric-mean
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." }
{ $examples { $example "USE: math.statistics" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } }
{ $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ;
HELP: harmonic-mean
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." }
{ $examples { $example "USE: math.statistics" "{ 1 2 3 } harmonic-mean ." "6/11" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: mean
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the arithmetic mean of all elements in " { $snippet "seq" } "." }
{ $examples { $example "USE: math.statistics" "{ 1 2 3 } mean ." "2" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: median
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the median of " { $snippet "seq" } " by sorting the sequence from lowest value to highest and outputting the middle one. If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is outputted." }
{ $examples
{ $example "USE: math.statistics" "{ 1 2 3 } median ." "2" }
{ $example "USE: math.statistics" "{ 1 2 3 4 } median ." "5/2" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: range
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the distance of the maximum and minimum values in " { $snippet "seq" } "." }
{ $examples
{ $example "USE: math.statistics" "{ 1 2 3 } range ." "2" }
{ $example "USE: math.statistics" "{ 1 2 3 4 } range ." "3" } } ;
HELP: std
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the standard deviation of " { $snippet "seq" } " by squaring the variance of the sequence. It measures how widely spread the values in a sequence are about the mean." }
{ $examples
{ $example "USE: math.statistics" "{ 1 2 3 } std ." "1.0" }
{ $example "USE: math.statistics" "{ 1 2 3 4 } std ." "1.290994448735806" } } ;
HELP: ste
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." }
{ $examples
{ $example "USE: math.statistics" "{ -2 2 } ste ." "2.0" }
{ $example "USE: math.statistics" "{ -2 2 2 } ste ." "1.333333333333333" } } ;
HELP: var
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." }
{ $notes "If the number of elements in " { $snippet "seq" } " is 1 or less, it outputs 0." }
{ $examples
{ $example "USE: math.statistics" "{ 1 } var ." "0" }
{ $example "USE: math.statistics" "{ 1 2 3 } var ." "1" }
{ $example "USE: math.statistics" "{ 1 2 3 4 } var ." "5/3" } } ;

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

@ -15,9 +15,11 @@ IN: temporary
[ 1 ] [ { 1 2 3 } var ] unit-test
[ 1 ] [ { 1 2 3 } std ] unit-test
[ t ] [ { 1 2 3 4 } ste 0.6454972243679028 - .0001 < ] unit-test
[ t ] [ { 23.2 33.4 22.5 66.3 44.5 } std 18.1906 - .0001 < ] unit-test
[ 0 ] [ { 1 } var ] unit-test
[ 0 ] [ { 1 } std ] unit-test
[ 0 ] [ { 1 } ste ] unit-test

4
extra/math/statistics/statistics.factor
View File

@ -40,6 +40,10 @@ IN: math.statistics
#! standard deviation, sqrt of variance
var sqrt ;
: ste ( seq -- x )
#! standard error, standard deviation / sqrt ( length of sequence )
dup std swap length sqrt / ;
: ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
! finds sigma((xi-mean(x))(yi-mean(y))
0 [ [ >r pick r> swap - ] 2apply * + ] 2reduce 2nip ;

2
extra/maze/deploy.factor
View File

@ -1,4 +1,4 @@
USING: tools.deploy ;
USING: tools.deploy.config ;
V{
{ strip-word-props? t }
{ strip-word-names? f }

2
extra/nehe/deploy.factor
View File

@ -1,4 +1,4 @@
USING: tools.deploy ;
USING: tools.deploy.config ;
V{
{ strip-word-props? t }
{ strip-word-names? t }

2
extra/sequences/lib/lib-tests.factor
View File

@ -1,4 +1,4 @@
USING: kernel sequences.lib ;
USING: kernel sequences.lib math math.functions tools.test ;
[ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test
[ 36 ] [ { 2 3 } [ sq ] [ * ] map-reduce ] unit-test

3
extra/serialize/serialize-tests.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
!
USING: tools.test kernel serialize io io.streams.string math
alien arrays byte-arrays sequences math prettyprint ;
alien arrays byte-arrays sequences math prettyprint parser
classes math.constants ;
IN: temporary
TUPLE: serialize-test a b ;

2
extra/tetris/deploy.factor
View File

@ -1,4 +1,4 @@
USING: tools.deploy ;
USING: tools.deploy.config ;
V{
{ strip-word-props? t }
{ strip-word-names? t }

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

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words parser io inspector quotations sequences
prettyprint tools.interpreter ;
prettyprint continuations ;
IN: tools.annotations
: annotate ( word quot -- )

4
extra/tools/deploy/app/app.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.files io.launcher kernel namespaces sequences
system cocoa.plists cocoa.application tools.deploy assocs
hashtables prettyprint ;
system cocoa.plists cocoa.application tools.deploy
tools.deploy.config assocs hashtables prettyprint ;
IN: tools.deploy.app
: mkdir ( path -- )

105
extra/tools/deploy/config/config-docs.factor Normal file
View File

@ -0,0 +1,105 @@
USING: help.markup help.syntax words alien.c-types assocs
kernel ;
IN: tools.deploy.config
ARTICLE: "deploy-config" "Deployment configuration"
"The deployment configuration is a key/value mapping stored in the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If this file does not exist, the default deployment configuration is used:"
{ $subsection default-config }
"The deployment configuration can be read and written with a pair of words:"
{ $subsection deploy-config }
{ $subsection set-deploy-config }
"A utility word is provided to load the configuration, change a flag, and store it back to disk:"
{ $subsection set-deploy-flag } ;
ARTICLE: "deploy-flags" "Deployment flags"
"There are two types of flags. The first set controls the major subsystems which are to be included in the deployment image:"
{ $subsection deploy-math? }
{ $subsection deploy-compiled? }
{ $subsection deploy-io? }
{ $subsection deploy-ui? }
"The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:"
{ $subsection strip-globals? }
{ $subsection strip-word-props? }
{ $subsection strip-word-names? }
{ $subsection strip-dictionary? }
{ $subsection strip-debugger? }
{ $subsection strip-prettyprint? }
{ $subsection strip-c-types? } ;
ARTICLE: "prepare-deploy" "Preparing to deploy an application"
"In order to deploy an application as a stand-alone image, the application's vocabulary must first be given a " { $link POSTPONE: MAIN: } " hook. Then, a " { $emphasis "deployment configuration" } " must be created."
{ $subsection "deploy-config" }
{ $subsection "deploy-flags" } ;
ABOUT: "prepare-deploy"
HELP: strip-globals?
{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed variables from the global namespace."
$nl
"On by default. Disable this if the heuristics strip out required variables." } ;
HELP: strip-word-props?
{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed word properties from words in the dictionary."
$nl
"On by default. Disable this if the heuristics strip out required word properties." } ;
HELP: strip-word-names?
{ $description "Deploy flag. If set, the deploy tool strips word names from words in the dictionary."
$nl
"On by default. Disable this if your program calls " { $link word-name } "." } ;
HELP: strip-dictionary?
{ $description "Deploy flag. If set, the deploy tool strips unused words."
$nl
"On by default. Disable this if your program calls " { $link lookup } " to look up words by name, or needs to parse code at run-time." } ;
HELP: strip-debugger?
{ $description "Deploy flag. If set, the deploy tool strips the verbose error reporting facility; any errors thrown by the program will start the low-level debugger in the VM."
$nl
"On by default. Disable this if you need to debug a problem which only occurs when your program is running deployed." } ;
HELP: strip-prettyprint?
{ $description "Deploy flag. If set, the deploy tool strips variables used by the prettyprinter."
$nl
"On by default. Disable this if your program uses the prettyprinter." } ;
HELP: strip-c-types?
{ $description "Deploy flag. If set, the deploy tool strips out the " { $link c-types } " table."
$nl
"On by default. Disable this if your program calls " { $link c-type } ", " { $link heap-size } ", " { $link <c-object> } ", " { $link <c-array> } ", " { $link malloc-object } ", or " { $link malloc-array } " with a C type name which is not a literal pushed directly at the call site. In this situation, the compiler is unable to fold away the C type lookup, and thus must use the global table at runtime." } ;
HELP: deploy-math?
{ $description "Deploy flag. If set, the deployed image will contain the full number tower."
$nl
"On by default. Most programs require the number tower, in particular, any program deployed with " { $link deploy-compiled? } " set." } ;
HELP: deploy-compiled?
{ $description "Deploy flag. If set, words in the deployed image will be compiled when possible."
$nl
"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
HELP: deploy-ui?
{ $description "Deploy flag. If set, the Factor UI will be included in the deployed image."
$nl
"Off by default. Programs wishing to use the UI must be deployed with this flag on." } ;
HELP: deploy-io?
{ $description "Deploy flag. If set, support for non-blocking I/O and networking will be included in the deployed image."
$nl
"Off by default. Programs wishing to use non-blocking I/O or networking must be deployed with this flag on." } ;
HELP: default-config
{ $values { "assoc" assoc } }
{ $description "Outputs the default deployment configuration." } ;
HELP: deploy-config
{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } }
{ $description "Loads a vocabulary's deployment configuration from the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If the file does not exist, the " { $link default-config } " is output." } ;
HELP: set-deploy-config
{ $values { "assoc" assoc } { "vocab" "a vocabulary specifier" } }
{ $description "Stores a vocabulary's deployment configuration to the " { $snippet "deploy.factor" } " file in the vocabulary's directory." } ;
HELP: set-deploy-flag
{ $values { "value" object } { "key" object } { "vocab" "a vocabulary specifier" } }
{ $description "Modifies an entry in a vocabulary's deployment configuration on disk." } ;

53
extra/tools/deploy/config/config.factor Normal file
View File

@ -0,0 +1,53 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: vocabs.loader io.files io kernel sequences assocs
splitting parser prettyprint ;
IN: tools.deploy.config
SYMBOL: strip-globals?
SYMBOL: strip-word-props?
SYMBOL: strip-word-names?
SYMBOL: strip-dictionary?
SYMBOL: strip-debugger?
SYMBOL: strip-prettyprint?
SYMBOL: strip-c-types?
SYMBOL: deploy-math?
SYMBOL: deploy-compiled?
SYMBOL: deploy-io?
SYMBOL: deploy-ui?
SYMBOL: deploy-vm
SYMBOL: deploy-image
: default-config ( -- assoc )
V{
{ strip-prettyprint? t }
{ strip-globals? t }
{ strip-word-props? t }
{ strip-word-names? t }
{ strip-dictionary? t }
{ strip-debugger? t }
{ strip-c-types? t }
{ deploy-math? t }
{ deploy-compiled? t }
{ deploy-io? f }
{ deploy-ui? f }
! default value for deploy.app
{ "stop-after-last-window?" t }
} clone ;
: deploy-config-path ( vocab -- string )
vocab-dir "deploy.factor" path+ ;
: deploy-config ( vocab -- assoc )
default-config swap
dup deploy-config-path vocab-file-contents
parse-fresh dup empty? [ drop ] [ first union ] if ;
: set-deploy-config ( assoc vocab -- )
>r unparse-use string-lines r>
dup deploy-config-path set-vocab-file-contents ;
: set-deploy-flag ( value key vocab -- )
[ deploy-config [ set-at ] keep ] keep set-deploy-config ;

99
extra/tools/deploy/deploy-docs.factor
View File

@ -2,30 +2,6 @@ USING: help.markup help.syntax words alien.c-types assocs
kernel ;
IN: tools.deploy
ARTICLE: "deploy-config" "Deployment configuration"
"The deployment configuration is a key/value mapping stored in the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If this file does not exist, the default deployment configuration is used:"
{ $subsection default-config }
"The deployment configuration can be read and written with a pair of words:"
{ $subsection deploy-config }
{ $subsection set-deploy-config }
"A utility word is provided to load the configuration, change a flag, and store it back to disk:"
{ $subsection set-deploy-flag } ;
ARTICLE: "deploy-flags" "Deployment flags"
"There are two types of flags. The first set controls the major subsystems which are to be included in the deployment image:"
{ $subsection deploy-math? }
{ $subsection deploy-compiled? }
{ $subsection deploy-io? }
{ $subsection deploy-ui? }
"The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:"
{ $subsection strip-globals? }
{ $subsection strip-word-props? }
{ $subsection strip-word-names? }
{ $subsection strip-dictionary? }
{ $subsection strip-debugger? }
{ $subsection strip-prettyprint? }
{ $subsection strip-c-types? } ;
ARTICLE: "tools.deploy" "Stand-alone image deployment"
"The stand-alone image deployment tool takes a vocabulary and generates an image, which when passed to the VM, runs the vocabulary's " { $link POSTPONE: MAIN: } " hook."
$nl
@ -33,85 +9,12 @@ $nl
{ $code "\"hello-world\" deploy" }
"This generates an image file named " { $snippet "hello-world.image" } ". Now we can start this image from the operating system's command line (see " { $link "runtime-cli-args" } "):"
{ $code "./factor -i=hello-world.image" "Hello world" }
"In order to deploy an application as a stand-alone image, the application's vocabulary must first be given a " { $link POSTPONE: MAIN: } " hook. Then, a " { $emphasis "deployment configuration" } " must be created."
{ $subsection "deploy-config" }
{ $subsection "deploy-flags" }
"Once the necessary deployment flags have been set, a deployment image can be generated:"
{ $subsection deploy } ;
ABOUT: "tools.deploy"
HELP: strip-globals?
{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed variables from the global namespace."
$nl
"On by default. Disable this if the heuristics strip out required variables." } ;
HELP: strip-word-props?
{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed word properties from words in the dictionary."
$nl
"On by default. Disable this if the heuristics strip out required word properties." } ;
HELP: strip-word-names?
{ $description "Deploy flag. If set, the deploy tool strips word names from words in the dictionary."
$nl
"On by default. Disable this if your program calls " { $link word-name } "." } ;
HELP: strip-dictionary?
{ $description "Deploy flag. If set, the deploy tool strips unused words."
$nl
"On by default. Disable this if your program calls " { $link lookup } " to look up words by name, or needs to parse code at run-time." } ;
HELP: strip-debugger?
{ $description "Deploy flag. If set, the deploy tool strips the verbose error reporting facility; any errors thrown by the program will start the low-level debugger in the VM."
$nl
"On by default. Disable this if you need to debug a problem which only occurs when your program is running deployed." } ;
HELP: strip-prettyprint?
{ $description "Deploy flag. If set, the deploy tool strips variables used by the prettyprinter."
$nl
"On by default. Disable this if your program uses the prettyprinter." } ;
HELP: strip-c-types?
{ $description "Deploy flag. If set, the deploy tool strips out the " { $link c-types } " table."
$nl
"On by default. Disable this if your program calls " { $link c-type } ", " { $link heap-size } ", " { $link <c-object> } ", " { $link <c-array> } ", " { $link malloc-object } ", or " { $link malloc-array } " with a C type name which is not a literal pushed directly at the call site. In this situation, the compiler is unable to fold away the C type lookup, and thus must use the global table at runtime." } ;
HELP: deploy-math?
{ $description "Deploy flag. If set, the deployed image will contain the full number tower."
$nl
"On by default. Most programs require the number tower, in particular, any program deployed with " { $link deploy-compiled? } " set." } ;
HELP: deploy-compiled?
{ $description "Deploy flag. If set, words in the deployed image will be compiled when possible."
$nl
"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
HELP: deploy-ui?
{ $description "Deploy flag. If set, the Factor UI will be included in the deployed image."
$nl
"Off by default. Programs wishing to use the UI must be deployed with this flag on." } ;
HELP: deploy-io?
{ $description "Deploy flag. If set, support for non-blocking I/O and networking will be included in the deployed image."
$nl
"Off by default. Programs wishing to use non-blocking I/O or networking must be deployed with this flag on." } ;
HELP: default-config
{ $values { "assoc" assoc } }
{ $description "Outputs the default deployment configuration." } ;
HELP: deploy-config
{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } }
{ $description "Loads a vocabulary's deployment configuration from the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If the file does not exist, the " { $link default-config } " is output." } ;
HELP: set-deploy-config
{ $values { "assoc" assoc } { "vocab" "a vocabulary specifier" } }
{ $description "Stores a vocabulary's deployment configuration to the " { $snippet "deploy.factor" } " file in the vocabulary's directory." } ;
HELP: set-deploy-flag
{ $values { "value" object } { "key" object } { "vocab" "a vocabulary specifier" } }
{ $description "Modifies an entry in a vocabulary's deployment configuration on disk." } ;
HELP: deploy*
{ $values { "vm" "a pathname string" } { "image" "a pathname string" } { "vocab" "a vocabulary specifier" } { "config" assoc } }
{ $description "Deploys " { $snippet "vocab" } ", which must have a " { $link POSTPONE: MAIN: } " hook, using the specified VM and configuration. The deployed image is saved as " { $snippet "image" } "." }

247
extra/tools/deploy/deploy.factor
View File

@ -5,255 +5,30 @@ assocs kernel vocabs words sequences memory io system arrays
continuations math definitions mirrors splitting parser classes
inspector layouts vocabs.loader prettyprint.config prettyprint
debugger io.streams.c io.streams.duplex io.files io.backend
quotations io.launcher words.private ;
quotations io.launcher words.private tools.deploy.config ;
IN: tools.deploy
SYMBOL: strip-globals?
SYMBOL: strip-word-props?
SYMBOL: strip-word-names?
SYMBOL: strip-dictionary?
SYMBOL: strip-debugger?
SYMBOL: strip-prettyprint?
SYMBOL: strip-c-types?
SYMBOL: deploy-math?
SYMBOL: deploy-compiled?
SYMBOL: deploy-io?
SYMBOL: deploy-ui?
SYMBOL: deploy-vm
SYMBOL: deploy-image
: default-config ( -- assoc )
V{
{ strip-prettyprint? t }
{ strip-globals? t }
{ strip-word-props? t }
{ strip-word-names? t }
{ strip-dictionary? t }
{ strip-debugger? t }
{ strip-c-types? t }
{ deploy-math? t }
{ deploy-compiled? t }
{ deploy-io? f }
{ deploy-ui? f }
! default value for deploy.app
{ "stop-after-last-window?" t }
} clone ;
: deploy-config-path ( vocab -- string )
vocab-dir "deploy.factor" path+ ;
: deploy-config ( vocab -- assoc )
default-config swap
dup deploy-config-path vocab-file-contents
parse-fresh dup empty? [ drop ] [ first union ] if ;
: set-deploy-config ( assoc vocab -- )
>r unparse-use string-lines r>
dup deploy-config-path set-vocab-file-contents ;
: set-deploy-flag ( value key vocab -- )
[ deploy-config [ set-at ] keep ] keep set-deploy-config ;
<PRIVATE
: show ( msg -- )
#! Use primitives directly so that we can print stuff even
#! after most of the image has been stripped away
"\r\n" append stdout fwrite stdout fflush ;
: strip-init-hooks ( -- )
"Stripping startup hooks" show
"command-line" init-hooks get delete-at ;
: strip-debugger ( -- )
strip-debugger? get [
"Stripping debugger" show
"resource:extra/tools/deploy/strip-debugger.factor"
run-file
] when ;
: strip-cocoa ( -- )
"cocoa" vocab [
"Stripping unused Cocoa methods" show
"resource:extra/tools/deploy/strip-cocoa.factor"
run-file
] when ;
: strip-assoc ( retained-keys assoc -- newassoc )
swap [ nip member? ] curry assoc-subset ;
: strip-word-names ( words -- )
"Stripping word names" show
[ f over set-word-name f swap set-word-vocabulary ] each ;
: strip-word-defs ( words -- )
"Stripping unoptimized definitions from optimized words" show
[ compiled? ] subset [ f swap set-word-def ] each ;
: strip-word-props ( retain-props words -- )
"Stripping word properties" show
[
[ word-props strip-assoc f assoc-like ] keep
set-word-props
] curry* each ;
: retained-props ( -- seq )
[
"class" ,
"metaclass" ,
"slot-names" ,
deploy-ui? get [
"gestures" ,
"commands" ,
{ "+nullary+" "+listener+" "+description+" }
[ "ui.commands" lookup , ] each
] when
] { } make ;
: strip-words ( props -- )
[ word? ] instances
strip-word-props? get [ tuck strip-word-props ] [ nip ] if
strip-word-names? get [ dup strip-word-names ] when
strip-word-defs ;
USING: bit-arrays byte-arrays io.streams.nested ;
: strip-classes ( -- )
"Stripping classes" show
io-backend get [
c-reader forget
c-writer forget
] when
{ style-stream mirror enum } [ forget ] each ;
: strip-environment ( retain-globals -- )
"Stripping environment" show
strip-globals? get [
global strip-assoc 21 setenv
] [ drop ] if ;
: finish-deploy ( final-image -- )
"Finishing up" show
>r V{ } set-datastack r>
V{ } set-retainstack
V{ } set-callstack
V{ } set-namestack
V{ } set-catchstack
"Saving final image" show
[ save-image-and-exit ] call ;
SYMBOL: deploy-vocab
: set-boot-quot* ( word -- )
[
\ boot ,
init-hooks get values concat %
,
"io.backend" init-hooks get at [ \ flush , ] when
] [ ] make "Boot quotation: " write dup . flush
set-boot-quot ;
: retained-globals ( -- seq )
[
builtins ,
io-backend ,
strip-dictionary? get [
{
builtins
dictionary
inspector-hook
lexer-factory
load-vocab-hook
num-tags
num-types
tag-bits
tag-mask
tag-numbers
typemap
vocab-roots
} %
] unless
strip-prettyprint? get [
{
tab-size
margin
} %
] unless
strip-c-types? get not deploy-ui? get or [
"c-types" "alien.c-types" lookup ,
] when
deploy-ui? get [
"ui" child-vocabs
"cocoa" child-vocabs
deploy-vocab get child-vocabs 3append
global keys [ word? ] subset
swap [ >r word-vocabulary r> member? ] curry
subset %
] when
] { } make dup . ;
: normalize-strip-flags
strip-prettyprint? get [
strip-word-names? off
] unless
strip-dictionary? get [
strip-prettyprint? off
strip-word-names? off
strip-word-props? off
] unless ;
: strip ( -- )
normalize-strip-flags
strip-cocoa
strip-debugger
strip-init-hooks
deploy-vocab get vocab-main set-boot-quot*
retained-props >r
retained-globals strip-environment
r> strip-words ;
: (deploy) ( final-image vocab config -- )
#! Does the actual work of a deployment in the slave
#! stage2 image
[
[
deploy-vocab set
parse-hook get >r
parse-hook off
deploy-vocab get require
r> call
strip
finish-deploy
] [
print-error flush 1 exit
] recover
] bind ;
: do-deploy ( -- )
"output-image" get
"deploy-vocab" get
"Deploying " write dup write "..." print
dup deploy-config dup .
(deploy) ;
: (copy-lines) ( stream -- stream )
dup stream-readln [ print flush (copy-lines) ] when* ;
: copy-lines ( stream -- )
[ (copy-lines) ] [ stream-close ] [ ] cleanup ;
: boot-image-name ( -- string )
cpu dup "ppc" = [ os "-" rot 3append ] when ;
: stage2 ( vm flags -- )
[
"\"" % swap % "\" -i=boot." % cpu % ".image" %
"\"" % swap % "\" -i=boot." %
boot-image-name
% ".image" %
[ " " % % ] each
] "" make
dup print <process-stream> copy-lines ;
dup print <process-stream>
dup duplex-stream-out stream-close
copy-lines ;
: profile-string ( config -- string )
{
@ -283,5 +58,3 @@ PRIVATE>
: deploy ( vocab -- )
vm over ".image" append rot dup deploy-config deploy* ;
MAIN: do-deploy

194
extra/tools/deploy/shaker/shaker.factor Normal file
View File

@ -0,0 +1,194 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces continuations.private kernel.private init
assocs kernel vocabs words sequences memory io system arrays
continuations math definitions mirrors splitting parser classes
inspector layouts vocabs.loader prettyprint.config prettyprint
debugger io.streams.c io.streams.duplex io.files io.backend
quotations words.private tools.deploy.config ;
IN: tools.deploy.shaker
: show ( msg -- )
#! Use primitives directly so that we can print stuff even
#! after most of the image has been stripped away
"\r\n" append stdout fwrite stdout fflush ;
: strip-init-hooks ( -- )
"Stripping startup hooks" show
"command-line" init-hooks get delete-at ;
: strip-debugger ( -- )
strip-debugger? get [
"Stripping debugger" show
"resource:extra/tools/deploy/strip-debugger.factor"
run-file
] when ;
: strip-cocoa ( -- )
"cocoa" vocab [
"Stripping unused Cocoa methods" show
"resource:extra/tools/deploy/strip-cocoa.factor"
run-file
] when ;
: strip-assoc ( retained-keys assoc -- newassoc )
swap [ nip member? ] curry assoc-subset ;
: strip-word-names ( words -- )
"Stripping word names" show
[ f over set-word-name f swap set-word-vocabulary ] each ;
: strip-word-defs ( words -- )
"Stripping unoptimized definitions from optimized words" show
[ compiled? ] subset [ [ ] swap set-word-def ] each ;
: strip-word-props ( retain-props words -- )
"Stripping word properties" show
[
[ word-props strip-assoc f assoc-like ] keep
set-word-props
] curry* each ;
: retained-props ( -- seq )
[
"class" ,
"metaclass" ,
"slot-names" ,
deploy-ui? get [
"gestures" ,
"commands" ,
{ "+nullary+" "+listener+" "+description+" }
[ "ui.commands" lookup , ] each
] when
] { } make ;
: strip-words ( props -- )
[ word? ] instances
strip-word-props? get [ tuck strip-word-props ] [ nip ] if
strip-word-names? get [ dup strip-word-names ] when
strip-word-defs ;
USING: bit-arrays byte-arrays io.streams.nested ;
: strip-classes ( -- )
"Stripping classes" show
io-backend get [
c-reader forget
c-writer forget
] when
{ style-stream mirror enum } [ forget ] each ;
: strip-environment ( retain-globals -- )
"Stripping environment" show
strip-globals? get [
global strip-assoc 21 setenv
] [ drop ] if ;
: finish-deploy ( final-image -- )
"Finishing up" show
>r { } set-datastack r>
{ } set-retainstack
V{ } set-namestack
V{ } set-catchstack
"Saving final image" show
[ save-image-and-exit ] call-clear ;
SYMBOL: deploy-vocab
: set-boot-quot* ( word -- )
[
\ boot ,
init-hooks get values concat %
,
"io.backend" init-hooks get at [ \ flush , ] when
] [ ] make "Boot quotation: " write dup . flush
set-boot-quot ;
: retained-globals ( -- seq )
[
builtins ,
io-backend ,
strip-dictionary? get [
{
builtins
dictionary
inspector-hook
lexer-factory
load-vocab-hook
num-tags
num-types
tag-bits
tag-mask
tag-numbers
typemap
vocab-roots
} %
] unless
strip-prettyprint? get [
{
tab-size
margin
} %
] unless
strip-c-types? get not deploy-ui? get or [
"c-types" "alien.c-types" lookup ,
] when
deploy-ui? get [
"ui" child-vocabs
"cocoa" child-vocabs
deploy-vocab get child-vocabs 3append
global keys [ word? ] subset
swap [ >r word-vocabulary r> member? ] curry
subset %
] when
] { } make dup . ;
: normalize-strip-flags
strip-prettyprint? get [
strip-word-names? off
] unless
strip-dictionary? get [
strip-prettyprint? off
strip-word-names? off
strip-word-props? off
] unless ;
: strip ( -- )
normalize-strip-flags
strip-cocoa
strip-debugger
strip-init-hooks
deploy-vocab get vocab-main set-boot-quot*
retained-props >r
retained-globals strip-environment
r> strip-words ;
: (deploy) ( final-image vocab config -- )
#! Does the actual work of a deployment in the slave
#! stage2 image
[
[
deploy-vocab set
parse-hook get >r
parse-hook off
deploy-vocab get require
r> [ call ] when*
strip
finish-deploy
] [
print-error flush 1 exit
] recover
] bind ;
: do-deploy ( -- )
"output-image" get
"deploy-vocab" get
"Deploying " write dup write "..." print
dup deploy-config dup .
(deploy) ;
MAIN: do-deploy

3
extra/tools/interpreter/interpreter-docs.factor
View File

@ -24,9 +24,6 @@ ABOUT: "meta-interpreter"
HELP: interpreter
{ $class-description "An interpreter instance." } ;
HELP: break
{ $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ;
HELP: step
{ $values { "interpreter" interpreter } }
{ $description "Evaluates the object in the single stepper using Factor evaluation semantics:"

2
extra/tools/interpreter/interpreter-tests.factor
View File

@ -1,7 +1,7 @@
USING: tools.interpreter io io.streams.string kernel math
math.private namespaces prettyprint sequences tools.test
continuations math.parser threads arrays
tools.interpreter.debug ;
tools.interpreter.private tools.interpreter.debug ;
IN: temporary
[ "Ooops" throw ] break-hook set

29
extra/tools/interpreter/interpreter.factor
View File

@ -10,13 +10,6 @@ TUPLE: interpreter continuation ;
: <interpreter> interpreter construct-empty ;
SYMBOL: break-hook
: break ( -- )
continuation callstack
over set-continuation-call
walker-hook [ continue-with ] [ break-hook get call ] if* ;
GENERIC# restore 1 ( obj interpreter -- )
M: f restore
@ -58,6 +51,8 @@ M: pair restore
: (step-into-continuation)
continuation callstack over set-continuation-call break ;
M: word (step-into) (step-into-execute) ;
{
{ call [ (step-into-call) ] }
{ (throw) [ (step-into-call) ] }
@ -76,14 +71,6 @@ M: pair restore
"step-into" set-word-prop
] each
: (continue) ( continuation -- )
>continuation<
set-catchstack
set-namestack
set-retainstack
>r set-datastack r>
set-callstack ;
! Stepping
: change-innermost-frame ( quot interpreter -- )
interpreter-continuation [
@ -99,16 +86,8 @@ M: pair restore
: (step) ( interpreter quot -- )
swap
[ change-innermost-frame ] keep
[
set-walker-hook
interpreter-continuation (continue)
] callcc1 swap restore ;
GENERIC: (step-into) ( obj -- )
M: word (step-into) (step-into-execute) ;
M: wrapper (step-into) wrapped break ;
M: object (step-into) break ;
[ interpreter-continuation with-walker-hook ] keep
restore ;
PRIVATE>

4
extra/tools/walker/walker.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: tools.walker
USING: kernel sequences tools.interpreter ;
USING: kernel sequences continuations ;
: walk ( quot -- ) [ break ] swap append call ;
: walk ( quot -- ) \ break add* call ;

21
extra/ui/gadgets/panes/panes.factor
View File

@ -184,33 +184,12 @@ M: pane-stream make-span-stream
: apply-presentation-style ( style gadget -- style gadget )
presented [ <presentation> ] apply-style ;
TUPLE: scroll-to-me done? ;
: <scroll-to-me>
scroll-to-me construct-empty
[ set-gadget-delegate ] keep ;
: scroll-on-graft? ( gadget -- ? )
parents
[ [ pane? ] is? ] subset
[ pane-scrolls? ] contains? not ;
M: scroll-to-me graft*
dup scroll-to-me-done? [
t over set-scroll-to-me-done?
dup scroll-on-graft? [ dup scroll>gadget ] when
] unless delegate graft* ;
: apply-highlight-style ( style gadget -- style gadget )
highlight [ drop <scroll-to-me> ] apply-style ;
: <styled-label> ( style text -- gadget )
<label>
apply-foreground-style
apply-background-style
apply-font-style
apply-presentation-style
apply-highlight-style
nip ;
! Paragraph styles

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

@ -27,8 +27,8 @@ M: traceback-gadget pref-dim* drop { 300 400 } ;
[
g control-model <datastack-display> 1/2 track,
g control-model <retainstack-display> 1/2 track,
] { 1 0 } make-track 1/2 track,
g control-model <callstack-display> 1/2 track,
] { 1 0 } make-track 1/3 track,
g control-model <callstack-display> 2/3 track,
] with-gadget
] keep ;

3
extra/ui/tools/walker/walker-tests.factor
View File

@ -4,7 +4,7 @@ listener tools.test ui ui.gadgets ui.gadgets.worlds
ui.gadgets.packs vectors ui.tools ;
IN: temporary
[ ] [ <walker "walker" set ] unit-test
[ ] [ <walker> "walker" set ] unit-test
! Make sure the toolbar buttons don't throw if we're
! not actually walking.
@ -16,7 +16,6 @@ IN: temporary
[ ] [ "walker" get com-inspect ] unit-test
[ ] [ "walker" get reset-walker ] unit-test
[ ] [ "walker" get com-continue ] unit-test
[ ] [ "walker" get com-abandon ] unit-test
: <test-world> ( gadget -- world )
[ gadget, ] make-pile "Hi" f <world> ;

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

@ -5,7 +5,7 @@ ui.tools.workspace inspector kernel models namespaces
prettyprint quotations sequences threads tools.interpreter
ui.commands ui.gadgets ui.gadgets.labelled ui.gadgets.tracks
ui.gestures ui.gadgets.buttons ui.gadgets.panes
prettyprint.config prettyprint.backend ;
prettyprint.config prettyprint.backend continuations ;
IN: ui.tools.walker
TUPLE: walker model interpreter history ;

2
extra/units/imperial/imperial-tests.factor
View File

@ -1,4 +1,4 @@
USING: kernel math tools.test units.imperial ;
USING: kernel math tools.test units.imperial inverse ;
IN: temporary
[ 1 ] [ 12 inches [ feet ] undo ] unit-test

3
extra/units/si/si-tests.factor
View File

@ -1,4 +1,5 @@
USING: kernel tools.test units.si inverse ;
USING: kernel tools.test units.si inverse math.constants
math.functions units.imperial ;
IN: temporary
[ t ] [ 1 m 100 cm = ] unit-test

3
extra/units/units-tests.factor
View File

@ -1,4 +1,5 @@
USING: arrays kernel math sequences tools.test units.si units ;
USING: arrays kernel math sequences tools.test units.si
units.imperial units inverse math.functions ;
IN: temporary
[ T{ dimensioned f 3 { m } { } } ] [ 3 m ] unit-test

4
vm/Config.unix
View File

@ -1,7 +1,3 @@
#ifndef DEBUG
C_FLAGS += -fomit-frame-pointer
#endif
EXE_SUFFIX =
DLL_PREFIX = lib
DLL_EXTENSION = .a

122
vm/callstack.c
View File

@ -1,28 +1,18 @@
#include "master.h"
/* This code is very ugly. Perhaps unavoidably so. */
/* called before entry into Factor code. */
F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom)
{
stack_chain->callstack_bottom = callstack_bottom;
}
void iterate_callstack(CELL top, CELL bottom, CELL base, CALLSTACK_ITER iterator)
void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator)
{
CELL delta = (bottom - base);
#ifdef CALLSTACK_UP_P
F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1;
#define ITERATING_P (CELL)frame >= top
#else
F_STACK_FRAME *frame = (F_STACK_FRAME *)top;
#define ITERATING_P (CELL)frame < bottom
#endif
while(ITERATING_P)
while((CELL)frame >= top)
{
F_STACK_FRAME *next = REBASE_FRAME_SUCCESSOR(frame,delta);
F_STACK_FRAME *next = frame_successor(frame);
iterator(frame);
frame = next;
}
@ -30,11 +20,10 @@ void iterate_callstack(CELL top, CELL bottom, CELL base, CALLSTACK_ITER iterator
void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator)
{
CELL top = (CELL)(stack + 1);
CELL top = (CELL)FIRST_STACK_FRAME(stack);
CELL bottom = top + untag_fixnum_fast(stack->length);
CELL base = stack->bottom;
iterate_callstack(top,bottom,base,iterator);
iterate_callstack(top,bottom,iterator);
}
F_CALLSTACK *allot_callstack(CELL size)
@ -55,17 +44,13 @@ called by continuation implementation, and user code shouldn't
be calling it at all, so we leave it as it is for now. */
F_STACK_FRAME *capture_start(void)
{
#ifdef CALLSTACK_UP_P
F_STACK_FRAME *frame = stack_chain->callstack_bottom - 1;
while(frame >= stack_chain->callstack_top
&& FRAME_SUCCESSOR(frame) >= stack_chain->callstack_top)
&& frame_successor(frame) >= stack_chain->callstack_top)
{
frame = FRAME_SUCCESSOR(frame);
frame = frame_successor(frame);
}
return frame + 1;
#else
return FRAME_SUCCESSOR(stack_chain->callstack_top);
#endif
}
DEFINE_PRIMITIVE(callstack)
@ -78,36 +63,14 @@ DEFINE_PRIMITIVE(callstack)
size = 0;
F_CALLSTACK *callstack = allot_callstack(size);
callstack->bottom = (CELL)bottom;
memcpy(FIRST_STACK_FRAME(callstack),top,size);
dpush(tag_object(callstack));
}
/* If a callstack object was captured at a different base stack height than
we have now, we have to patch up the back-chain pointers. */
static F_FIXNUM delta;
void adjust_stack_frame(F_STACK_FRAME *frame)
{
FRAME_SUCCESSOR(frame) = REBASE_FRAME_SUCCESSOR(frame,delta);
}
void adjust_callstack(F_CALLSTACK *stack, CELL bottom)
{
delta = (bottom - stack->bottom);
iterate_callstack_object(stack,adjust_stack_frame);
stack->bottom = bottom;
}
DEFINE_PRIMITIVE(set_callstack)
{
F_CALLSTACK *stack = untag_callstack(dpop());
CELL bottom = (CELL)stack_chain->callstack_bottom;
if(stack->bottom != bottom)
adjust_callstack(stack,bottom);
set_callstack(stack_chain->callstack_bottom,
FIRST_STACK_FRAME(stack),
untag_fixnum_fast(stack->length),
@ -117,15 +80,6 @@ DEFINE_PRIMITIVE(set_callstack)
critical_error("Bug in set_callstack()",0);
}
/* C doesn't have closures... */
static CELL frame_count;
static CELL frame_index;
static F_ARRAY *array;
void count_stack_frame(F_STACK_FRAME *frame) {
frame_count += 2;
}
CELL frame_type(F_STACK_FRAME *frame)
{
return xt_to_compiled(frame->xt)->type;
@ -142,6 +96,11 @@ CELL frame_executing(F_STACK_FRAME *frame)
return get(literal_start);
}
F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)
{
return (F_STACK_FRAME *)((CELL)frame - frame->size);
}
CELL frame_scan(F_STACK_FRAME *frame)
{
if(frame_type(frame) == QUOTATION_TYPE)
@ -150,15 +109,21 @@ CELL frame_scan(F_STACK_FRAME *frame)
return F;
}
/* C doesn't have closures... */
static CELL frame_count;
void count_stack_frame(F_STACK_FRAME *frame)
{
frame_count += 2;
}
static CELL frame_index;
static F_ARRAY *array;
void stack_frame_to_array(F_STACK_FRAME *frame)
{
#ifdef CALLSTACK_UP_P
set_array_nth(array,frame_index++,frame_executing(frame));
set_array_nth(array,frame_index++,frame_scan(frame));
#else
set_array_nth(array,frame_index--,frame_scan(frame));
set_array_nth(array,frame_index--,frame_executing(frame));
#endif
}
DEFINE_PRIMITIVE(callstack_to_array)
@ -172,14 +137,7 @@ DEFINE_PRIMITIVE(callstack_to_array)
array = allot_array_internal(ARRAY_TYPE,frame_count);
UNREGISTER_UNTAGGED(stack);
/* frame_count is equal to the total length now */
#ifdef CALLSTACK_UP_P
frame_index = 0;
#else
frame_index = frame_count - 1;
#endif
iterate_callstack_object(stack,stack_frame_to_array);
dpush(tag_object(array));
@ -187,22 +145,15 @@ DEFINE_PRIMITIVE(callstack_to_array)
F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack)
{
#ifdef CALLSTACK_UP_P
CELL top = (CELL)(callstack + 1);
CELL bottom = top + untag_fixnum_fast(callstack->length);
CELL base = callstack->bottom;
CELL delta = (bottom - base);
F_STACK_FRAME *top = FIRST_STACK_FRAME(callstack);
CELL bottom = (CELL)top + untag_fixnum_fast(callstack->length);
F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1;
while(frame >= (F_STACK_FRAME *)top
&& REBASE_FRAME_SUCCESSOR(frame,delta) >= (F_STACK_FRAME *)top)
frame = REBASE_FRAME_SUCCESSOR(frame,delta);
while(frame >= top && frame_successor(frame) >= top)
frame = frame_successor(frame);
return frame;
#else
return FIRST_STACK_FRAME(callstack);
#endif
}
/* Some primitives implementing a limited form of callstack mutation.
@ -243,27 +194,12 @@ DEFINE_PRIMITIVE(set_innermost_stack_frame_quot)
type_check(QUOTATION_TYPE,frame_executing(inner));
CELL scan = inner->scan - inner->array;
#ifdef CALLSTACK_UP_P
CELL top = (CELL)(callstack + 1);
CELL bottom = top + untag_fixnum_fast(callstack->length);
CELL base = callstack->bottom;
CELL delta = (bottom - base);
F_STACK_FRAME *next = REBASE_FRAME_SUCCESSOR(inner,delta);
CELL offset = *(XT *)(next + 1) - inner->xt;
#else
CELL offset = inner->return_address - inner->xt;
#endif
CELL offset = FRAME_RETURN_ADDRESS(inner) - inner->xt;
inner->array = quot->array;
inner->scan = quot->array + scan;
inner->xt = quot->xt;
#ifdef CALLSTACK_UP_P
*(XT *)(next + 1) = quot->xt + offset;
#else
inner->return_address = quot->xt + offset;
#endif
FRAME_RETURN_ADDRESS(inner) = quot->xt + offset;
}

5
vm/callstack.h
View File

@ -2,12 +2,11 @@ F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom);
#define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1)
#define REBASE_FRAME_SUCCESSOR(frame,delta) (F_STACK_FRAME *)((CELL)FRAME_SUCCESSOR(frame) + delta)
typedef void (*CALLSTACK_ITER)(F_STACK_FRAME *frame);
void iterate_callstack(CELL top, CELL bottom, CELL base, CALLSTACK_ITER iterator);
void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator);
void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator);
F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame);
CELL frame_executing(F_STACK_FRAME *frame);
CELL frame_type(F_STACK_FRAME *frame);

4
vm/cpu-ppc.S
View File

@ -146,8 +146,6 @@ DEF(void,primitive_execute,(void)):
subi r14,r14,4 /* pop word from data stack */
bctr /* go */
#define SCAN_SAVE (RESERVED_SIZE + PARAM_SIZE + 4)
/* We pass a function pointer to memcpy in r6 to work around a Mac OS X ABI
limitation which would otherwise require us to do a bizzaro PC-relative
trampoline to retrieve the function address */
@ -159,8 +157,6 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi
blrl /* go */
lwz r1,0(r1) /* tear down fake stack frame */
lwz r0,LR_SAVE(r1) /* we have restored the stack; load return address */
/* load quotation scan pointer */
lwz r5,SCAN_SAVE(r1)
mtlr r0 /* prepare to return to restored callstack */
blr /* go */

2
vm/cpu-ppc.h
View File

@ -13,5 +13,3 @@ void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *me
void throw_impl(CELL quot, F_STACK_FRAME *rewind);
void lazy_jit_compile(CELL quot);
void flush_icache(CELL start, CELL len);
#define FRAME_SUCCESSOR(frame) (frame)->previous

3
vm/cpu-x86.32.S
View File

@ -44,6 +44,3 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi
ret /* return _with new stack_ */
#include "cpu-x86.S"
.section .drectve
.ascii " -export:set_callstack"

3
vm/cpu-x86.64.S
View File

@ -36,6 +36,3 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi
ret /* return _with new stack_ */
#include "cpu-x86.S"
.section .drectve
.ascii " -export:set_callstack"

12
vm/cpu-x86.S
View File

@ -64,11 +64,7 @@ DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
pop XT_REG
JUMP_QUOT /* Call the quotation */
.section .drectve
.ascii " -export:c_to_factor"
.ascii " -export:undefined"
.ascii " -export:docol_profiling"
.ascii " -export:primitive_call"
.ascii " -export:primitive_execute"
.ascii " -export:throw_impl"
.ascii " -export:lazy_jit_compile"
#ifdef WINDOWS
.section .drectve
.ascii " -export:c_to_factor"
#endif

22
vm/cpu-x86.h
View File

@ -1,24 +1,4 @@
typedef struct _F_STACK_FRAME
{
/* In compiled quotation frames, position within the array.
In compiled word frames, unused. */
CELL scan;
/* In compiled quotation frames, the quot->array slot.
In compiled word frames, unused. */
CELL array;
/* Pointer to the next stack frame; frames are chained from
the bottom on up */
struct _F_STACK_FRAME *next;
/* In all compiled frames, the XT on entry. */
XT xt;
} F_STACK_FRAME;
#define CALLSTACK_UP_P
#define FRAME_SUCCESSOR(frame) (frame)->next
#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1)
INLINE void flush_icache(CELL start, CELL len) {}

3
vm/data_gc.c
View File

@ -395,8 +395,7 @@ void collect_callstack(F_CONTEXT *stacks)
{
CELL top = (CELL)stacks->callstack_top;
CELL bottom = (CELL)stacks->callstack_bottom;
CELL base = bottom;
iterate_callstack(top,bottom,base,collect_stack_frame);
iterate_callstack(top,bottom,collect_stack_frame);
}
/* Copy roots over at the start of GC, namely various constants, stacks,

3
vm/debug.c
View File

@ -108,8 +108,7 @@ void print_callstack(void)
{
CELL bottom = (CELL)stack_chain->callstack_bottom;
CELL top = (CELL)stack_chain->callstack_top;
CELL base = bottom;
iterate_callstack(top,bottom,base,print_stack_frame);
iterate_callstack(top,bottom,print_stack_frame);
}
void dump_cell(CELL cell)

6
vm/errors.c
View File

@ -137,3 +137,9 @@ DEFINE_PRIMITIVE(throw)
uncurry(dpop());
throw_impl(dpop(),stack_chain->callstack_top);
}
DEFINE_PRIMITIVE(call_clear)
{
uncurry(dpop());
throw_impl(dpop(),stack_chain->callstack_bottom);
}

1
vm/errors.h
View File

@ -35,6 +35,7 @@ void not_implemented_error(void);
F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top);
DECLARE_PRIMITIVE(throw);
DECLARE_PRIMITIVE(call_clear);
INLINE void type_check(CELL type, CELL tagged)
{

13
vm/image.c
View File

@ -173,8 +173,6 @@ void fixup_alien(F_ALIEN *d)
d->expired = T;
}
F_FIXNUM delta;
void fixup_stack_frame(F_STACK_FRAME *frame)
{
code_fixup(&frame->xt);
@ -186,20 +184,11 @@ void fixup_stack_frame(F_STACK_FRAME *frame)
frame->scan = scan + frame->array;
}
#ifdef CALLSTACK_UP_P
F_STACK_FRAME *next = REBASE_FRAME_SUCCESSOR(frame,delta);
code_fixup((XT *)(next + 1));
#else
code_fixup(&frame->return_address);
#endif
code_fixup(&FRAME_RETURN_ADDRESS(frame));
}
void fixup_callstack_object(F_CALLSTACK *stack)
{
CELL top = (CELL)(stack + 1);
CELL bottom = top + untag_fixnum_fast(stack->length);
delta = (bottom - stack->bottom);
iterate_callstack_object(stack,fixup_stack_frame);
}

19
vm/layouts.h
View File

@ -238,6 +238,21 @@ typedef struct {
CELL header;
/* tagged */
CELL length;
/* untagged */
CELL bottom;
} F_CALLSTACK;
typedef struct
{
/* In compiled quotation frames, position within the array.
In compiled word frames, unused. */
CELL scan;
/* In compiled quotation frames, the quot->array slot.
In compiled word frames, unused. */
CELL array;
/* In all compiled frames, the XT on entry. */
XT xt;
/* Frame size in bytes */
CELL size;
} F_STACK_FRAME;

27
vm/os-linux-ppc.h
View File

@ -1,29 +1,4 @@
typedef struct _F_STACK_FRAME
{
struct _F_STACK_FRAME *previous;
/* Callee stores our LR here */
XT return_address;
/* ===== 32 bytes saved register area ===== */
CELL padding5[8];
/* ===== 16 byte local variable area ===== */
/* In compiled quotation frames, the quot->array slot.
In compiled word frames, unused. */
CELL array;
/* In compiled quotation frames, position within the array.
In compiled word frames, unused. */
CELL scan;
/* In all compiled frames, the XT on entry. */
XT xt;
/* ===== 12 byte padding to make it 16 byte aligned ===== */
CELL padding6[3];
} F_STACK_FRAME;
#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1)
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP])

36
vm/os-macosx-ppc.h
View File

@ -1,34 +1,4 @@
typedef struct _F_STACK_FRAME {
/* ===== 24 bytes reserved ===== */
struct _F_STACK_FRAME *previous;
CELL padding1;
/* Callee stores our LR here */
XT return_address;
CELL padding2;
CELL padding3;
CELL padding4;
/* ===== 32 bytes saved register area ===== */
CELL padding5[8];
/* ===== 16 byte local variable area ===== */
/* In compiled quotation frames, the quot->array slot.
In compiled word frames, unused. */
CELL array;
/* In compiled quotation frames, position within the array.
In compiled word frames, unused. */
CELL scan;
/* In all compiled frames, the XT on entry. */
XT xt;
/* ===== 12 byte padding to make it 16 byte aligned ===== */
CELL padding6[3];
} F_STACK_FRAME;
#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 2)
#define MACH_EXC_STATE_TYPE ppc_exception_state_t
#define MACH_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE
@ -41,8 +11,12 @@ typedef struct _F_STACK_FRAME {
#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__dar
#define MACH_STACK_POINTER(thr_state) (thr_state)->__r1
#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__srr0
#define UAP_PROGRAM_COUNTER(ucontext) \
MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
#else
#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->dar
#define MACH_STACK_POINTER(thr_state) (thr_state)->r1
#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->srr0
#define UAP_PROGRAM_COUNTER(ucontext) \
MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
#endif

4
vm/os-macosx-x86.32.h
View File

@ -9,8 +9,12 @@
#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
#define MACH_STACK_POINTER(thr_state) (thr_state)->__esp
#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__eip
#define UAP_PROGRAM_COUNTER(ucontext) \
MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
#else
#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
#define MACH_STACK_POINTER(thr_state) (thr_state)->esp
#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->eip
#define UAP_PROGRAM_COUNTER(ucontext) \
MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
#endif

Some files were not shown because too many files have changed in this diff Show More