Merge git://factorcode.org/git/factor
Conflicts: extra/concurrency/concurrency.factorrelease
commit
18a554ad4d
|
@ -29,7 +29,7 @@ TUPLE: no-c-type name ;
|
|||
dup string? [ (c-type) ] when
|
||||
] when ;
|
||||
|
||||
GENERIC: c-type ( name -- type )
|
||||
GENERIC: c-type ( name -- type ) foldable
|
||||
|
||||
: resolve-pointer-type ( name -- name )
|
||||
c-types get at dup string?
|
||||
|
|
|
@ -387,7 +387,7 @@ TUPLE: callback-context ;
|
|||
dup alien-callback-xt dup rot [
|
||||
init-templates
|
||||
generate-profiler-prologue
|
||||
%save-xt
|
||||
%save-word-xt
|
||||
%prologue-later
|
||||
dup alien-stack-frame [
|
||||
dup registers>objects
|
||||
|
|
|
@ -157,7 +157,7 @@ GENERIC: ' ( obj -- ptr )
|
|||
#! n is positive or zero.
|
||||
[ dup 0 > ]
|
||||
[ dup bignum-bits neg shift swap bignum-radix bitand ]
|
||||
{ } unfold ;
|
||||
[ ] unfold nip ;
|
||||
|
||||
: emit-bignum ( n -- )
|
||||
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
|
||||
|
@ -442,7 +442,7 @@ M: curry '
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: make-image ( architecture -- )
|
||||
: make-image ( arch -- )
|
||||
[
|
||||
parse-hook off
|
||||
prepare-image
|
||||
|
@ -452,6 +452,9 @@ PRIVATE>
|
|||
image get image-name write-image
|
||||
] with-scope ;
|
||||
|
||||
: my-arch ( -- arch )
|
||||
cpu dup "ppc" = [ os "-" rot 3append ] when ;
|
||||
|
||||
: make-images ( -- )
|
||||
{
|
||||
"x86.32" "x86.64" "linux-ppc" "macosx-ppc" "arm"
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: kernel vocabs vocabs.loader sequences ;
|
||||
USING: kernel vocabs vocabs.loader sequences system ;
|
||||
|
||||
{ "ui" "help" "tools" }
|
||||
[ "bootstrap." swap append vocab ] all? [
|
||||
|
|
|
@ -133,7 +133,7 @@ PRIVATE>
|
|||
>vector
|
||||
[ dup empty? not ]
|
||||
[ dup largest-class >r over delete-nth r> ]
|
||||
{ } unfold ;
|
||||
[ ] unfold nip ;
|
||||
|
||||
: class-or ( class1 class2 -- class )
|
||||
{
|
||||
|
|
|
@ -50,7 +50,12 @@ HOOK: %epilogue compiler-backend ( n -- )
|
|||
HOOK: %profiler-prologue compiler-backend ( word -- )
|
||||
|
||||
! Store word XT in stack frame
|
||||
HOOK: %save-xt compiler-backend ( -- )
|
||||
HOOK: %save-word-xt compiler-backend ( -- )
|
||||
|
||||
! Store dispatch branch XT in stack frame
|
||||
HOOK: %save-dispatch-xt compiler-backend ( -- )
|
||||
|
||||
M: object %save-dispatch-xt %save-word-xt ;
|
||||
|
||||
! Call another label
|
||||
HOOK: %call-label compiler-backend ( label -- )
|
||||
|
|
|
@ -47,6 +47,16 @@ M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap <+/-> ;
|
|||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
: call-cell ( -- )
|
||||
! Compute return address; we skip 3 instructions
|
||||
LR PC 8 ADD
|
||||
! Load target address
|
||||
R12 PC 0 <+> LDR
|
||||
! Jump to target address
|
||||
R12 BX
|
||||
! The target address
|
||||
0 , ;
|
||||
|
||||
M: arm-backend load-indirect ( obj reg -- )
|
||||
tuck load-cell rc-absolute-cell rel-literal
|
||||
dup 0 <+> LDR ;
|
||||
|
@ -66,9 +76,12 @@ M: immediate load-literal
|
|||
M: arm-backend stack-frame ( n -- i )
|
||||
factor-area-size + 8 align ;
|
||||
|
||||
M: arm-backend %save-xt ( -- )
|
||||
M: arm-backend %save-word-xt ( -- )
|
||||
R12 PC 9 cells SUB ;
|
||||
|
||||
M: arm-backend %save-dispatch-xt ( -- )
|
||||
R12 PC 2 cells SUB ;
|
||||
|
||||
M: arm-backend %prologue ( n -- )
|
||||
SP SP pick SUB
|
||||
R11 over MOV
|
||||
|
@ -98,30 +111,36 @@ M: arm-backend %call-label ( label -- ) BL ;
|
|||
|
||||
M: arm-backend %jump-label ( label -- ) B ;
|
||||
|
||||
: %prepare-primitive ( word -- )
|
||||
: %prepare-primitive ( -- )
|
||||
#! Save stack pointer to stack_chain->callstack_top, load XT
|
||||
R1 SP MOV
|
||||
T{ temp-reg } load-literal
|
||||
R12 R12 word-xt-offset <+> LDR ;
|
||||
R1 SP MOV ;
|
||||
|
||||
M: arm-backend %call-primitive ( word -- )
|
||||
%prepare-primitive R12 BLX ;
|
||||
%prepare-primitive
|
||||
call-cell rc-absolute-cell rel-word ;
|
||||
|
||||
M: arm-backend %jump-primitive ( word -- )
|
||||
%prepare-primitive R12 BX ;
|
||||
%prepare-primitive
|
||||
! Load target address
|
||||
R12 PC 0 <+> LDR
|
||||
! Jump to target address
|
||||
R12 BX
|
||||
! The target address
|
||||
0 , rc-absolute-cell rel-word ;
|
||||
|
||||
M: arm-backend %jump-t ( label -- )
|
||||
"flag" operand f v>operand CMP NE B ;
|
||||
|
||||
: (%dispatch) ( word-table# reg -- )
|
||||
: (%dispatch) ( word-table# -- )
|
||||
#! Load jump table target address into reg.
|
||||
"scratch" operand PC "n" operand 1 <LSR> ADD
|
||||
"scratch" operand 0 <+> LDR
|
||||
rc-indirect-arm rel-dispatch ;
|
||||
"scratch" operand dup 0 <+> LDR
|
||||
rc-indirect-arm rel-dispatch
|
||||
"scratch" operand dup compiled-header-size ADD ;
|
||||
|
||||
M: arm-backend %call-dispatch ( word-table# -- )
|
||||
[
|
||||
"scratch" operand (%dispatch)
|
||||
(%dispatch)
|
||||
"scratch" operand BLX
|
||||
] H{
|
||||
{ +input+ { { f "n" } } }
|
||||
|
@ -131,7 +150,8 @@ M: arm-backend %call-dispatch ( word-table# -- )
|
|||
M: arm-backend %jump-dispatch ( word-table# -- )
|
||||
[
|
||||
%epilogue-later
|
||||
PC (%dispatch)
|
||||
(%dispatch)
|
||||
"scratch" operand BX
|
||||
] H{
|
||||
{ +input+ { { f "n" } } }
|
||||
{ +scratch+ { { f "scratch" } } }
|
||||
|
@ -259,14 +279,7 @@ M: arm-backend %prepare-alien-invoke
|
|||
rs-reg R12 12 <+> STR ;
|
||||
|
||||
M: arm-backend %alien-invoke ( symbol dll -- )
|
||||
! Load target address
|
||||
R12 PC 4 <+> LDR
|
||||
! Store address of next instruction in LR
|
||||
LR PC 4 ADD
|
||||
! Jump to target address
|
||||
R12 BX
|
||||
! The target address
|
||||
0 , rc-absolute rel-dlsym ;
|
||||
call-cell rc-absolute-cell rel-dlsym ;
|
||||
|
||||
M: arm-backend %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
|
|
|
@ -76,7 +76,7 @@ M: ppc-backend load-indirect ( obj reg -- )
|
|||
[ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
|
||||
dup 0 LWZ ;
|
||||
|
||||
M: ppc-backend %save-xt ( -- )
|
||||
M: ppc-backend %save-word-xt ( -- )
|
||||
0 11 LOAD32 rc-absolute-ppc-2/2 rel-current-word ;
|
||||
|
||||
M: ppc-backend %prologue ( n -- )
|
||||
|
|
|
@ -44,7 +44,7 @@ M: immediate load-literal v>operand swap v>operand MOV ;
|
|||
M: x86-backend stack-frame ( n -- i )
|
||||
3 cells + 16 align cell - ;
|
||||
|
||||
M: x86-backend %save-xt ( -- )
|
||||
M: x86-backend %save-word-xt ( -- )
|
||||
xt-reg 0 MOV rc-absolute-cell rel-current-word ;
|
||||
|
||||
: factor-area-size 4 cells ;
|
||||
|
|
|
@ -60,7 +60,7 @@ GENERIC: generate-node ( node -- next )
|
|||
[
|
||||
init-templates
|
||||
generate-profiler-prologue
|
||||
%save-xt
|
||||
%save-word-xt
|
||||
%prologue-later
|
||||
current-label-start define-label
|
||||
current-label-start resolve-label
|
||||
|
@ -189,7 +189,7 @@ M: #if generate-node
|
|||
gensym [
|
||||
rot [
|
||||
copy-templates
|
||||
%save-xt
|
||||
%save-dispatch-xt
|
||||
%prologue-later
|
||||
[ generate-nodes ] with-node-iterator
|
||||
] generate-1
|
||||
|
|
|
@ -7,7 +7,7 @@ ARTICLE: "file-streams" "Reading and writing files"
|
|||
{ $subsection <file-writer> }
|
||||
{ $subsection <file-appender> }
|
||||
"Pathname manipulation:"
|
||||
{ $subsection parent-dir }
|
||||
{ $subsection parent-directory }
|
||||
{ $subsection file-name }
|
||||
{ $subsection last-path-separator }
|
||||
{ $subsection path+ }
|
||||
|
@ -101,10 +101,10 @@ HELP: file-modified
|
|||
{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
|
||||
{ $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ;
|
||||
|
||||
HELP: parent-dir
|
||||
HELP: parent-directory
|
||||
{ $values { "path" "a pathname string" } { "parent" "a pathname string" } }
|
||||
{ $description "Strips the last component off a pathname." }
|
||||
{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-dir print" "/etc" } } ;
|
||||
{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-directory print" "/etc" } } ;
|
||||
|
||||
HELP: file-name
|
||||
{ $values { "path" "a pathname string" } { "string" string } }
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.files
|
||||
USING: io.backend io.files.private hashtables kernel math memory
|
||||
namespaces sequences strings arrays definitions system
|
||||
USING: io.backend io.files.private io hashtables kernel math
|
||||
memory namespaces sequences strings arrays definitions system
|
||||
combinators splitting ;
|
||||
|
||||
HOOK: <file-reader> io-backend ( path -- stream )
|
||||
|
@ -58,13 +58,16 @@ M: object root-directory? ( path -- ? ) "/" = ;
|
|||
|
||||
TUPLE: no-parent-directory path ;
|
||||
|
||||
: parent-dir ( path -- parent )
|
||||
: no-parent-directory ( path -- * )
|
||||
\ no-parent-directory construct-boa throw ;
|
||||
|
||||
: parent-directory ( path -- parent )
|
||||
{
|
||||
{ [ dup root-directory? ] [ ] }
|
||||
{ [ dup "/\\" split ".." over member? "." rot member? or ]
|
||||
[ \ no-parent-directory construct-boa throw ] }
|
||||
[ no-parent-directory ] }
|
||||
{ [ t ] [ dup last-path-separator
|
||||
[ 1+ head ] [ 2drop "." ] if ] }
|
||||
[ 1+ head ] [ 2drop "." ] if ] }
|
||||
} cond ;
|
||||
|
||||
: file-name ( path -- string )
|
||||
|
@ -72,7 +75,7 @@ TUPLE: no-parent-directory path ;
|
|||
[ 1+ tail ] [ drop ] if ;
|
||||
|
||||
: resource-path ( path -- newpath )
|
||||
\ resource-path get [ image parent-dir ] unless*
|
||||
\ resource-path get [ image parent-directory ] unless*
|
||||
swap path+ ;
|
||||
|
||||
: ?resource-path ( path -- newpath )
|
||||
|
@ -86,7 +89,7 @@ TUPLE: no-parent-directory path ;
|
|||
{ [ dup empty? ] [ ] }
|
||||
{ [ dup exists? ] [ ] }
|
||||
{ [ t ] [
|
||||
dup parent-dir make-directories
|
||||
dup parent-directory make-directories
|
||||
dup make-directory
|
||||
] }
|
||||
} cond drop ;
|
||||
|
@ -103,3 +106,18 @@ M: pathname <=> [ pathname-string ] compare ;
|
|||
{ [ wince? ] [ "" resource-path ] }
|
||||
{ [ unix? ] [ "HOME" os-env ] }
|
||||
} cond ;
|
||||
|
||||
: copy-file ( from to -- )
|
||||
dup parent-directory make-directories
|
||||
<file-writer> [
|
||||
stdio get swap
|
||||
<file-reader> [
|
||||
stdio get swap stream-copy
|
||||
] with-stream
|
||||
] with-stream ;
|
||||
|
||||
: copy-directory ( from to -- )
|
||||
dup make-directories
|
||||
>r dup directory swap r> [
|
||||
>r >r first r> over path+ r> rot path+ copy-file
|
||||
] 2curry each ;
|
||||
|
|
|
@ -86,7 +86,7 @@ SYMBOL: stdio
|
|||
presented associate format ;
|
||||
|
||||
: lines ( stream -- seq )
|
||||
[ [ readln dup ] [ ] { } unfold ] with-stream ;
|
||||
[ [ readln dup ] [ ] [ drop ] unfold ] with-stream ;
|
||||
|
||||
: contents ( stream -- str )
|
||||
2048 <sbuf> [ stream-copy ] keep >string ;
|
||||
|
|
|
@ -60,6 +60,8 @@ $nl
|
|||
"A pair of utility words built from " { $link 2apply } ":"
|
||||
{ $subsection both? }
|
||||
{ $subsection either? }
|
||||
"A looping combinator:"
|
||||
{ $subsection while }
|
||||
"Quotations can be composed using efficient quotation-specific operations:"
|
||||
{ $subsection curry }
|
||||
{ $subsection 2curry }
|
||||
|
@ -538,3 +540,15 @@ HELP: 3compose
|
|||
}
|
||||
"However, " { $link 3compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations."
|
||||
} ;
|
||||
|
||||
HELP: while
|
||||
{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "quot" "a quotation" } { "tail" "a quotation" } }
|
||||
{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "quot" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
|
||||
{ $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used."
|
||||
$nl
|
||||
"Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:"
|
||||
{ $code
|
||||
"[ P ] [ Q ] [ T ] while"
|
||||
"[ P ] [ Q ] [ ] while T"
|
||||
}
|
||||
"However, depending on the stack effects of " { $snippet "pred" } " and " { $snippet "quot" } ", the " { $snippet "tail" } " quotation might need to be non-empty in order to balance out the stack effect of branches for stack effect inference." } ;
|
||||
|
|
|
@ -16,29 +16,3 @@ math strings combinators ;
|
|||
pusher >r each-object r> >array ; inline
|
||||
|
||||
: save ( -- ) image save-image ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: intern-objects ( predicate -- )
|
||||
instances
|
||||
dup H{ } clone [ [ ] cache ] curry map
|
||||
become ; inline
|
||||
|
||||
: prepare-compress-image ( -- seq )
|
||||
[ sbuf? ] instances [ underlying ] map ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: compress-image ( -- )
|
||||
prepare-compress-image "bad-strings" [
|
||||
[
|
||||
{
|
||||
{ [ dup quotation? ] [ t ] }
|
||||
{ [ dup wrapper? ] [ t ] }
|
||||
{ [ dup fixnum? ] [ f ] }
|
||||
{ [ dup number? ] [ t ] }
|
||||
{ [ dup string? ] [ dup "bad-strings" get memq? not ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond nip
|
||||
] intern-objects
|
||||
] with-variable ;
|
||||
|
|
|
@ -5,7 +5,7 @@ USING: alien arrays generic hashtables inference.dataflow
|
|||
inference.class kernel assocs math math.private kernel.private
|
||||
sequences words parser vectors strings sbufs io namespaces
|
||||
assocs quotations sequences.private io.binary io.crc32
|
||||
io.buffers io.streams.string layouts splitting math.intervals
|
||||
io.streams.string layouts splitting math.intervals
|
||||
math.floats.private tuples tuples.private classes
|
||||
optimizer.def-use optimizer.backend optimizer.pattern-match
|
||||
float-arrays combinators.private ;
|
||||
|
@ -148,5 +148,3 @@ float-arrays combinators.private ;
|
|||
\ >le { { fixnum bignum } fixnum } "specializer" set-word-prop
|
||||
|
||||
\ >be { { fixnum bignum } fixnum } "specializer" set-word-prop
|
||||
|
||||
\ search-buffer-until { fixnum fixnum simple-alien string } "specializer" set-word-prop
|
||||
|
|
|
@ -127,8 +127,9 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
|
|||
{ $subsection 2reduce }
|
||||
"Mapping:"
|
||||
{ $subsection map }
|
||||
{ $subsection accumulate }
|
||||
{ $subsection 2map }
|
||||
{ $subsection accumulate }
|
||||
{ $subsection unfold }
|
||||
"Filtering:"
|
||||
{ $subsection push-if }
|
||||
{ $subsection subset } ;
|
||||
|
@ -230,6 +231,7 @@ $nl
|
|||
{ $subsection "sequences-tests" }
|
||||
{ $subsection "sequences-search" }
|
||||
{ $subsection "sequences-comparing" }
|
||||
{ $subsection "sequences-split" }
|
||||
{ $subsection "sequences-destructive" }
|
||||
{ $subsection "sequences-stacks" }
|
||||
"For inner loops:"
|
||||
|
@ -961,3 +963,13 @@ HELP: supremum
|
|||
{ $values { "seq" "a sequence of real numbers" } { "n" "a number" } }
|
||||
{ $description "Outputs the greatest element of " { $snippet "seq" } "." }
|
||||
{ $errors "Throws an error if the sequence is empty." } ;
|
||||
|
||||
HELP: unfold
|
||||
{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "quot" "a quotation with stack effect " { $snippet "( -- obj )" } } { "tail" "a quotation" } { "seq" "a sequence" } }
|
||||
{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence at the end." }
|
||||
{ $examples
|
||||
"The following example divides a number by two until we reach zero, and accumulates intermediate results:"
|
||||
{ $example "1337 [ dup 0 > ] [ 2/ dup ] [ ] unfold nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" }
|
||||
"The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link unfold } " call:"
|
||||
{ $unchecked-example "[ 10 random dup 1 > ] [ ] [ drop ] unfold ." "{ 8 2 2 9 }" }
|
||||
} ;
|
||||
|
|
|
@ -414,12 +414,10 @@ PRIVATE>
|
|||
: interleave ( seq between quot -- )
|
||||
[ (interleave) ] 2curry iterate-seq 2each ; inline
|
||||
|
||||
: unfold ( obj pred quot exemplar -- seq )
|
||||
[
|
||||
10 swap new-resizable [
|
||||
[ push ] curry compose [ drop ] while
|
||||
] keep
|
||||
] keep like ; inline
|
||||
: unfold ( pred quot tail -- seq )
|
||||
V{ } clone [
|
||||
swap >r [ push ] curry compose r> while
|
||||
] keep { } like ; inline
|
||||
|
||||
: index ( obj seq -- n )
|
||||
[ = ] curry* find drop ;
|
||||
|
|
|
@ -107,7 +107,7 @@ M: tuple equal?
|
|||
[ dup , delegate (delegates) ] when* ;
|
||||
|
||||
: delegates ( obj -- seq )
|
||||
[ dup ] [ [ delegate ] keep ] { } unfold ;
|
||||
[ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
|
||||
|
||||
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
|
||||
|
||||
|
|
|
@ -1,16 +1,12 @@
|
|||
USING: tools.deploy.config ;
|
||||
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? t }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ "bundle-name" "Cellular Automata.app" }
|
||||
{ deploy-name "Cellular Automata" }
|
||||
}
|
||||
|
|
|
@ -1,13 +1,12 @@
|
|||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ 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? t }
|
||||
{ "bundle-name" "Boids.app" }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-name "Boids" }
|
||||
}
|
||||
|
|
|
@ -1,12 +1,12 @@
|
|||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ strip-word-props? t }
|
||||
{ strip-word-names? t }
|
||||
{ strip-dictionary? t }
|
||||
{ strip-debugger? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-compiled? t }
|
||||
{ deploy-io? t }
|
||||
{ deploy-ui? t }
|
||||
{ "bundle-name" "Bunny.app" }
|
||||
{ deploy-io 3 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-name "Bunny" }
|
||||
}
|
||||
|
|
|
@ -0,0 +1,12 @@
|
|||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ deploy-ui? t }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-name "Catalyst Talk" }
|
||||
}
|
|
@ -0,0 +1,12 @@
|
|||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ deploy-ui? t }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-reflection 2 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ "bundle-name" "cfdg.models.flower6.app" }
|
||||
}
|
|
@ -1,12 +1,12 @@
|
|||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ strip-word-props? t }
|
||||
{ strip-word-names? t }
|
||||
{ strip-dictionary? t }
|
||||
{ strip-debugger? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-compiled? t }
|
||||
{ deploy-io? f }
|
||||
{ deploy-ui? t }
|
||||
{ "bundle-name" "Color Picker.app" }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-name "Color Picker" }
|
||||
}
|
||||
|
|
|
@ -60,7 +60,7 @@ PRIVATE>
|
|||
(mailbox-block-if-empty)
|
||||
[ dup mailbox-empty? ]
|
||||
[ dup mailbox-data pop-front ]
|
||||
{ } unfold ;
|
||||
[ ] unfold nip ;
|
||||
|
||||
: mailbox-get-all ( mailbox -- array )
|
||||
f mailbox-get-all* ;
|
||||
|
|
|
@ -5,7 +5,7 @@ sequences combinators.lib assocs system sorting math.parser ;
|
|||
IN: contributors
|
||||
|
||||
: changelog ( -- authors )
|
||||
image parent-dir cd
|
||||
image parent-directory cd
|
||||
"git-log --pretty=format:%an" <process-stream> lines ;
|
||||
|
||||
: patch-counts ( authors -- assoc )
|
||||
|
|
|
@ -4,8 +4,8 @@ IN: editors
|
|||
ARTICLE: "editor" "Editor integration"
|
||||
"Factor development is best done with one of the supported editors; this allows you to quickly jump to definitions from the Factor environment."
|
||||
{ $subsection edit }
|
||||
"Depending on the editor you are using, you must load one of the child vocabularies of the " { $vocab-link "editors" } " vocabulary, for example " { $vocab-link "editors.emacs" } "."
|
||||
$nl
|
||||
"Depending on the editor you are using, you must load one of the child vocabularies of the " { $vocab-link "editors" } " vocabulary, for example " { $vocab-link "editors.emacs" } ", for example:"
|
||||
{ $code "USE: editors.emacs" }
|
||||
"Editor integration vocabularies store a quotation in a global variable when loaded:"
|
||||
{ $subsection edit-hook }
|
||||
"If a syntax error was thrown while loading a source file, you can jump to the location of the error in your editor:"
|
||||
|
|
|
@ -1,13 +1,12 @@
|
|||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ strip-word-props? t }
|
||||
{ strip-word-names? f }
|
||||
{ strip-dictionary? t }
|
||||
{ strip-debugger? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-compiled? t }
|
||||
{ deploy-io? f }
|
||||
{ deploy-ui? t }
|
||||
{ strip-prettyprint? f }
|
||||
{ "bundle-name" "Gesture Logger.app" }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-reflection 3 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-name "Gesture Logger" }
|
||||
}
|
||||
|
|
|
@ -1,17 +1,12 @@
|
|||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ strip-io? t }
|
||||
{ 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? t }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ "bundle-name" "Golden Section.app" }
|
||||
{ deploy-name "Golden Section" }
|
||||
}
|
||||
|
|
|
@ -1,16 +1,13 @@
|
|||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ strip-prettyprint? t }
|
||||
{ strip-globals? t }
|
||||
{ strip-word-props? t }
|
||||
{ strip-word-names? f }
|
||||
{ strip-dictionary? t }
|
||||
{ strip-debugger? t }
|
||||
{ strip-c-types? t }
|
||||
H{
|
||||
{ deploy-math? t }
|
||||
{ deploy-compiled? t }
|
||||
{ deploy-io? f }
|
||||
{ deploy-ui? t }
|
||||
{ deploy-reflection 2 }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-word-defs? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ "bundle-name" "Hello World.app" }
|
||||
{ deploy-ui? t }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-name "Hello world" }
|
||||
{ deploy-c-types? f }
|
||||
}
|
||||
|
|
|
@ -1,15 +1,13 @@
|
|||
USING: tools.deploy.config ;
|
||||
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 }
|
||||
H{
|
||||
{ deploy-math? f }
|
||||
{ deploy-compiled? f }
|
||||
{ deploy-io? f }
|
||||
{ deploy-ui? f }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-name "Hello world (console)" }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-c-types? f }
|
||||
{ deploy-compiler? f }
|
||||
{ deploy-io 2 }
|
||||
{ deploy-ui? f }
|
||||
{ deploy-reflection 1 }
|
||||
}
|
||||
|
|
|
@ -14,7 +14,7 @@ M: link uses
|
|||
collect-elements [ \ f or ] map ;
|
||||
|
||||
: help-path ( topic -- seq )
|
||||
[ dup ] [ [ article-parent ] keep ] { } unfold 1 tail ;
|
||||
[ dup ] [ [ article-parent ] keep ] [ ] unfold nip 1 tail ;
|
||||
|
||||
: set-article-parents ( parent article -- )
|
||||
article-children [ set-article-parent ] curry* each ;
|
||||
|
|
|
@ -88,7 +88,7 @@ DEFER: <% delimiter
|
|||
] assert-depth drop ;
|
||||
|
||||
: run-relative-template-file ( filename -- )
|
||||
file get source-file-path parent-dir
|
||||
file get source-file-path parent-directory
|
||||
swap path+ run-template-file ;
|
||||
|
||||
: template-convert ( infile outfile -- )
|
||||
|
|
|
@ -4,7 +4,7 @@
|
|||
USING: kernel math sequences kernel.private namespaces arrays
|
||||
io io.files splitting io.binary math.functions vectors
|
||||
quotations combinators.private ;
|
||||
IN: universal-machine
|
||||
IN: icfp.2006
|
||||
|
||||
SYMBOL: regs
|
||||
SYMBOL: arrays
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.buffers
|
||||
USING: alien alien.syntax kernel kernel.private libc math
|
||||
sequences strings ;
|
||||
sequences strings hints ;
|
||||
|
||||
TUPLE: buffer size ptr fill pos ;
|
||||
|
||||
|
@ -54,6 +54,8 @@ TUPLE: buffer size ptr fill pos ;
|
|||
: search-buffer-until ( start end alien separators -- n )
|
||||
[ >r swap alien-unsigned-1 r> memq? ] 2curry find* drop ;
|
||||
|
||||
HINTS: search-buffer-until { fixnum fixnum simple-alien string } ;
|
||||
|
||||
: finish-buffer-until ( buffer n -- string separator )
|
||||
[
|
||||
over buffer-pos -
|
|
@ -12,7 +12,10 @@ GENERIC: protocol-family ( addrspec -- af )
|
|||
|
||||
GENERIC: sockaddr-type ( addrspec -- type )
|
||||
|
||||
GENERIC: make-sockaddr ( addrspec -- sockaddr type )
|
||||
GENERIC: make-sockaddr ( addrspec -- sockaddr )
|
||||
|
||||
: make-sockaddr/size ( addrspec -- sockaddr size )
|
||||
dup make-sockaddr swap sockaddr-type heap-size ;
|
||||
|
||||
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
|
||||
|
||||
|
@ -36,16 +39,15 @@ M: inet4 address-size drop 4 ;
|
|||
|
||||
M: inet4 protocol-family drop PF_INET ;
|
||||
|
||||
M: inet4 sockaddr-type drop "sockaddr-in" ;
|
||||
M: inet4 sockaddr-type drop "sockaddr-in" c-type ;
|
||||
|
||||
M: inet4 make-sockaddr ( inet -- sockaddr type )
|
||||
M: inet4 make-sockaddr ( inet -- sockaddr )
|
||||
"sockaddr-in" <c-object>
|
||||
AF_INET over set-sockaddr-in-family
|
||||
over inet4-port htons over set-sockaddr-in-port
|
||||
over inet4-host
|
||||
"0.0.0.0" or
|
||||
rot inet-pton *uint over set-sockaddr-in-addr
|
||||
"sockaddr-in" ;
|
||||
rot inet-pton *uint over set-sockaddr-in-addr ;
|
||||
|
||||
M: inet4 parse-sockaddr
|
||||
>r dup sockaddr-in-addr <uint> r> inet-ntop
|
||||
|
@ -65,15 +67,14 @@ M: inet6 address-size drop 16 ;
|
|||
|
||||
M: inet6 protocol-family drop PF_INET6 ;
|
||||
|
||||
M: inet6 sockaddr-type drop "sockaddr-in6" ;
|
||||
M: inet6 sockaddr-type drop "sockaddr-in6" c-type ;
|
||||
|
||||
M: inet6 make-sockaddr ( inet -- sockaddr type )
|
||||
M: inet6 make-sockaddr ( inet -- sockaddr )
|
||||
"sockaddr-in6" <c-object>
|
||||
AF_INET6 over set-sockaddr-in6-family
|
||||
over inet6-port htons over set-sockaddr-in6-port
|
||||
over inet6-host "::" or
|
||||
rot inet-pton over set-sockaddr-in6-addr
|
||||
"sockaddr-in6" ;
|
||||
rot inet-pton over set-sockaddr-in6-addr ;
|
||||
|
||||
M: inet6 parse-sockaddr
|
||||
>r dup sockaddr-in6-addr r> inet-ntop
|
||||
|
@ -97,7 +98,7 @@ M: f parse-sockaddr nip ;
|
|||
: parse-addrinfo-list ( addrinfo -- seq )
|
||||
[ dup ]
|
||||
[ dup addrinfo-next swap addrinfo>addrspec ]
|
||||
{ } unfold [ ] subset ;
|
||||
[ ] unfold nip [ ] subset ;
|
||||
|
||||
M: object resolve-host ( host serv passive? -- seq )
|
||||
>r dup integer? [ number>string ] when
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
USING: tools.test io.files ;
|
||||
IN: temporary
|
||||
|
||||
[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-dir ] unit-test
|
||||
[ "/etc/" ] [ "/etc/passwd" parent-dir ] unit-test
|
||||
[ "/" ] [ "/etc/" parent-dir ] unit-test
|
||||
[ "/" ] [ "/etc" parent-dir ] unit-test
|
||||
[ "/" ] [ "/" parent-dir ] unit-test
|
||||
[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test
|
||||
[ "/etc/" ] [ "/etc/passwd" parent-directory ] unit-test
|
||||
[ "/" ] [ "/etc/" parent-directory ] unit-test
|
||||
[ "/" ] [ "/etc" parent-directory ] unit-test
|
||||
[ "/" ] [ "/" parent-directory ] unit-test
|
||||
|
|
|
@ -45,9 +45,9 @@ M: connect-task task-container drop write-tasks get-global ;
|
|||
[ swap <connect-task> add-io-task stop ] callcc0 drop ;
|
||||
|
||||
M: unix-io (client) ( addrspec -- stream )
|
||||
dup make-sockaddr >r >r
|
||||
dup make-sockaddr/size >r >r
|
||||
protocol-family SOCK_STREAM socket-fd
|
||||
dup r> r> heap-size connect
|
||||
dup r> r> connect
|
||||
zero? err_no EINPROGRESS = or [
|
||||
dup init-client-socket
|
||||
dup handle>duplex-stream
|
||||
|
@ -92,7 +92,7 @@ USE: io.sockets
|
|||
: server-fd ( addrspec type -- fd )
|
||||
>r dup protocol-family r> socket-fd
|
||||
dup init-server-socket
|
||||
dup rot make-sockaddr heap-size bind
|
||||
dup rot make-sockaddr/size bind
|
||||
zero? [ dup close (io-error) ] unless ;
|
||||
|
||||
M: unix-io <server> ( addrspec -- stream )
|
||||
|
@ -190,20 +190,19 @@ M: send-task task-container drop write-tasks get ;
|
|||
|
||||
M: unix-io send ( packet addrspec datagram -- )
|
||||
3dup check-datagram-send
|
||||
[ >r make-sockaddr heap-size r> wait-send ] keep
|
||||
[ >r make-sockaddr/size r> wait-send ] keep
|
||||
pending-error ;
|
||||
|
||||
M: local protocol-family drop PF_UNIX ;
|
||||
|
||||
M: local sockaddr-type drop "sockaddr-un" ;
|
||||
M: local sockaddr-type drop "sockaddr-un" c-type ;
|
||||
|
||||
M: local make-sockaddr
|
||||
local-path
|
||||
dup length 1 + max-un-path > [ "Path too long" throw ] when
|
||||
"sockaddr-un" <c-object>
|
||||
AF_UNIX over set-sockaddr-un-family
|
||||
dup sockaddr-un-path rot string>char-alien dup length memcpy
|
||||
"sockaddr-un" ;
|
||||
dup sockaddr-un-path rot string>char-alien dup length memcpy ;
|
||||
|
||||
M: local parse-sockaddr
|
||||
drop
|
||||
|
|
|
@ -153,7 +153,7 @@ M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ;
|
|||
|
||||
: do-connect ( addrspec -- socket )
|
||||
[ tcp-socket dup ] keep
|
||||
make-sockaddr heap-size
|
||||
make-sockaddr/size
|
||||
f f f f windows.winsock:WSAConnect zero? [
|
||||
winsock-error-string throw
|
||||
] unless ;
|
||||
|
@ -227,7 +227,7 @@ M: windows-ce-io send ( packet addrspec datagram -- )
|
|||
[ windows.winsock:set-WSABUF-len ] keep
|
||||
[ windows.winsock:set-WSABUF-buf ] keep
|
||||
|
||||
rot make-sockaddr heap-size
|
||||
rot make-sockaddr/size
|
||||
>r >r 1 0 <uint> 0 r> r> f f
|
||||
windows.winsock:WSASendTo zero? [
|
||||
winsock-error-string throw
|
||||
|
|
|
@ -29,8 +29,7 @@ TUPLE: ConnectEx-args port
|
|||
s* name* namelen* lpSendBuffer* dwSendDataLength*
|
||||
lpdwBytesSent* lpOverlapped* ptr* ;
|
||||
|
||||
: init-connect ( sockaddr sockaddr-name ConnectEx -- )
|
||||
>r heap-size r>
|
||||
: init-connect ( sockaddr size ConnectEx -- )
|
||||
[ set-ConnectEx-args-namelen* ] keep
|
||||
[ set-ConnectEx-args-name* ] keep
|
||||
f over set-ConnectEx-args-lpSendBuffer*
|
||||
|
@ -55,7 +54,7 @@ TUPLE: ConnectEx-args port
|
|||
M: windows-nt-io (client) ( addrspec -- duplex-stream )
|
||||
[
|
||||
\ ConnectEx-args construct-empty
|
||||
over make-sockaddr pick init-connect
|
||||
over make-sockaddr/size pick init-connect
|
||||
over tcp-socket over set-ConnectEx-args-s*
|
||||
dup ConnectEx-args-s* add-completion
|
||||
dup ConnectEx-args-s* get-ConnectEx-ptr over set-ConnectEx-args-ptr*
|
||||
|
@ -229,9 +228,9 @@ TUPLE: WSASendTo-args port
|
|||
>r delegate port-handle delegate win32-file-handle r>
|
||||
set-WSASendTo-args-s*
|
||||
] keep [
|
||||
>r make-sockaddr >r
|
||||
>r make-sockaddr/size >r
|
||||
malloc-byte-array dup free-always
|
||||
r> heap-size r>
|
||||
r> r>
|
||||
[ set-WSASendTo-args-iToLen* ] keep
|
||||
set-WSASendTo-args-lpTo*
|
||||
] keep [
|
||||
|
|
|
@ -1,14 +1,14 @@
|
|||
USING: io.files kernel tools.test ;
|
||||
IN: temporary
|
||||
|
||||
[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-dir ] unit-test
|
||||
[ "c:\\" ] [ "c:\\foo\\" parent-dir ] unit-test
|
||||
[ "c:\\" ] [ "c:\\foo" parent-dir ] unit-test
|
||||
[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
|
||||
[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
|
||||
[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test
|
||||
! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing
|
||||
[ "c:\\" ] [ "c:\\" parent-dir ] unit-test
|
||||
[ "Z:\\" ] [ "Z:\\" parent-dir ] unit-test
|
||||
[ "c:" ] [ "c:" parent-dir ] unit-test
|
||||
[ "Z:" ] [ "Z:" parent-dir ] unit-test
|
||||
[ "c:\\" ] [ "c:\\" parent-directory ] unit-test
|
||||
[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test
|
||||
[ "c:" ] [ "c:" parent-directory ] unit-test
|
||||
[ "Z:" ] [ "Z:" parent-directory ] unit-test
|
||||
[ t ] [ "c:\\" root-directory? ] unit-test
|
||||
[ t ] [ "Z:\\" root-directory? ] unit-test
|
||||
[ f ] [ "c:\\foo" root-directory? ] unit-test
|
||||
|
|
|
@ -175,7 +175,7 @@ USE: windows.winsock
|
|||
: server-fd ( addrspec type -- fd )
|
||||
>r dup protocol-family r> open-socket
|
||||
dup close-socket-later
|
||||
dup rot make-sockaddr heap-size bind socket-error ;
|
||||
dup rot make-sockaddr/size bind socket-error ;
|
||||
|
||||
USE: namespaces
|
||||
|
||||
|
|
|
@ -1 +0,0 @@
|
|||
lint refactor
|
|
@ -1 +1 @@
|
|||
L-system explorer
|
||||
Lindenmayer system explorer
|
||||
|
|
|
@ -1,13 +1,13 @@
|
|||
USING: tools.deploy ;
|
||||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ 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? t }
|
||||
{ "bundle-name" "Lindenmayer Systems.app" }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-reflection 2 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? t }
|
||||
{ deploy-word-defs? t }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-name "Lindenmayer System Explorer" }
|
||||
}
|
||||
|
|
|
@ -52,7 +52,6 @@ VARS: buffer-start buffer-length output-callback-var ;
|
|||
|
||||
: output ( data header pcm -- mad_flow )
|
||||
"output" . flush
|
||||
break
|
||||
-rot 2drop output-callback-var> call
|
||||
[ MAD_FLOW_CONTINUE ] [ MAD_FLOW_STOP ] if ;
|
||||
|
||||
|
|
|
@ -47,7 +47,6 @@ VARS: openal-buffer ;
|
|||
malloc [ fill-data ] keep ;
|
||||
|
||||
: output-openal ( pcm -- ? )
|
||||
break
|
||||
openal-buffer> swap ! buffer pcm
|
||||
[ get-format ] keep ! buffer format pcm
|
||||
[ get-data ] keep ! buffer format size alien pcm
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.functions ;
|
||||
IN: quadratic
|
||||
IN: math.quadratic
|
||||
|
||||
: monic ( c b a -- c' b' ) tuck / >r / r> ;
|
||||
|
||||
|
|
|
@ -1,13 +1,12 @@
|
|||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ strip-word-props? t }
|
||||
{ strip-word-names? f }
|
||||
{ strip-dictionary? t }
|
||||
{ strip-debugger? t }
|
||||
{ strip-c-types? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-compiled? t }
|
||||
{ deploy-io? f }
|
||||
{ deploy-ui? t }
|
||||
{ "bundle-name" "Maze.app" }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-name "Maze" }
|
||||
}
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
IN: temporary
|
||||
USING: arrays generic kernel math models namespaces sequences
|
||||
tools.test assocs ;
|
||||
USING: arrays generic kernel math models namespaces sequences assocs
|
||||
tools.test ;
|
||||
|
||||
TUPLE: model-tester hit? ;
|
||||
|
||||
|
@ -137,3 +137,38 @@ f <history> "history" set
|
|||
] unit-test
|
||||
|
||||
[ ] [ "m" get deactivate-model ] unit-test
|
||||
|
||||
! Test <range>
|
||||
: setup-range 0 0 0 255 <range> ;
|
||||
|
||||
! clamp-value should not go past range ends
|
||||
[ 0 ] [ -10 setup-range clamp-value ] unit-test
|
||||
[ 255 ] [ 2000 setup-range clamp-value ] unit-test
|
||||
[ 14 ] [ 14 setup-range clamp-value ] unit-test
|
||||
|
||||
! range min/max/page values should be correct
|
||||
[ 0 ] [ setup-range range-page-value ] unit-test
|
||||
[ 0 ] [ setup-range range-min-value ] unit-test
|
||||
[ 255 ] [ setup-range range-max-value ] unit-test
|
||||
|
||||
! should be able to set the value within the range and get back
|
||||
[ 15 ] [ setup-range 15 over set-range-value range-value ] unit-test
|
||||
[ 0 ] [ setup-range -15 over set-range-value range-value ] unit-test
|
||||
[ 255 ] [ setup-range 4000 over set-range-value range-value ] unit-test
|
||||
|
||||
! should be able to change the range min/max/page value
|
||||
[ 1 ] [ setup-range 1 over set-range-page-value range-page-value ] unit-test
|
||||
[ 50 ] [ setup-range 50 over set-range-min-value range-min-value ] unit-test
|
||||
[ 4000 ] [ setup-range 4000 over set-range-max-value range-max-value ] unit-test
|
||||
|
||||
! should be able to move by positive and negative values
|
||||
[ 30 ] [ setup-range 30 over move-by range-value ] unit-test
|
||||
[ 0 ] [ setup-range 30 over move-by -30 over move-by range-value ] unit-test
|
||||
|
||||
! should be able to move by a page of 10
|
||||
[ 10 ] [
|
||||
setup-range 10 over set-range-page-value
|
||||
1 over move-by-page range-value
|
||||
] unit-test
|
||||
|
||||
|
||||
|
|
|
@ -207,7 +207,8 @@ M: range range-max-value range-max model-value ;
|
|||
M: range range-max-value*
|
||||
dup range-max-value swap range-page-value [-] ;
|
||||
|
||||
M: range set-range-value range-model set-model ;
|
||||
M: range set-range-value
|
||||
[ clamp-value ] keep range-model set-model ;
|
||||
|
||||
M: range set-range-page-value range-page set-model ;
|
||||
|
||||
|
|
|
@ -1,13 +1,12 @@
|
|||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ 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? t }
|
||||
{ "bundle-name" "NeHe Demos.app" }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-name "NeHe OpenGL demos" }
|
||||
}
|
||||
|
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Portions copyright (C) 2007 Eduardo Cavazos.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types io kernel math namespaces
|
||||
sequences math.vectors math.constants math.functions opengl.gl opengl.glu combinators arrays ;
|
||||
USING: alien alien.c-types kernel math namespaces sequences
|
||||
math.vectors math.constants math.functions opengl.gl opengl.glu
|
||||
combinators arrays ;
|
||||
IN: opengl
|
||||
|
||||
: coordinates [ first2 ] 2apply ;
|
||||
|
@ -19,7 +20,7 @@ IN: opengl
|
|||
|
||||
: gl-error ( -- )
|
||||
glGetError dup zero? [
|
||||
"GL error: " write dup gluErrorString print flush
|
||||
"GL error: " dup gluErrorString append throw
|
||||
] unless drop ;
|
||||
|
||||
: do-state ( what quot -- )
|
||||
|
|
|
@ -261,7 +261,7 @@ DEFER: (deserialize) ( -- obj )
|
|||
V{ } clone serialized rot with-variable ; inline
|
||||
|
||||
: deserialize-sequence ( -- seq )
|
||||
[ [ deserialize* ] [ ] { } unfold ] with-serialized ;
|
||||
[ [ deserialize* ] [ ] [ drop ] unfold ] with-serialized ;
|
||||
|
||||
: deserialize ( -- obj )
|
||||
[ (deserialize) ] with-serialized ;
|
||||
|
|
|
@ -0,0 +1,13 @@
|
|||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ deploy-ui? t }
|
||||
{ deploy-io 2 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ "bundle-name" "Belt Tire.app" }
|
||||
}
|
|
@ -1,13 +1,12 @@
|
|||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ 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? t }
|
||||
{ "bundle-name" "Tetris.app" }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-name "Tetris" }
|
||||
}
|
||||
|
|
|
@ -9,10 +9,11 @@ ARTICLE: "deploy-config" "Deployment configuration"
|
|||
{ $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 } ;
|
||||
{ $subsection set-deploy-flag }
|
||||
"The " { $link "ui.tools.deploy" } " provides a graphical way of editing the configuration." ;
|
||||
|
||||
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:"
|
||||
"There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:"
|
||||
{ $subsection deploy-math? }
|
||||
{ $subsection deploy-compiler? }
|
||||
{ $subsection deploy-ui? }
|
||||
|
@ -29,15 +30,36 @@ ARTICLE: "prepare-deploy" "Preparing to deploy an application"
|
|||
|
||||
ABOUT: "prepare-deploy"
|
||||
|
||||
HELP: deploy-name
|
||||
{ $description "Deploy setting. The name of the executable."
|
||||
$nl
|
||||
"On Mac OS X, this becomes the name of the application bundle, with " { $snippet ".app" } " appended. On Windows, this becomes the name of the directory containing the executable." } ;
|
||||
|
||||
HELP: deploy-word-props?
|
||||
{ $description "Deploy flag. If set, the deploy tool retains all word properties. Otherwise, it applies various heuristics to strip out un-needed word properties from words in the dictionary."
|
||||
$nl
|
||||
"Off by default. Enable this if the heuristics strip out required word properties." } ;
|
||||
|
||||
HELP: deploy-c-types?
|
||||
{ $description "Deploy flag. If set, the deploy tool retains the " { $link c-types } " table."
|
||||
HELP: deploy-word-defs?
|
||||
{ $description "Deploy flag. If set, the deploy tool retains word definition quotations for words compiled with the optimizing compiler. Otherwise, word definitions are stripped from words compiled with the optimizing compiler."
|
||||
$nl
|
||||
"Off 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." } ;
|
||||
"Off by default. During normal execution, the word definition quotation of a word compiled with the optimizing compiler is not used, so disabling this flag can save space. However, some libraries introspect word definitions dynamically (for example, " { $link "inverse" } ") and so programs using these libraries must retain word definition quotations." } ;
|
||||
|
||||
HELP: deploy-c-types?
|
||||
{ $description "Deploy flag. If set, the deploy tool retains the " { $link c-types } " table, otherwise this table is stripped out, saving space."
|
||||
$nl
|
||||
"Off by default."
|
||||
$nl
|
||||
"The optimizing compiler is able to fold away calls to various words which take a C type as an input if the C type is a literal string:"
|
||||
{ $list
|
||||
{ $link c-type }
|
||||
{ $link heap-size }
|
||||
{ $link <c-object> }
|
||||
{ $link <c-array> }
|
||||
{ $link malloc-object }
|
||||
{ $link malloc-array }
|
||||
}
|
||||
"If your program looks up C types dynamically or from words which do not have a stack effect, you must enable this flag, because in these situations the C type lookup is not folded away and the global table must be consulted at runtime." } ;
|
||||
|
||||
HELP: deploy-math?
|
||||
{ $description "Deploy flag. If set, the deployed image will contain support for " { $link ratio } " and " { $link complex } " types."
|
||||
|
@ -45,7 +67,7 @@ $nl
|
|||
"On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ;
|
||||
|
||||
HELP: deploy-compiler?
|
||||
{ $description "Deploy flag. If set, words in the deployed image will be compiled when possible."
|
||||
{ $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler 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." } ;
|
||||
|
||||
|
@ -55,14 +77,31 @@ $nl
|
|||
"Off by default. Programs wishing to use the UI must be deployed with this flag on." } ;
|
||||
|
||||
HELP: deploy-io
|
||||
{ $description "The level of I/O support required by the deployed image." } ;
|
||||
{ $description "The level of I/O support required by the deployed image:"
|
||||
{ $table
|
||||
{ "Value" "Description" }
|
||||
{ "1" "No input/output" }
|
||||
{ "2" "Basic ANSI C streams" }
|
||||
{ "3" "Non-blocking streams and networking" }
|
||||
}
|
||||
"The default value is 1, basic ANSI C streams. This enables basic console and file I/O, however more advanced features such are not available." } ;
|
||||
|
||||
HELP: deploy-reflection
|
||||
{ $description "The level of reflection support required by the deployed image." } ;
|
||||
{ $description "The level of reflection support required by the deployed image."
|
||||
{ $table
|
||||
{ "Value" "Description" }
|
||||
{ "1" "No reflection" }
|
||||
{ "2" "Retain word names" }
|
||||
{ "3" "Prettyprinter" }
|
||||
{ "4" "Debugger" }
|
||||
{ "5" "Parser" }
|
||||
{ "6" "Full environment" }
|
||||
}
|
||||
"The defalut value is 1, no reflection. Programs which use the above features will need to be deployed with a higher level of reflection support." } ;
|
||||
|
||||
HELP: default-config
|
||||
{ $values { "assoc" assoc } }
|
||||
{ $description "Outputs the default deployment configuration." } ;
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } }
|
||||
{ $description "Outputs the default deployment configuration for a vocabulary." } ;
|
||||
|
||||
HELP: deploy-config
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } }
|
||||
|
|
|
@ -1,9 +1,12 @@
|
|||
! 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 namespaces math ;
|
||||
splitting parser prettyprint namespaces math vocabs
|
||||
hashtables ;
|
||||
IN: tools.deploy.config
|
||||
|
||||
SYMBOL: deploy-name
|
||||
|
||||
SYMBOL: deploy-ui?
|
||||
SYMBOL: deploy-compiler?
|
||||
SYMBOL: deploy-math?
|
||||
|
@ -17,7 +20,7 @@ SYMBOL: deploy-io
|
|||
{ 3 "Level 3 - Non-blocking streams and networking" }
|
||||
} ;
|
||||
|
||||
: strip-io? deploy-io get zero? ;
|
||||
: strip-io? deploy-io get 1 = ;
|
||||
|
||||
: native-io? deploy-io get 3 = ;
|
||||
|
||||
|
@ -40,29 +43,31 @@ SYMBOL: deploy-reflection
|
|||
: strip-globals? deploy-reflection get 6 < ;
|
||||
|
||||
SYMBOL: deploy-word-props?
|
||||
SYMBOL: deploy-word-defs?
|
||||
SYMBOL: deploy-c-types?
|
||||
|
||||
SYMBOL: deploy-vm
|
||||
SYMBOL: deploy-image
|
||||
|
||||
: default-config ( -- assoc )
|
||||
V{
|
||||
: default-config ( vocab -- assoc )
|
||||
vocab-name deploy-name associate H{
|
||||
{ deploy-ui? f }
|
||||
{ deploy-io 2 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-c-types? f }
|
||||
! default value for deploy.app
|
||||
! default value for deploy.macosx
|
||||
{ "stop-after-last-window?" t }
|
||||
} clone ;
|
||||
} union ;
|
||||
|
||||
: deploy-config-path ( vocab -- string )
|
||||
vocab-dir "deploy.factor" path+ ;
|
||||
|
||||
: deploy-config ( vocab -- assoc )
|
||||
default-config swap
|
||||
dup default-config swap
|
||||
dup deploy-config-path vocab-file-contents
|
||||
parse-fresh dup empty? [ drop ] [ first union ] if ;
|
||||
|
||||
|
|
|
@ -2,16 +2,20 @@ USING: help.markup help.syntax words alien.c-types assocs
|
|||
kernel ;
|
||||
IN: tools.deploy
|
||||
|
||||
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."
|
||||
ARTICLE: "tools.deploy" "Application deployment"
|
||||
"The stand-alone application deployment tool compiles a vocabulary down to a native executable which runs the vocabulary's " { $link POSTPONE: MAIN: } " hook. Deployed executables do not depend on Factor being installed, and do not expose any source code, and thus are suitable for delivering commercial end-user applications."
|
||||
$nl
|
||||
"For example, we can deploy the " { $vocab-link "hello-world" } " demo which comes with Factor:"
|
||||
{ $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" }
|
||||
|
||||
"Once the necessary deployment flags have been set, a deployment image can be generated:"
|
||||
{ $subsection deploy } ;
|
||||
{ $code "\"hello-ui\" deploy" }
|
||||
"On Mac OS X, this yields a program named " { $snippet "Hello world.app" } ". On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } ". In both cases, running the program displays a window with a message."
|
||||
$nl
|
||||
"The deployment tool works by bootstrapping a fresh image, loading the vocabulary into this image, then applying various heuristics to strip the image down to minimal size."
|
||||
$nl
|
||||
"You must explicitly specify major subsystems which are required, as well as the level of reflection support needed. This is done by modifying the deployment configuration prior to deployment."
|
||||
{ $subsection "prepare-deploy" }
|
||||
"Once the necessary deployment flags have been set, the application can be deployed:"
|
||||
{ $subsection deploy }
|
||||
{ $see-also "ui.tools.deploy" } ;
|
||||
|
||||
ABOUT: "tools.deploy"
|
||||
|
||||
|
|
|
@ -5,25 +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 tools.deploy.config ;
|
||||
quotations io.launcher words.private tools.deploy.config
|
||||
bootstrap.image ;
|
||||
IN: tools.deploy
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: boot-image-name ( -- string )
|
||||
"boot." my-arch ".image" 3append ;
|
||||
|
||||
: stage1 ( -- )
|
||||
#! If stage1 image doesn't exist, create one.
|
||||
boot-image-name resource-path exists?
|
||||
[ my-arch make-image ] unless ;
|
||||
|
||||
: (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." %
|
||||
boot-image-name
|
||||
% ".image" %
|
||||
"\"" % swap % "\" -i=" %
|
||||
boot-image-name %
|
||||
[ " " % % ] each
|
||||
] "" make
|
||||
dup print <process-stream>
|
||||
|
@ -37,8 +42,8 @@ IN: tools.deploy
|
|||
""
|
||||
deploy-math? get " math" ?append
|
||||
deploy-compiler? get " compiler" ?append
|
||||
native-io? " io" ?append
|
||||
deploy-ui? get " ui" ?append
|
||||
native-io? " io" ?append
|
||||
] bind ;
|
||||
|
||||
: deploy-command-line ( vm image vocab config -- vm flags )
|
||||
|
@ -57,8 +62,12 @@ IN: tools.deploy
|
|||
PRIVATE>
|
||||
|
||||
: deploy* ( vm image vocab config -- )
|
||||
deploy-command-line stage2 ;
|
||||
stage1 deploy-command-line stage2 ;
|
||||
|
||||
: deploy ( vocab -- )
|
||||
"" resource-path cd
|
||||
vm over ".image" append rot dup deploy-config deploy* ;
|
||||
SYMBOL: deploy-implementation
|
||||
|
||||
HOOK: deploy deploy-implementation ( vocab -- )
|
||||
|
||||
USE-IF: macosx? tools.deploy.macosx
|
||||
|
||||
USE-IF: winnt? tools.deploy.windows
|
||||
|
|
44
extra/tools/deploy/app/app.factor → extra/tools/deploy/macosx/macosx.factor
Normal file → Executable file
44
extra/tools/deploy/app/app.factor → extra/tools/deploy/macosx/macosx.factor
Normal file → Executable file
|
@ -3,10 +3,7 @@
|
|||
USING: io io.files io.launcher kernel namespaces sequences
|
||||
system cocoa.plists cocoa.application tools.deploy
|
||||
tools.deploy.config assocs hashtables prettyprint ;
|
||||
IN: tools.deploy.app
|
||||
|
||||
: mkdir ( path -- )
|
||||
"mkdir -p \"" swap "\"" 3append run-process ;
|
||||
IN: tools.deploy.macosx
|
||||
|
||||
: touch ( path -- )
|
||||
"touch \"" swap "\"" 3append run-process ;
|
||||
|
@ -14,22 +11,24 @@ IN: tools.deploy.app
|
|||
: rm ( path -- )
|
||||
"rm -rf \"" swap "\"" 3append run-process ;
|
||||
|
||||
: cp ( from to -- )
|
||||
"Copying " write over write " to " write dup print
|
||||
dup parent-dir mkdir
|
||||
[ "cp -R \"" % swap % "\" \"" % % "\"" % ] "" make
|
||||
run-process ;
|
||||
: chmod ( path perms -- )
|
||||
[ "chmod " % % " \"" % % "\"" % ] "" make run-process ;
|
||||
|
||||
: bundle-dir ( -- dir )
|
||||
vm parent-directory parent-directory ;
|
||||
|
||||
: copy-bundle-dir ( name dir -- )
|
||||
vm parent-dir parent-dir over path+ -rot
|
||||
>r "Contents" path+ r> path+ cp ;
|
||||
bundle-dir over path+ -rot
|
||||
>r "Contents" path+ r> path+ copy-directory ;
|
||||
|
||||
: copy-vm ( executable bundle-name -- vm )
|
||||
"Contents/MacOS/" path+ swap path+ vm swap [ cp ] keep ;
|
||||
"Contents/MacOS/" path+ swap path+ vm swap
|
||||
[ copy-file ] keep
|
||||
[ "755" chmod ] keep ;
|
||||
|
||||
: copy-fonts ( name -- )
|
||||
"fonts/" resource-path
|
||||
swap "Contents/Resources/fonts/" path+ cp ;
|
||||
swap "Contents/Resources/fonts/" path+ copy-directory ;
|
||||
|
||||
: print-app-plist ( executable bundle-name -- )
|
||||
[
|
||||
|
@ -57,16 +56,19 @@ IN: tools.deploy.app
|
|||
: deploy.app-image ( vocab bundle-name -- str )
|
||||
[ % "/Contents/Resources/" % % ".image" % ] "" make ;
|
||||
|
||||
: deploy.app-config ( vocab -- assoc )
|
||||
[ ".app" append "bundle-name" associate ] keep
|
||||
deploy-config union ;
|
||||
: bundle-name ( -- string )
|
||||
deploy-name get ".app" append ;
|
||||
|
||||
: deploy.app ( vocab -- )
|
||||
TUPLE: macosx-deploy-implementation ;
|
||||
|
||||
T{ macosx-deploy-implementation } deploy-implementation set-global
|
||||
|
||||
M: macosx-deploy-implementation deploy ( vocab -- )
|
||||
".app deploy tool" assert.app
|
||||
"." resource-path cd
|
||||
dup deploy.app-config [
|
||||
"bundle-name" get rm
|
||||
[ "bundle-name" get create-app-dir ] keep
|
||||
[ "bundle-name" get deploy.app-image ] keep
|
||||
dup deploy-config [
|
||||
bundle-name rm
|
||||
[ bundle-name create-app-dir ] keep
|
||||
[ bundle-name deploy.app-image ] keep
|
||||
namespace
|
||||
] bind deploy* ;
|
|
@ -16,6 +16,7 @@ IN: tools.deploy.shaker
|
|||
: strip-init-hooks ( -- )
|
||||
"Stripping startup hooks" show
|
||||
"command-line" init-hooks get delete-at
|
||||
"mallocs" init-hooks get delete-at
|
||||
strip-io? [ "io.backend" init-hooks get delete-at ] when ;
|
||||
|
||||
: strip-debugger ( -- )
|
||||
|
@ -23,6 +24,15 @@ IN: tools.deploy.shaker
|
|||
"Stripping debugger" show
|
||||
"resource:extra/tools/deploy/shaker/strip-debugger.factor"
|
||||
run-file
|
||||
do-parse-hook
|
||||
] when ;
|
||||
|
||||
: strip-libc ( -- )
|
||||
"libc" vocab [
|
||||
"Stripping manual memory management debug code" show
|
||||
"resource:extra/tools/deploy/shaker/strip-libc.factor"
|
||||
run-file
|
||||
do-parse-hook
|
||||
] when ;
|
||||
|
||||
: strip-cocoa ( -- )
|
||||
|
@ -30,6 +40,7 @@ IN: tools.deploy.shaker
|
|||
"Stripping unused Cocoa methods" show
|
||||
"resource:extra/tools/deploy/shaker/strip-cocoa.factor"
|
||||
run-file
|
||||
do-parse-hook
|
||||
] when ;
|
||||
|
||||
: strip-assoc ( retained-keys assoc -- newassoc )
|
||||
|
@ -65,13 +76,14 @@ IN: tools.deploy.shaker
|
|||
|
||||
: strip-words ( props -- )
|
||||
[ word? ] instances
|
||||
deploy-word-props? get [ nip ] [ tuck strip-word-props ] if
|
||||
deploy-word-props? get [ 2dup strip-word-props ] unless
|
||||
deploy-word-defs? get [ dup strip-word-defs ] unless
|
||||
strip-word-names? [ dup strip-word-names ] when
|
||||
strip-word-defs ;
|
||||
2drop ;
|
||||
|
||||
: strip-environment ( retain-globals -- )
|
||||
"Stripping environment" show
|
||||
strip-globals? [
|
||||
"Stripping environment" show
|
||||
global strip-assoc 21 setenv
|
||||
] [ drop ] if ;
|
||||
|
||||
|
@ -126,7 +138,7 @@ SYMBOL: deploy-vocab
|
|||
} %
|
||||
] unless
|
||||
|
||||
deploy-c-types? get deploy-ui? get or [
|
||||
deploy-c-types? get [
|
||||
"c-types" "alien.c-types" lookup ,
|
||||
] when
|
||||
|
||||
|
@ -141,6 +153,7 @@ SYMBOL: deploy-vocab
|
|||
] { } make dup . ;
|
||||
|
||||
: strip ( -- )
|
||||
strip-libc
|
||||
strip-cocoa
|
||||
strip-debugger
|
||||
strip-init-hooks
|
||||
|
@ -160,8 +173,6 @@ SYMBOL: deploy-vocab
|
|||
deploy-vocab get require
|
||||
r> [ call ] when*
|
||||
strip
|
||||
"Compressing image" show
|
||||
compress-image
|
||||
finish-deploy
|
||||
] [
|
||||
print-error flush 1 exit
|
||||
|
|
|
@ -0,0 +1,10 @@
|
|||
USING: libc.private ;
|
||||
IN: libc
|
||||
|
||||
: malloc (malloc) ;
|
||||
|
||||
: free (free) ;
|
||||
|
||||
: realloc (realloc) ;
|
||||
|
||||
: calloc (calloc) ;
|
|
@ -0,0 +1 @@
|
|||
Deploying minimal stand-alone Windows executables
|
|
@ -0,0 +1 @@
|
|||
tools
|
|
@ -0,0 +1,41 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io io.files kernel namespaces sequences system
|
||||
tools.deploy tools.deploy.config assocs hashtables prettyprint ;
|
||||
IN: tools.deploy.windows
|
||||
|
||||
: copy-vm ( executable bundle-name -- vm )
|
||||
swap path+ ".exe" append vm swap [ copy-file ] keep ;
|
||||
|
||||
: copy-fonts ( bundle-name -- )
|
||||
"fonts/" resource-path
|
||||
swap "fonts/" path+ copy-directory ;
|
||||
|
||||
: copy-dlls ( bundle-name -- )
|
||||
{
|
||||
"freetype6.dll"
|
||||
"zlib1.dll"
|
||||
"factor-nt.dll"
|
||||
} [
|
||||
dup resource-path -rot path+ copy-file
|
||||
] curry* each ;
|
||||
|
||||
: create-exe-dir ( vocab bundle-name -- vm )
|
||||
dup copy-dlls
|
||||
dup copy-fonts
|
||||
copy-vm ;
|
||||
|
||||
: image-name ( vocab bundle-name -- str )
|
||||
swap path+ ".image" append ;
|
||||
|
||||
TUPLE: windows-deploy-implementation ;
|
||||
|
||||
T{ windows-deploy-implementation } deploy-implementation set-global
|
||||
|
||||
M: windows-deploy-implementation deploy
|
||||
"." resource-path cd
|
||||
dup deploy-config [
|
||||
[ deploy-name get create-exe-dir ] keep
|
||||
[ deploy-name get image-name ] keep
|
||||
namespace
|
||||
] bind deploy* ;
|
|
@ -20,7 +20,8 @@ M: border pref-dim*
|
|||
|
||||
: border-minor-rect ( major border -- rect )
|
||||
gadget-child pref-dim
|
||||
[ >r rect-bounds r> v- 2 v/n v+ ] keep <rect> ;
|
||||
[ >r rect-bounds r> v- [ 2 / >fixnum ] map v+ ] keep
|
||||
<rect> ;
|
||||
|
||||
: scale-rect ( rect vec -- loc dim )
|
||||
[ v* ] curry >r rect-bounds r> 2apply ;
|
||||
|
|
|
@ -4,7 +4,8 @@ USING: arrays ui.commands ui.gadgets ui.gadgets.borders
|
|||
ui.gadgets.controls ui.gadgets.labels ui.gadgets.theme
|
||||
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
|
||||
ui.render kernel math models namespaces sequences strings
|
||||
quotations assocs combinators classes colors tuples ;
|
||||
quotations assocs combinators classes colors tuples opengl
|
||||
math.vectors ;
|
||||
IN: ui.gadgets.buttons
|
||||
|
||||
TUPLE: button pressed? selected? quot ;
|
||||
|
@ -95,6 +96,18 @@ repeat-button H{
|
|||
repeat-button construct-empty
|
||||
[ >r <bevel-button> r> set-gadget-delegate ] keep ;
|
||||
|
||||
TUPLE: checkmark-paint color ;
|
||||
|
||||
C: <checkmark-paint> checkmark-paint
|
||||
|
||||
M: checkmark-paint draw-interior
|
||||
checkmark-paint-color gl-color
|
||||
origin get [
|
||||
rect-dim
|
||||
{ 0 0 } over gl-line
|
||||
dup { 0 1 } v* swap { 1 0 } v* gl-line
|
||||
] with-translation ;
|
||||
|
||||
: checkmark-theme ( gadget -- )
|
||||
f
|
||||
f
|
||||
|
@ -125,6 +138,18 @@ repeat-button H{
|
|||
[ set-button-selected? ] <control>
|
||||
dup checkbox-theme ;
|
||||
|
||||
TUPLE: radio-paint color ;
|
||||
|
||||
C: <radio-paint> radio-paint
|
||||
|
||||
M: radio-paint draw-interior
|
||||
radio-paint-color gl-color
|
||||
origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
|
||||
|
||||
M: radio-paint draw-boundary
|
||||
radio-paint-color gl-color
|
||||
origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
|
||||
|
||||
: radio-knob-theme ( gadget -- )
|
||||
f
|
||||
f
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.worlds
|
||||
ui.render opengl opengl.gl kernel namespaces tuples colors ;
|
||||
USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.lib
|
||||
ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces
|
||||
tuples colors ;
|
||||
IN: ui.gadgets.canvas
|
||||
|
||||
TUPLE: canvas dlist ;
|
||||
|
@ -10,9 +11,6 @@ TUPLE: canvas dlist ;
|
|||
canvas construct-gadget
|
||||
dup black solid-interior ;
|
||||
|
||||
: find-gl-context ( gadget -- )
|
||||
find-world world-handle select-gl-context ;
|
||||
|
||||
: delete-canvas-dlist ( canvas -- )
|
||||
dup find-gl-context
|
||||
dup canvas-dlist [ delete-dlist ] when*
|
||||
|
|
|
@ -286,7 +286,7 @@ M: gadget ungraft* drop ;
|
|||
swap [ over (add-gadget) ] each relayout ;
|
||||
|
||||
: parents ( gadget -- seq )
|
||||
[ dup ] [ [ gadget-parent ] keep ] { } unfold ;
|
||||
[ dup ] [ [ gadget-parent ] keep ] [ ] unfold nip ;
|
||||
|
||||
: each-parent ( gadget quot -- ? )
|
||||
>r parents r> all? ; inline
|
||||
|
@ -333,7 +333,7 @@ M: f request-focus-on 2drop ;
|
|||
dup focusable-child swap request-focus-on ;
|
||||
|
||||
: focus-path ( world -- seq )
|
||||
[ dup ] [ [ gadget-focus ] keep ] { } unfold ;
|
||||
[ dup ] [ [ gadget-focus ] keep ] [ ] unfold nip ;
|
||||
|
||||
: make-gadget ( quot gadget -- gadget )
|
||||
[ \ make-gadget rot with-variable ] keep ; inline
|
||||
|
|
|
@ -140,32 +140,6 @@ M: polygon draw-interior
|
|||
>r <polygon> <gadget> r> over set-rect-dim
|
||||
[ set-gadget-interior ] keep ;
|
||||
|
||||
! Checkbox and radio button pens
|
||||
TUPLE: checkmark-paint color ;
|
||||
|
||||
C: <checkmark-paint> checkmark-paint
|
||||
|
||||
M: checkmark-paint draw-interior
|
||||
checkmark-paint-color gl-color
|
||||
origin get [
|
||||
rect-dim
|
||||
{ 0 0 } over gl-line
|
||||
dup { 0 1 } v* swap { 1 0 } v* gl-line
|
||||
] with-translation ;
|
||||
|
||||
|
||||
TUPLE: radio-paint color ;
|
||||
|
||||
C: <radio-paint> radio-paint
|
||||
|
||||
M: radio-paint draw-interior
|
||||
radio-paint-color gl-color
|
||||
origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
|
||||
|
||||
M: radio-paint draw-boundary
|
||||
radio-paint-color gl-color
|
||||
origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
|
||||
|
||||
! Font rendering
|
||||
SYMBOL: font-renderer
|
||||
|
||||
|
|
|
@ -0,0 +1,14 @@
|
|||
USING: help.markup help.syntax ui.tools.deploy ;
|
||||
|
||||
HELP: deploy-tool
|
||||
{ $values { "vocab" "a vocabulary specifier" } }
|
||||
{ $description "Opens the graphical deployment tool for the specified vocabulary." }
|
||||
{ $examples { $code "\"tetris\" deploy-tool" } } ;
|
||||
|
||||
ARTICLE: "ui.tools.deploy" "Application deployment UI tool"
|
||||
"The application deployment UI tool provides a graphical front-end to deployment configuration. Using the tool, you can set deployment options graphically."
|
||||
$nl
|
||||
"To start the tool, pass a vocabulary name to a word:"
|
||||
{ $subsection deploy-tool }
|
||||
"Alternatively, right-click on a vocabulary presentation in the UI and choose " { $strong "Deploy tool" } " from the resulting popup menu."
|
||||
{ $see-also "tools.deploy" } ;
|
|
@ -5,14 +5,14 @@ ui.gadgets.controls models sequences ui.gadgets.buttons
|
|||
ui.gadgets.packs ui.gadgets.labels tools.deploy.config
|
||||
namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
|
||||
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
|
||||
tools.deploy.app vocabs ui.tools.workspace ui.operations ;
|
||||
tools.deploy vocabs ui.tools.workspace system ;
|
||||
IN: ui.tools.deploy
|
||||
|
||||
TUPLE: deploy-gadget vocab settings ;
|
||||
|
||||
: bundle-name ( -- )
|
||||
"bundle-name" get <field>
|
||||
"Bundle name:" label-on-left gadget, ;
|
||||
deploy-name get <field>
|
||||
"Executable name:" label-on-left gadget, ;
|
||||
|
||||
: deploy-ui ( -- )
|
||||
deploy-ui? get
|
||||
|
@ -35,19 +35,19 @@ TUPLE: deploy-gadget vocab settings ;
|
|||
deploy-compiler? get "Use optimizing compiler" <checkbox> gadget,
|
||||
deploy-math? get "Rational and complex number support" <checkbox> gadget,
|
||||
deploy-word-props? get "Include word properties" <checkbox> gadget,
|
||||
deploy-word-defs? get "Include word definitions" <checkbox> gadget,
|
||||
deploy-c-types? get "Include C types" <checkbox> gadget, ;
|
||||
|
||||
: deploy-settings-theme
|
||||
{ 10 10 } over set-pack-gap
|
||||
1 swap set-pack-fill ;
|
||||
|
||||
: <deploy-settings> ( -- control )
|
||||
: <deploy-settings> ( vocab -- control )
|
||||
default-config [ <model> ] assoc-map [
|
||||
f <model> "bundle-name" set
|
||||
[
|
||||
bundle-name
|
||||
deploy-ui
|
||||
exit-when-windows-closed
|
||||
macosx? [ exit-when-windows-closed ] when
|
||||
io-settings
|
||||
reflection-settings
|
||||
advanced-settings
|
||||
|
@ -62,7 +62,7 @@ TUPLE: deploy-gadget vocab settings ;
|
|||
find-deploy-gadget deploy-gadget-vocab ;
|
||||
|
||||
: find-deploy-config
|
||||
find-deploy-vocab deploy.app-config ;
|
||||
find-deploy-vocab deploy-config ;
|
||||
|
||||
: find-deploy-settings
|
||||
find-deploy-gadget deploy-gadget-settings ;
|
||||
|
@ -77,7 +77,7 @@ TUPLE: deploy-gadget vocab settings ;
|
|||
|
||||
: com-deploy ( gadget -- )
|
||||
dup com-save
|
||||
find-deploy-vocab [ deploy.app ] curry call-listener ;
|
||||
find-deploy-vocab [ deploy ] curry call-listener ;
|
||||
|
||||
: com-help ( -- )
|
||||
"ui-deploy" help-window ;
|
||||
|
@ -98,7 +98,7 @@ deploy-gadget "toolbar" f {
|
|||
|
||||
: <deploy-gadget> ( vocab -- gadget )
|
||||
f deploy-gadget construct-boa [
|
||||
<deploy-settings>
|
||||
dup <deploy-settings>
|
||||
g-> set-deploy-gadget-settings gadget,
|
||||
buttons,
|
||||
] { 0 1 } build-pack
|
||||
|
@ -108,5 +108,3 @@ deploy-gadget "toolbar" f {
|
|||
: deploy-tool ( vocab -- )
|
||||
vocab-name dup <deploy-gadget> 10 <border>
|
||||
"Deploying \"" rot "\"" 3append open-window ;
|
||||
|
||||
[ vocab-spec? ] \ deploy-tool H{ } define-operation
|
||||
|
|
|
@ -6,8 +6,9 @@ ui.tools.search ui.tools.traceback ui.tools.workspace generic
|
|||
help.topics inference inspector io.files io.styles kernel
|
||||
namespaces parser prettyprint quotations tools.annotations
|
||||
editors tools.profiler tools.test tools.time tools.walker
|
||||
ui.commands ui.gadgets.editors ui.gestures ui.operations vocabs
|
||||
vocabs.loader words sequences tools.browser classes ;
|
||||
ui.commands ui.gadgets.editors ui.gestures ui.operations
|
||||
ui.tools.deploy vocabs vocabs.loader words sequences
|
||||
tools.browser classes ;
|
||||
IN: ui.tools.operations
|
||||
|
||||
V{ } clone operations set-global
|
||||
|
@ -155,6 +156,8 @@ M: word com-stack-effect word-def com-stack-effect ;
|
|||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
[ vocab-spec? ] \ deploy-tool H{ } define-operation
|
||||
|
||||
! Quotations
|
||||
[ quotation? ] \ com-stack-effect H{
|
||||
{ +keyboard+ T{ key-down f { C+ } "i" } }
|
||||
|
|
|
@ -130,12 +130,14 @@ $nl
|
|||
{ $subsection "ui-presentations" }
|
||||
{ $subsection "ui-completion" }
|
||||
{ $heading "Tools" }
|
||||
"All development tools are integrated into a single-window " { $emphasis "workspace" } "."
|
||||
"A single-window " { $emphasis "workspace" } " contains the most frequently-used tools:"
|
||||
{ $subsection "ui-listener" }
|
||||
{ $subsection "ui-browser" }
|
||||
{ $subsection "ui-inspector" }
|
||||
{ $subsection "ui-walker" }
|
||||
{ $subsection "ui-profiler" }
|
||||
"Additional tools:"
|
||||
{ $subsection "ui.tools.deploy" }
|
||||
"Platform-specific features:"
|
||||
{ $subsection "ui-cocoa" } ;
|
||||
|
||||
|
|
|
@ -107,6 +107,7 @@ FUNCTION: void close ( int fd ) ;
|
|||
FUNCTION: int connect ( int s, void* name, socklen_t namelen ) ;
|
||||
FUNCTION: int dup2 ( int oldd, int newd ) ;
|
||||
! FUNCTION: int dup ( int oldd ) ;
|
||||
FUNCTION: int execv ( char* path, char** argv ) ;
|
||||
FUNCTION: int execvp ( char* path, char** argv ) ;
|
||||
FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
|
||||
FUNCTION: int fchdir ( int fd ) ;
|
||||
|
@ -164,6 +165,18 @@ FUNCTION: int system ( char* command ) ;
|
|||
FUNCTION: time_t time ( time_t* t ) ;
|
||||
FUNCTION: int unlink ( char* path ) ;
|
||||
FUNCTION: int utimes ( char* path, timeval[2] times ) ;
|
||||
|
||||
! Flags for waitpid
|
||||
|
||||
: WNOHANG 1 ;
|
||||
: WUNTRACED 2 ;
|
||||
|
||||
: WSTOPPED 2 ;
|
||||
: WEXITED 4 ;
|
||||
: WCONTINUED 8 ;
|
||||
: WNOWAIT HEX: 1000000 ;
|
||||
|
||||
FUNCTION: pid_t wait ( int* status ) ;
|
||||
FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;
|
||||
|
||||
FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
|
||||
|
|
|
@ -1,2 +1,3 @@
|
|||
include vm/Config.linux
|
||||
include vm/Config.arm
|
||||
PLAF_DLL_OBJS += vm/os-linux-arm.o
|
||||
|
|
|
@ -21,5 +21,5 @@ endif
|
|||
# LINKER = gcc -shared -o
|
||||
# LINK_WITH_ENGINE = '-Wl,-rpath,$$ORIGIN' -lfactor
|
||||
|
||||
LINKER = ar rcs
|
||||
LINKER = $(AR) rcs
|
||||
LINK_WITH_ENGINE = -Wl,--whole-archive -lfactor -Wl,-no-whole-archive
|
||||
|
|
|
@ -124,3 +124,8 @@ DEF(void,lazy_jit_compile,(CELL quot)):
|
|||
bl MANGLE(primitive_jit_compile)
|
||||
EPILOGUE
|
||||
JUMP_QUOT /* call the quotation */
|
||||
|
||||
#ifdef WINCE
|
||||
.section .drectve
|
||||
.ascii " -export:c_to_factor"
|
||||
#endif
|
||||
|
|
|
@ -200,6 +200,7 @@ void dump_objects(F_FIXNUM type)
|
|||
{
|
||||
if(type == -1 || type_of(obj) == type)
|
||||
{
|
||||
printf("%lx ",obj);
|
||||
print_nested_obj(obj,3);
|
||||
printf("\n");
|
||||
}
|
||||
|
|
|
@ -0,0 +1,23 @@
|
|||
#include "master.h"
|
||||
|
||||
void flush_icache(CELL start, CELL len)
|
||||
{
|
||||
int result;
|
||||
|
||||
/* XXX: why doesn't this work on Nokia n800? It should behave
|
||||
identically to the below assembly. */
|
||||
/* result = syscall(__ARM_NR_cacheflush,start,start + len,0); */
|
||||
|
||||
__asm__ __volatile__ (
|
||||
"mov r0, %1\n"
|
||||
"sub r1, %2, #1\n"
|
||||
"mov r2, #0\n"
|
||||
"swi " __sys1(__ARM_NR_cacheflush) "\n"
|
||||
"mov %0, r0\n"
|
||||
: "=r" (result)
|
||||
: "r" (start), "r" (start + len)
|
||||
: "r0","r1","r2");
|
||||
|
||||
if(result < 0)
|
||||
critical_error("flush_icache() failed",result);
|
||||
}
|
|
@ -8,7 +8,7 @@ INLINE void *ucontext_stack_pointer(void *uap)
|
|||
return (void *)ucontext->uc_mcontext.arm_sp;
|
||||
}
|
||||
|
||||
INLINE void flush_icache(CELL start, CELL len)
|
||||
{
|
||||
syscall(__ARM_NR_cacheflush,start,start + len,0);
|
||||
}
|
||||
#define UAP_PROGRAM_COUNTER(ucontext) \
|
||||
(((ucontext_t *)(ucontext))->uc_mcontext.arm_pc)
|
||||
|
||||
void flush_icache(CELL start, CELL len);
|
||||
|
|
Loading…
Reference in New Issue