Merge branch 'master' of git://factorcode.org/git/factor
commit
4d8b31f0d7
basis
bootstrap
compiler
cfg/builder
codegen
tests
tree
escape-analysis
propagation
branches
constraints
recursive
cpu
architecture
ppc
x86
fry
help/tutorial
io
encodings/string
servers/connection
unix/launcher/parser
windows/files
locals
peg/ebnf
prettyprint
random/mersenne-twister
tools
ui
freetype
gadgets
buttons
editors
grid-lines
labelled
labels
lists
panes
scrollers
theme
tools/listener
unix
groups
build-support
core
generic
grouping
io/encodings
kernel
namespaces
sequences
extra
automata/ui
boids/ui
builder
build
child
cleanup
common
email
release
report
test
updates
util
bunny/model
|
@ -8,6 +8,8 @@ definitions assocs compiler.errors compiler.units
|
|||
math.parser generic sets debugger command-line ;
|
||||
IN: bootstrap.stage2
|
||||
|
||||
SYMBOL: core-bootstrap-time
|
||||
|
||||
SYMBOL: bootstrap-time
|
||||
|
||||
: default-image-name ( -- string )
|
||||
|
@ -30,11 +32,15 @@ SYMBOL: bootstrap-time
|
|||
: count-words ( pred -- )
|
||||
all-words swap count number>string write ;
|
||||
|
||||
: print-report ( time -- )
|
||||
: print-time ( time -- )
|
||||
1000 /i
|
||||
60 /mod swap
|
||||
"Bootstrap completed in " write number>string write
|
||||
" minutes and " write number>string write " seconds." print
|
||||
number>string write
|
||||
" minutes and " write number>string write " seconds." print ;
|
||||
|
||||
: print-report ( -- )
|
||||
"Core bootstrap completed in " write core-bootstrap-time get print-time
|
||||
"Bootstrap completed in " write bootstrap-time get print-time
|
||||
|
||||
[ compiled>> ] count-words " compiled words" print
|
||||
[ symbol? ] count-words " symbol words" print
|
||||
|
@ -46,7 +52,7 @@ SYMBOL: bootstrap-time
|
|||
|
||||
[
|
||||
! We time bootstrap
|
||||
millis >r
|
||||
millis
|
||||
|
||||
default-image-name "output-image" set-global
|
||||
|
||||
|
@ -71,6 +77,8 @@ SYMBOL: bootstrap-time
|
|||
[
|
||||
load-components
|
||||
|
||||
millis over - core-bootstrap-time set-global
|
||||
|
||||
run-bootstrap-init
|
||||
] with-compiler-errors
|
||||
:errors
|
||||
|
@ -92,7 +100,7 @@ SYMBOL: bootstrap-time
|
|||
] [ print-error 1 exit ] recover
|
||||
] set-boot-quot
|
||||
|
||||
millis r> - dup bootstrap-time set-global
|
||||
millis swap - bootstrap-time set-global
|
||||
print-report
|
||||
|
||||
"output-image" get save-image-and-exit
|
||||
|
|
|
@ -171,6 +171,7 @@ M: #if emit-node
|
|||
[
|
||||
V{ } clone node-stack set
|
||||
##prologue
|
||||
begin-basic-block
|
||||
emit-nodes
|
||||
basic-block get [
|
||||
##epilogue
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces make math math.parser sequences accessors
|
||||
USING: namespaces make math math.order math.parser sequences accessors
|
||||
kernel kernel.private layouts assocs words summary arrays
|
||||
combinators classes.algebra alien alien.c-types alien.structs
|
||||
alien.strings alien.arrays sets threads libc continuations.private
|
||||
|
@ -234,13 +234,26 @@ M: float-regs reg-class-variable drop float-regs ;
|
|||
|
||||
GENERIC: inc-reg-class ( register-class -- )
|
||||
|
||||
M: reg-class inc-reg-class
|
||||
dup reg-class-variable inc
|
||||
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
|
||||
: ?dummy-stack-params ( reg-class -- )
|
||||
dummy-stack-params? [ reg-size stack-params +@ ] [ drop ] if ;
|
||||
|
||||
: ?dummy-int-params ( reg-class -- )
|
||||
dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ;
|
||||
|
||||
: ?dummy-fp-params ( reg-class -- )
|
||||
drop dummy-fp-params? [ float-regs inc ] when ;
|
||||
|
||||
M: int-regs inc-reg-class
|
||||
[ reg-class-variable inc ]
|
||||
[ ?dummy-stack-params ]
|
||||
[ ?dummy-fp-params ]
|
||||
tri ;
|
||||
|
||||
M: float-regs inc-reg-class
|
||||
dup call-next-method
|
||||
fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
|
||||
[ reg-class-variable inc ]
|
||||
[ ?dummy-stack-params ]
|
||||
[ ?dummy-int-params ]
|
||||
tri ;
|
||||
|
||||
GENERIC: reg-class-full? ( class -- ? )
|
||||
|
||||
|
|
|
@ -219,3 +219,14 @@ TUPLE: my-tuple ;
|
|||
: bad-value-bug ( a -- b ) [ 3 ] [ 3 ] if f <array> ;
|
||||
|
||||
[ { f f f } ] [ t bad-value-bug ] unit-test
|
||||
|
||||
! PowerPC regression
|
||||
TUPLE: id obj ;
|
||||
|
||||
: (gc-check-bug) ( a b -- c )
|
||||
{ [ id boa ] [ id boa ] } dispatch ;
|
||||
|
||||
: gc-check-bug ( -- )
|
||||
10000000 [ "hi" 0 (gc-check-bug) drop ] times ;
|
||||
|
||||
[ ] [ gc-check-bug ] unit-test
|
||||
|
|
|
@ -5,7 +5,7 @@ strings sbufs sequences.private slots.private combinators
|
|||
definitions system layouts vectors math.partial-dispatch
|
||||
math.order math.functions accessors hashtables classes assocs
|
||||
io.encodings.utf8 io.encodings.ascii io.encodings fry slots
|
||||
sorting.private combinators.short-circuit
|
||||
sorting.private combinators.short-circuit grouping prettyprint
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.cleanup
|
||||
|
@ -500,3 +500,13 @@ cell-bits 32 = [
|
|||
[ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
|
||||
[ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] contains?
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[ { null } declare [ 1 ] [ 2 ] if ]
|
||||
build-tree normalize propagate cleanup check-nodes
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { array } declare 2 <groups> [ . . ] assoc-each ]
|
||||
\ nth-unsafe inlined?
|
||||
] unit-test
|
||||
|
|
|
@ -102,7 +102,7 @@ M: #declare cleanup* drop f ;
|
|||
#! If only one branch is live we don't need to branch at
|
||||
#! all; just drop the condition value.
|
||||
dup live-children sift dup length {
|
||||
{ 0 [ 2drop f ] }
|
||||
{ 0 [ drop in-d>> #drop ] }
|
||||
{ 1 [ first swap in-d>> #drop prefix ] }
|
||||
[ 2drop ]
|
||||
} case ;
|
||||
|
|
|
@ -8,6 +8,7 @@ math.private kernel tools.test accessors slots.private
|
|||
quotations.private prettyprint classes.tuple.private classes
|
||||
classes.tuple namespaces
|
||||
compiler.tree.propagation.info stack-checker.errors
|
||||
compiler.tree.checker
|
||||
kernel.private ;
|
||||
|
||||
\ escape-analysis must-infer
|
||||
|
@ -34,6 +35,7 @@ M: node count-unboxed-allocations* drop ;
|
|||
propagate
|
||||
cleanup
|
||||
escape-analysis
|
||||
dup check-nodes
|
||||
0 swap [ count-unboxed-allocations* ] each-node ;
|
||||
|
||||
[ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
|
||||
|
@ -307,7 +309,7 @@ C: <ro-box> ro-box
|
|||
: bleach-node ( quot: ( node -- ) -- )
|
||||
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
|
||||
|
||||
[ 2 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
|
||||
[ 3 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
|
||||
|
||||
[ 0 ] [
|
||||
[ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]
|
||||
|
|
|
@ -40,8 +40,8 @@ M: #dispatch live-branches
|
|||
SYMBOL: infer-children-data
|
||||
|
||||
: copy-value-info ( -- )
|
||||
value-infos [ clone ] change
|
||||
constraints [ clone ] change ;
|
||||
value-infos [ H{ } clone suffix ] change
|
||||
constraints [ H{ } clone suffix ] change ;
|
||||
|
||||
: no-value-info ( -- )
|
||||
value-infos off
|
||||
|
|
|
@ -32,7 +32,7 @@ TUPLE: true-constraint value ;
|
|||
|
||||
M: true-constraint assume*
|
||||
[ \ f class-not <class-info> swap value>> refine-value-info ]
|
||||
[ constraints get at [ assume ] when* ]
|
||||
[ constraints get assoc-stack [ assume ] when* ]
|
||||
bi ;
|
||||
|
||||
M: true-constraint satisfied?
|
||||
|
@ -44,7 +44,7 @@ TUPLE: false-constraint value ;
|
|||
|
||||
M: false-constraint assume*
|
||||
[ \ f <class-info> swap value>> refine-value-info ]
|
||||
[ constraints get at [ assume ] when* ]
|
||||
[ constraints get assoc-stack [ assume ] when* ]
|
||||
bi ;
|
||||
|
||||
M: false-constraint satisfied?
|
||||
|
@ -83,7 +83,7 @@ TUPLE: implication p q ;
|
|||
C: --> implication
|
||||
|
||||
: assume-implication ( p q -- )
|
||||
[ constraints get [ swap suffix ] change-at ]
|
||||
[ constraints get [ assoc-stack swap suffix ] 2keep peek set-at ]
|
||||
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
|
||||
|
||||
M: implication assume*
|
||||
|
|
|
@ -70,3 +70,7 @@ TUPLE: test-tuple { x read-only } ;
|
|||
f f 3 <literal-info> 3array test-tuple <tuple-info> dup
|
||||
object-info value-info-intersect =
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
null-info 3 <literal-info> value-info<=
|
||||
] unit-test
|
||||
|
|
|
@ -34,7 +34,7 @@ slots ;
|
|||
|
||||
: null-info T{ value-info f null empty-interval } ; inline
|
||||
|
||||
: object-info T{ value-info f object T{ interval f { -1.0/0.0 t } { 1.0/0.0 t } } } ; inline
|
||||
: object-info T{ value-info f object full-interval } ; inline
|
||||
|
||||
: class-interval ( class -- interval )
|
||||
dup real class<=
|
||||
|
@ -43,7 +43,7 @@ slots ;
|
|||
: interval>literal ( class interval -- literal literal? )
|
||||
#! If interval has zero length and the class is sufficiently
|
||||
#! precise, we can turn it into a literal
|
||||
dup empty-interval eq? [
|
||||
dup special-interval? [
|
||||
2drop f f
|
||||
] [
|
||||
dup from>> first {
|
||||
|
@ -243,7 +243,7 @@ DEFER: (value-info-union)
|
|||
: literals<= ( info1 info2 -- ? )
|
||||
{
|
||||
{ [ dup literal?>> not ] [ 2drop t ] }
|
||||
{ [ over literal?>> not ] [ 2drop f ] }
|
||||
{ [ over literal?>> not ] [ drop class>> null-class? ] }
|
||||
[ [ literal>> ] bi@ eql? ]
|
||||
} cond ;
|
||||
|
||||
|
@ -262,17 +262,19 @@ DEFER: (value-info-union)
|
|||
]
|
||||
} cond ;
|
||||
|
||||
! Current value --> info mapping
|
||||
! Assoc stack of current value --> info mapping
|
||||
SYMBOL: value-infos
|
||||
|
||||
: value-info ( value -- info )
|
||||
resolve-copy value-infos get at null-info or ;
|
||||
resolve-copy value-infos get assoc-stack null-info or ;
|
||||
|
||||
: set-value-info ( info value -- )
|
||||
resolve-copy value-infos get set-at ;
|
||||
resolve-copy value-infos get peek set-at ;
|
||||
|
||||
: refine-value-info ( info value -- )
|
||||
resolve-copy value-infos get [ value-info-intersect ] change-at ;
|
||||
resolve-copy value-infos get
|
||||
[ assoc-stack value-info-intersect ] 2keep
|
||||
peek set-at ;
|
||||
|
||||
: value-literal ( value -- obj ? )
|
||||
value-info >literal< ;
|
||||
|
|
|
@ -8,7 +8,7 @@ math.functions math.private strings layouts
|
|||
compiler.tree.propagation.info compiler.tree.def-use
|
||||
compiler.tree.debugger compiler.tree.checker
|
||||
slots.private words hashtables classes assocs locals
|
||||
float-arrays system ;
|
||||
float-arrays system sorting ;
|
||||
IN: compiler.tree.propagation.tests
|
||||
|
||||
\ propagate must-infer
|
||||
|
@ -592,6 +592,8 @@ MIXIN: empty-mixin
|
|||
|
||||
[ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
|
||||
|
||||
[ V{ array } ] [ [ [ <=> ] sort [ <=> ] sort ] final-classes ] unit-test
|
||||
|
||||
! [ V{ string } ] [
|
||||
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
|
||||
! ] unit-test
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences namespaces hashtables
|
||||
USING: accessors kernel sequences namespaces hashtables arrays
|
||||
compiler.tree
|
||||
compiler.tree.propagation.copy
|
||||
compiler.tree.propagation.info
|
||||
|
@ -17,7 +17,7 @@ IN: compiler.tree.propagation
|
|||
|
||||
: propagate ( node -- node )
|
||||
H{ } clone copies set
|
||||
H{ } clone constraints set
|
||||
H{ } clone value-infos set
|
||||
H{ } clone 1array value-infos set
|
||||
H{ } clone 1array constraints set
|
||||
dup count-nodes
|
||||
dup (propagate) ;
|
||||
|
|
|
@ -17,9 +17,12 @@ IN: compiler.tree.propagation.recursive
|
|||
[ value-info<= ] 2all?
|
||||
[ drop ] [ label>> f >>fixed-point drop ] if ;
|
||||
|
||||
: latest-input-infos ( node -- infos )
|
||||
in-d>> [ value-info ] map ;
|
||||
|
||||
: recursive-stacks ( #enter-recursive -- stacks initial )
|
||||
[ label>> calls>> [ node-input-infos ] map flip ]
|
||||
[ in-d>> [ value-info ] map ] bi ;
|
||||
[ latest-input-infos ] bi ;
|
||||
|
||||
: generalize-counter-interval ( interval initial-interval -- interval' )
|
||||
{
|
||||
|
@ -46,14 +49,13 @@ IN: compiler.tree.propagation.recursive
|
|||
] if ;
|
||||
|
||||
: propagate-recursive-phi ( #enter-recursive -- )
|
||||
[ ] [ recursive-stacks unify-recursive-stacks ] [ ] tri
|
||||
[ node-output-infos check-fixed-point ]
|
||||
[ out-d>> set-value-infos drop ]
|
||||
3bi ;
|
||||
[ recursive-stacks unify-recursive-stacks ] keep
|
||||
out-d>> set-value-infos ;
|
||||
|
||||
M: #recursive propagate-around ( #recursive -- )
|
||||
constraints [ H{ } clone suffix ] change
|
||||
[
|
||||
constraints [ clone ] change
|
||||
constraints [ but-last H{ } clone suffix ] change
|
||||
|
||||
child>>
|
||||
[ first compute-copy-equiv ]
|
||||
|
@ -62,6 +64,9 @@ M: #recursive propagate-around ( #recursive -- )
|
|||
tri
|
||||
] until-fixed-point ;
|
||||
|
||||
: recursive-phi-infos ( node -- infos )
|
||||
label>> enter-recursive>> node-output-infos ;
|
||||
|
||||
: generalize-return-interval ( info -- info' )
|
||||
dup [ literal?>> ] [ class>> null-class? ] bi or
|
||||
[ clone [-inf,inf] >>interval ] unless ;
|
||||
|
@ -70,12 +75,25 @@ M: #recursive propagate-around ( #recursive -- )
|
|||
[ generalize-return-interval ] map ;
|
||||
|
||||
: return-infos ( node -- infos )
|
||||
label>> [ return>> node-input-infos ] [ loop?>> ] bi
|
||||
[ generalize-return ] unless ;
|
||||
label>> return>> node-input-infos generalize-return ;
|
||||
|
||||
: save-return-infos ( node infos -- )
|
||||
swap out-d>> set-value-infos ;
|
||||
|
||||
: unless-loop ( node quot -- )
|
||||
[ dup label>> loop?>> [ drop ] ] dip if ; inline
|
||||
|
||||
M: #call-recursive propagate-before ( #call-recursive -- )
|
||||
[ ] [ return-infos ] [ node-output-infos ] tri
|
||||
[ check-fixed-point ] [ drop swap out-d>> set-value-infos ] 3bi ;
|
||||
[
|
||||
[ ] [ latest-input-infos ] [ recursive-phi-infos ] tri
|
||||
check-fixed-point
|
||||
]
|
||||
[
|
||||
[
|
||||
[ ] [ return-infos ] [ node-output-infos ] tri
|
||||
[ check-fixed-point ] [ drop save-return-infos ] 3bi
|
||||
] unless-loop
|
||||
] bi ;
|
||||
|
||||
M: #call-recursive annotate-node
|
||||
dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;
|
||||
|
@ -83,5 +101,11 @@ M: #call-recursive annotate-node
|
|||
M: #enter-recursive annotate-node
|
||||
dup out-d>> (annotate-node) ;
|
||||
|
||||
M: #return-recursive propagate-before ( #return-recursive -- )
|
||||
[
|
||||
[ ] [ latest-input-infos ] [ node-input-infos ] tri
|
||||
check-fixed-point
|
||||
] unless-loop ;
|
||||
|
||||
M: #return-recursive annotate-node
|
||||
dup in-d>> (annotate-node) ;
|
||||
|
|
|
@ -146,8 +146,14 @@ HOOK: struct-small-enough? cpu ( heap-size -- ? )
|
|||
! Do we pass value structs by value or hidden reference?
|
||||
HOOK: value-structs? cpu ( -- ? )
|
||||
|
||||
! If t, fp parameters are shadowed by dummy int parameters
|
||||
HOOK: fp-shadows-int? cpu ( -- ? )
|
||||
! If t, all parameters are shadowed by dummy stack parameters
|
||||
HOOK: dummy-stack-params? cpu ( -- ? )
|
||||
|
||||
! If t, all FP parameters are shadowed by dummy int parameters
|
||||
HOOK: dummy-int-params? cpu ( -- ? )
|
||||
|
||||
! If t, all int parameters are shadowed by dummy FP parameters
|
||||
HOOK: dummy-fp-params? cpu ( -- ? )
|
||||
|
||||
HOOK: %prepare-unbox cpu ( -- )
|
||||
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors system kernel alien.c-types cpu.architecture cpu.ppc ;
|
||||
USING: accessors system kernel layouts
|
||||
alien.c-types cpu.architecture cpu.ppc ;
|
||||
IN: cpu.ppc.linux
|
||||
|
||||
<<
|
||||
|
@ -8,12 +9,16 @@ t "longlong" c-type (>>stack-align?)
|
|||
t "ulonglong" c-type (>>stack-align?)
|
||||
>>
|
||||
|
||||
M: linux reserved-area-size 2 ;
|
||||
M: linux reserved-area-size 2 cells ;
|
||||
|
||||
M: linux lr-save 1 ;
|
||||
M: linux lr-save 1 cells ;
|
||||
|
||||
M: float-regs param-regs { 1 2 3 4 5 6 7 8 } ;
|
||||
M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 } ;
|
||||
|
||||
M: ppc value-structs? drop f ;
|
||||
M: ppc value-structs? f ;
|
||||
|
||||
M: ppc fp-shadows-int? drop f ;
|
||||
M: ppc dummy-stack-params? f ;
|
||||
|
||||
M: ppc dummy-int-params? f ;
|
||||
|
||||
M: ppc dummy-fp-params? f ;
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors system kernel alien.c-types cpu.architecture cpu.ppc ;
|
||||
USING: accessors system kernel layouts
|
||||
alien.c-types cpu.architecture cpu.ppc ;
|
||||
IN: cpu.ppc.macosx
|
||||
|
||||
<<
|
||||
|
@ -9,12 +10,16 @@ IN: cpu.ppc.macosx
|
|||
4 "double" c-type (>>align)
|
||||
>>
|
||||
|
||||
M: macosx reserved-area-size 6 ;
|
||||
M: macosx reserved-area-size 6 cells ;
|
||||
|
||||
M: macosx lr-save 2 ;
|
||||
M: macosx lr-save 2 cells ;
|
||||
|
||||
M: float-regs param-regs { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
|
||||
M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
|
||||
|
||||
M: ppc value-structs? drop t ;
|
||||
M: ppc value-structs? t ;
|
||||
|
||||
M: ppc fp-shadows-int? drop t ;
|
||||
M: ppc dummy-stack-params? t ;
|
||||
|
||||
M: ppc dummy-int-params? t ;
|
||||
|
||||
M: ppc dummy-fp-params? f ;
|
||||
|
|
|
@ -4,7 +4,8 @@ USING: accessors assocs sequences kernel combinators make math
|
|||
math.order math.ranges system namespaces locals layouts words
|
||||
alien alien.c-types cpu.architecture cpu.ppc.assembler
|
||||
compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.constants compiler.codegen compiler.codegen.fixup ;
|
||||
compiler.constants compiler.codegen compiler.codegen.fixup
|
||||
compiler.cfg.intrinsics compiler.cfg.stack-frame ;
|
||||
IN: cpu.ppc
|
||||
|
||||
! PowerPC register assignments:
|
||||
|
@ -15,15 +16,19 @@ IN: cpu.ppc
|
|||
! f0-f29: float vregs
|
||||
! f30, f31: float scratch
|
||||
|
||||
enable-float-intrinsics
|
||||
|
||||
<< \ ##integer>float t frame-required? set-word-prop
|
||||
\ ##float>integer t frame-required? set-word-prop >>
|
||||
|
||||
M: ppc machine-registers
|
||||
{
|
||||
{ int-regs T{ range f 2 26 1 } }
|
||||
{ double-float-regs T{ range f 0 28 1 } }
|
||||
{ double-float-regs T{ range f 0 29 1 } }
|
||||
} ;
|
||||
|
||||
: scratch-reg 28 ; inline
|
||||
: fp-scratch-reg-1 29 ; inline
|
||||
: fp-scratch-reg-2 30 ; inline
|
||||
: fp-scratch-reg 30 ; inline
|
||||
|
||||
M: ppc two-operand? f ;
|
||||
|
||||
|
@ -54,8 +59,16 @@ M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
|
|||
M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
|
||||
|
||||
HOOK: reserved-area-size os ( -- n )
|
||||
HOOK: lr-save os ( -- n )
|
||||
|
||||
! The start of the stack frame contains the size of this frame
|
||||
! as well as the currently executing XT
|
||||
: factor-area-size ( -- n ) 2 cells ; foldable
|
||||
: next-save ( n -- i ) cell - ;
|
||||
: xt-save ( n -- i ) 2 cells - ;
|
||||
|
||||
! Next, we have the spill area as well as the FFI parameter area.
|
||||
! They overlap, since basic blocks with FFI calls will never
|
||||
! spill.
|
||||
: param@ ( n -- x ) reserved-area-size + ; inline
|
||||
|
||||
: param-save-size ( -- n ) 8 cells ; foldable
|
||||
|
@ -63,19 +76,34 @@ HOOK: lr-save os ( -- n )
|
|||
: local@ ( n -- x )
|
||||
reserved-area-size param-save-size + + ; inline
|
||||
|
||||
: factor-area-size ( -- n ) 2 cells ; foldable
|
||||
: spill-integer-base ( -- n )
|
||||
stack-frame get spill-counts>> double-float-regs swap at
|
||||
double-float-regs reg-size * ;
|
||||
|
||||
: next-save ( n -- i ) cell - ;
|
||||
: spill-integer@ ( n -- offset )
|
||||
cells spill-integer-base + param@ ;
|
||||
|
||||
: xt-save ( n -- i ) 2 cells - ;
|
||||
: spill-float@ ( n -- offset )
|
||||
double-float-regs reg-size * param@ ;
|
||||
|
||||
! Some FP intrinsics need a temporary scratch area in the stack
|
||||
! frame, 8 bytes in size
|
||||
: scratch@ ( n -- offset )
|
||||
stack-frame get total-size>>
|
||||
factor-area-size -
|
||||
param-save-size -
|
||||
+ ;
|
||||
|
||||
! Finally we have the linkage area
|
||||
HOOK: lr-save os ( -- n )
|
||||
|
||||
M: ppc stack-frame-size ( stack-frame -- i )
|
||||
[ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
|
||||
[ params>> ]
|
||||
[ return>> ]
|
||||
tri + +
|
||||
reserved-area-size +
|
||||
param-save-size +
|
||||
reserved-area-size +
|
||||
factor-area-size +
|
||||
4 cells align ;
|
||||
|
||||
|
@ -198,19 +226,19 @@ M: ppc %div-float FDIV ;
|
|||
|
||||
M:: ppc %integer>float ( dst src -- )
|
||||
HEX: 4330 scratch-reg LIS
|
||||
scratch-reg 1 0 param@ STW
|
||||
scratch-reg 1 0 scratch@ STW
|
||||
scratch-reg src MR
|
||||
scratch-reg dup HEX: 8000 XORIS
|
||||
scratch-reg 1 cell param@ STW
|
||||
fp-scratch-reg-2 1 0 param@ LFD
|
||||
scratch-reg 1 4 scratch@ STW
|
||||
dst 1 0 scratch@ LFD
|
||||
scratch-reg 4503601774854144.0 %load-indirect
|
||||
fp-scratch-reg-2 scratch-reg float-offset LFD
|
||||
fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ;
|
||||
fp-scratch-reg scratch-reg float-offset LFD
|
||||
dst dst fp-scratch-reg FSUB ;
|
||||
|
||||
M:: ppc %float>integer ( dst src -- )
|
||||
fp-scratch-reg-1 src FCTIWZ
|
||||
fp-scratch-reg-2 1 0 param@ STFD
|
||||
dst 1 4 param@ LWZ ;
|
||||
fp-scratch-reg src FCTIWZ
|
||||
fp-scratch-reg 1 0 scratch@ STFD
|
||||
dst 1 4 scratch@ LWZ ;
|
||||
|
||||
M: ppc %copy ( dst src -- ) MR ;
|
||||
|
||||
|
@ -218,6 +246,10 @@ M: ppc %copy-float ( dst src -- ) FMR ;
|
|||
|
||||
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
|
||||
|
||||
M:: ppc %box-float ( dst src temp -- )
|
||||
dst 16 float temp %allot
|
||||
src dst float-offset STFD ;
|
||||
|
||||
M:: ppc %unbox-any-c-ptr ( dst src temp -- )
|
||||
[
|
||||
{ "is-byte-array" "end" "start" } [ define-label ] each
|
||||
|
@ -349,12 +381,12 @@ M: ppc %gc
|
|||
"end" resolve-label ;
|
||||
|
||||
M: ppc %prologue ( n -- )
|
||||
0 scratch-reg LOAD32 rc-absolute-ppc-2/2 rel-this
|
||||
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
|
||||
0 MFLR
|
||||
1 1 pick neg ADDI
|
||||
scratch-reg 1 pick xt-save STW
|
||||
dup scratch-reg LI
|
||||
scratch-reg 1 pick next-save STW
|
||||
11 1 pick xt-save STW
|
||||
dup 11 LI
|
||||
11 1 pick next-save STW
|
||||
0 1 rot lr-save + STW ;
|
||||
|
||||
M: ppc %epilogue ( n -- )
|
||||
|
@ -405,32 +437,11 @@ M: ppc %compare-branch (%compare) %branch ;
|
|||
M: ppc %compare-imm-branch (%compare-imm) %branch ;
|
||||
M: ppc %compare-float-branch (%compare-float) %branch ;
|
||||
|
||||
: spill-integer-base ( stack-frame -- n )
|
||||
[ params>> ] [ return>> ] bi + ;
|
||||
M: ppc %spill-integer ( src n -- ) spill-integer@ 1 swap STW ;
|
||||
M: ppc %reload-integer ( dst n -- ) spill-integer@ 1 swap LWZ ;
|
||||
|
||||
: stack@ 1 swap ; inline
|
||||
|
||||
: spill-integer@ ( n -- reg offset )
|
||||
cells
|
||||
stack-frame get spill-integer-base
|
||||
+ stack@ ;
|
||||
|
||||
: spill-float-base ( stack-frame -- n )
|
||||
[ spill-counts>> int-regs swap at int-regs reg-size * ]
|
||||
[ params>> ]
|
||||
[ return>> ]
|
||||
tri + + ;
|
||||
|
||||
: spill-float@ ( n -- reg offset )
|
||||
double-float-regs reg-size *
|
||||
stack-frame get spill-float-base
|
||||
+ stack@ ;
|
||||
|
||||
M: ppc %spill-integer ( src n -- ) spill-integer@ STW ;
|
||||
M: ppc %reload-integer ( dst n -- ) spill-integer@ LWZ ;
|
||||
|
||||
M: ppc %spill-float ( src n -- ) spill-float@ STFD ;
|
||||
M: ppc %reload-float ( dst n -- ) spill-float@ LFD ;
|
||||
M: ppc %spill-float ( src n -- ) spill-float@ 1 swap STFD ;
|
||||
M: ppc %reload-float ( dst n -- ) spill-float@ 1 swap LFD ;
|
||||
|
||||
M: ppc %loop-entry ;
|
||||
|
||||
|
|
|
@ -274,6 +274,12 @@ M: x86.32 %callback-return ( n -- )
|
|||
[ drop 0 ]
|
||||
} cond RET ;
|
||||
|
||||
M: x86.32 dummy-stack-params? f ;
|
||||
|
||||
M: x86.32 dummy-int-params? f ;
|
||||
|
||||
M: x86.32 dummy-fp-params? f ;
|
||||
|
||||
os windows? [
|
||||
cell "longlong" c-type (>>align)
|
||||
cell "ulonglong" c-type (>>align)
|
||||
|
|
|
@ -26,6 +26,7 @@ M: x86.64 temp-reg-2 RCX ;
|
|||
|
||||
: param-reg-1 int-regs param-regs first ; inline
|
||||
: param-reg-2 int-regs param-regs second ; inline
|
||||
: param-reg-3 int-regs param-regs third ; inline
|
||||
|
||||
M: int-regs return-reg drop RAX ;
|
||||
M: float-regs return-reg drop XMM0 ;
|
||||
|
@ -40,13 +41,13 @@ M: x86.64 %prologue ( n -- )
|
|||
|
||||
M: stack-params %load-param-reg
|
||||
drop
|
||||
>r R11 swap stack@ MOV
|
||||
r> stack@ R11 MOV ;
|
||||
>r R11 swap param@ MOV
|
||||
r> param@ R11 MOV ;
|
||||
|
||||
M: stack-params %save-param-reg
|
||||
drop
|
||||
R11 swap next-stack@ MOV
|
||||
stack@ R11 MOV ;
|
||||
param@ R11 MOV ;
|
||||
|
||||
: with-return-regs ( quot -- )
|
||||
[
|
||||
|
@ -55,37 +56,6 @@ M: stack-params %save-param-reg
|
|||
call
|
||||
] with-scope ; inline
|
||||
|
||||
! The ABI for passing structs by value is pretty messed up
|
||||
<< "void*" c-type clone "__stack_value" define-primitive-type
|
||||
stack-params "__stack_value" c-type (>>reg-class) >>
|
||||
|
||||
: struct-types&offset ( struct-type -- pairs )
|
||||
fields>> [
|
||||
[ type>> ] [ offset>> ] bi 2array
|
||||
] map ;
|
||||
|
||||
: split-struct ( pairs -- seq )
|
||||
[
|
||||
[ 8 mod zero? [ t , ] when , ] assoc-each
|
||||
] { } make { t } split harvest ;
|
||||
|
||||
: flatten-small-struct ( c-type -- seq )
|
||||
struct-types&offset split-struct [
|
||||
[ c-type c-type-reg-class ] map
|
||||
int-regs swap member? "void*" "double" ? c-type
|
||||
] map ;
|
||||
|
||||
: flatten-large-struct ( c-type -- seq )
|
||||
heap-size cell align
|
||||
cell /i "__stack_value" c-type <repetition> ;
|
||||
|
||||
M: struct-type flatten-value-type ( type -- seq )
|
||||
dup heap-size 16 > [
|
||||
flatten-large-struct
|
||||
] [
|
||||
flatten-small-struct
|
||||
] if ;
|
||||
|
||||
M: x86.64 %prepare-unbox ( -- )
|
||||
! First parameter is top of stack
|
||||
param-reg-1 R14 [] MOV
|
||||
|
@ -102,7 +72,7 @@ M: x86.64 %unbox-long-long ( n func -- )
|
|||
|
||||
: %unbox-struct-field ( c-type i -- )
|
||||
! Alien must be in param-reg-1.
|
||||
param-reg-1 swap cells [+] swap reg-class>> {
|
||||
R11 swap cells [+] swap reg-class>> {
|
||||
{ int-regs [ int-regs get pop swap MOV ] }
|
||||
{ double-float-regs [ float-regs get pop swap MOVSD ] }
|
||||
} case ;
|
||||
|
@ -110,20 +80,20 @@ M: x86.64 %unbox-long-long ( n func -- )
|
|||
M: x86.64 %unbox-small-struct ( c-type -- )
|
||||
! Alien must be in param-reg-1.
|
||||
"alien_offset" f %alien-invoke
|
||||
! Move alien_offset() return value to param-reg-1 so that we don't
|
||||
! Move alien_offset() return value to R11 so that we don't
|
||||
! clobber it.
|
||||
param-reg-1 RAX MOV
|
||||
R11 RAX MOV
|
||||
[
|
||||
flatten-small-struct [ %unbox-struct-field ] each-index
|
||||
flatten-value-type [ %unbox-struct-field ] each-index
|
||||
] with-return-regs ;
|
||||
|
||||
M: x86.64 %unbox-large-struct ( n c-type -- )
|
||||
! Source is in param-reg-1
|
||||
heap-size
|
||||
! Load destination address
|
||||
param-reg-2 rot stack@ LEA
|
||||
param-reg-2 rot param@ LEA
|
||||
! Load structure size
|
||||
RDX swap MOV
|
||||
param-reg-3 swap MOV
|
||||
! Copy the struct to the C stack
|
||||
"to_value_struct" f %alien-invoke ;
|
||||
|
||||
|
@ -142,10 +112,7 @@ M: x86.64 %box ( n reg-class func -- )
|
|||
M: x86.64 %box-long-long ( n func -- )
|
||||
int-regs swap %box ;
|
||||
|
||||
M: x86.64 struct-small-enough? ( size -- ? )
|
||||
heap-size 2 cells <= ;
|
||||
|
||||
: box-struct-field@ ( i -- operand ) 1+ cells stack@ ;
|
||||
: box-struct-field@ ( i -- operand ) 1+ cells param@ ;
|
||||
|
||||
: %box-struct-field ( c-type i -- )
|
||||
box-struct-field@ swap reg-class>> {
|
||||
|
@ -156,15 +123,15 @@ M: x86.64 struct-small-enough? ( size -- ? )
|
|||
M: x86.64 %box-small-struct ( c-type -- )
|
||||
#! Box a <= 16-byte struct.
|
||||
[
|
||||
[ flatten-small-struct [ %box-struct-field ] each-index ]
|
||||
[ RDX swap heap-size MOV ] bi
|
||||
[ flatten-value-type [ %box-struct-field ] each-index ]
|
||||
[ param-reg-3 swap heap-size MOV ] bi
|
||||
param-reg-1 0 box-struct-field@ MOV
|
||||
param-reg-2 1 box-struct-field@ MOV
|
||||
"box_small_struct" f %alien-invoke
|
||||
] with-return-regs ;
|
||||
|
||||
: struct-return@ ( n -- operand )
|
||||
[ stack-frame get params>> ] unless* stack@ ;
|
||||
[ stack-frame get params>> ] unless* param@ ;
|
||||
|
||||
M: x86.64 %box-large-struct ( n c-type -- )
|
||||
! Struct size is parameter 2
|
||||
|
@ -178,7 +145,7 @@ M: x86.64 %prepare-box-struct ( -- )
|
|||
! Compute target address for value struct return
|
||||
RAX f struct-return@ LEA
|
||||
! Store it as the first parameter
|
||||
0 stack@ RAX MOV ;
|
||||
0 param@ RAX MOV ;
|
||||
|
||||
M: x86.64 %prepare-var-args RAX RAX XOR ;
|
||||
|
||||
|
|
|
@ -1,7 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel layouts system compiler.cfg.registers
|
||||
cpu.architecture cpu.x86.assembler cpu.x86 ;
|
||||
USING: accessors arrays sequences math splitting make assocs
|
||||
kernel layouts system alien.c-types alien.structs
|
||||
cpu.architecture cpu.x86.assembler cpu.x86
|
||||
compiler.codegen compiler.cfg.registers ;
|
||||
IN: cpu.x86.64.unix
|
||||
|
||||
M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
|
||||
|
@ -10,3 +12,43 @@ M: float-regs param-regs
|
|||
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
||||
|
||||
M: x86.64 reserved-area-size 0 ;
|
||||
|
||||
! The ABI for passing structs by value is pretty messed up
|
||||
<< "void*" c-type clone "__stack_value" define-primitive-type
|
||||
stack-params "__stack_value" c-type (>>reg-class) >>
|
||||
|
||||
: struct-types&offset ( struct-type -- pairs )
|
||||
fields>> [
|
||||
[ type>> ] [ offset>> ] bi 2array
|
||||
] map ;
|
||||
|
||||
: split-struct ( pairs -- seq )
|
||||
[
|
||||
[ 8 mod zero? [ t , ] when , ] assoc-each
|
||||
] { } make { t } split harvest ;
|
||||
|
||||
: flatten-small-struct ( c-type -- seq )
|
||||
struct-types&offset split-struct [
|
||||
[ c-type c-type-reg-class ] map
|
||||
int-regs swap member? "void*" "double" ? c-type
|
||||
] map ;
|
||||
|
||||
: flatten-large-struct ( c-type -- seq )
|
||||
heap-size cell align
|
||||
cell /i "__stack_value" c-type <repetition> ;
|
||||
|
||||
M: struct-type flatten-value-type ( type -- seq )
|
||||
dup heap-size 16 > [
|
||||
flatten-large-struct
|
||||
] [
|
||||
flatten-small-struct
|
||||
] if ;
|
||||
|
||||
M: x86.64 struct-small-enough? ( size -- ? )
|
||||
heap-size 2 cells <= ;
|
||||
|
||||
M: x86.64 dummy-stack-params? f ;
|
||||
|
||||
M: x86.64 dummy-int-params? f ;
|
||||
|
||||
M: x86.64 dummy-fp-params? f ;
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel layouts system alien.c-types compiler.cfg.registers
|
||||
cpu.architecture cpu.x86.assembler cpu.x86 ;
|
||||
USING: kernel layouts system math alien.c-types
|
||||
compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 ;
|
||||
IN: cpu.x86.64.winnt
|
||||
|
||||
M: int-regs param-regs drop { RCX RDX R8 R9 } ;
|
||||
|
@ -10,6 +10,15 @@ M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
|
|||
|
||||
M: x86.64 reserved-area-size 4 cells ;
|
||||
|
||||
M: x86.64 struct-small-enough? ( size -- ? )
|
||||
heap-size cell <= ;
|
||||
|
||||
M: x86.64 dummy-stack-params? f ;
|
||||
|
||||
M: x86.64 dummy-int-params? t ;
|
||||
|
||||
M: x86.64 dummy-fp-params? t ;
|
||||
|
||||
<<
|
||||
"longlong" "ptrdiff_t" typedef
|
||||
"int" "long" typedef
|
||||
|
|
|
@ -467,6 +467,8 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
|
|||
|
||||
: stack@ ( n -- op ) stack-reg swap [+] ;
|
||||
|
||||
: param@ ( n -- op ) reserved-area-size + stack@ ;
|
||||
|
||||
: spill-integer-base ( stack-frame -- n )
|
||||
[ params>> ] [ return>> ] bi + reserved-area-size + ;
|
||||
|
||||
|
@ -493,16 +495,16 @@ M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ;
|
|||
|
||||
M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
|
||||
|
||||
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
|
||||
M: int-regs %load-param-reg drop swap stack@ MOV ;
|
||||
M: int-regs %save-param-reg drop >r param@ r> MOV ;
|
||||
M: int-regs %load-param-reg drop swap param@ MOV ;
|
||||
|
||||
GENERIC: MOVSS/D ( dst src reg-class -- )
|
||||
|
||||
M: single-float-regs MOVSS/D drop MOVSS ;
|
||||
M: double-float-regs MOVSS/D drop MOVSD ;
|
||||
|
||||
M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
|
||||
M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
|
||||
M: float-regs %save-param-reg >r >r param@ r> r> MOVSS/D ;
|
||||
M: float-regs %load-param-reg >r swap param@ r> MOVSS/D ;
|
||||
|
||||
GENERIC: push-return-reg ( reg-class -- )
|
||||
GENERIC: load-return-reg ( n reg-class -- )
|
||||
|
@ -518,8 +520,6 @@ M: x86 %prepare-alien-invoke
|
|||
temp-reg-1 2 cells [+] ds-reg MOV
|
||||
temp-reg-1 3 cells [+] rs-reg MOV ;
|
||||
|
||||
M: x86 fp-shadows-int? ( -- ? ) f ;
|
||||
|
||||
M: x86 value-structs? t ;
|
||||
|
||||
M: x86 small-enough? ( n -- ? )
|
||||
|
|
|
@ -77,3 +77,10 @@ IN: dlists.tests
|
|||
[ f ] [ <dlist> 3 over push-front 4 over push-back -1 swap deque-member? ] unit-test
|
||||
|
||||
[ f ] [ <dlist> 0 swap deque-member? ] unit-test
|
||||
|
||||
! Make sure clone does the right thing
|
||||
[ V{ 2 1 } V{ 2 1 3 } ] [
|
||||
<dlist> 1 over push-front 2 over push-front
|
||||
dup clone 3 over push-back
|
||||
[ dlist>seq ] bi@
|
||||
] unit-test
|
||||
|
|
|
@ -154,6 +154,14 @@ M: dlist clear-deque ( dlist -- )
|
|||
: dlist-each ( dlist quot -- )
|
||||
[ obj>> ] prepose dlist-each-node ; inline
|
||||
|
||||
: dlist>seq ( dlist -- seq )
|
||||
[ ] pusher [ dlist-each ] dip ;
|
||||
|
||||
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
|
||||
|
||||
M: dlist clone
|
||||
<dlist> [
|
||||
[ push-back ] curry dlist-each
|
||||
] keep ;
|
||||
|
||||
INSTANCE: dlist deque
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences combinators parser splitting math
|
||||
quotations arrays make qualified words ;
|
||||
quotations arrays make words ;
|
||||
IN: fry
|
||||
|
||||
: _ ( -- * ) "Only valid inside a fry" throw ;
|
||||
|
|
|
@ -1,29 +1,24 @@
|
|||
USING: help.markup help.syntax ui.commands ui.operations
|
||||
ui.tools.search ui.tools.workspace editors vocabs.loader
|
||||
kernel sequences prettyprint tools.test tools.vocabs strings
|
||||
unicode.categories unicode.case ;
|
||||
unicode.categories unicode.case ui.tools.browser ;
|
||||
IN: help.tutorial
|
||||
|
||||
ARTICLE: "first-program-start" "Creating a vocabulary for your first program"
|
||||
"Factor source code is organized into " { $link "vocabularies" } ". Before we can write our first program, we must create a vocabulary for it."
|
||||
$nl
|
||||
"Start by asking Factor for the path to your ``work'' directory, where you will place your own code:"
|
||||
"Start by loading the scaffold tool:"
|
||||
{ $code "USE: tools.scaffold" }
|
||||
"Then, ask the scaffold tool to create a new vocabulary named " { $snippet "palindrome" } ":"
|
||||
{ $code "\"resource:work\" \"palindrome\" scaffold-vocab" }
|
||||
"If you look at the output, you will see that a few files were created in your ``work'' directory. The following phrase will print the full path of your work directory:"
|
||||
{ $code "\"work\" resource-path ." }
|
||||
"Open the work directory in your file manager, and create a subdirectory named " { $snippet "palindrome" } ". Inside this directory, create a file named " { $snippet "palindrome.factor" } " using your favorite text editor. Leave the file empty for now."
|
||||
"Open the work directory in your file manager, and open the subdirectory named " { $snippet "palindrome" } ". Inside this subdirectory you will see a file named " { $snippet "palindrome.factor" } ". We will be editing this file."
|
||||
$nl
|
||||
"Inside the Factor listener, type"
|
||||
{ $code "USE: palindrome" }
|
||||
"The source file should now load. Since it is empty, it does nothing. If you get an error message, make sure you created the directory and the file in the right place and gave them the right names."
|
||||
$nl
|
||||
"Now, we will start filling out this source file. Go back to your editor, and type:"
|
||||
{ $code
|
||||
"! Copyright (C) 2008 <your name here>"
|
||||
"! See http://factorcode.org/license.txt for BSD license."
|
||||
}
|
||||
"This is the standard header for Factor source files; it consists of two " { $link "syntax-comments" } "."
|
||||
$nl
|
||||
"Now, we tell Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"
|
||||
"Notice that the file ends with an " { $link POSTPONE: IN: } " form telling Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"
|
||||
{ $code "IN: palindrome" }
|
||||
"We will add new definitions after the " { $link POSTPONE: IN: } " form."
|
||||
$nl
|
||||
"You are now ready to go on to the next section: " { $link "first-program-logic" } "." ;
|
||||
|
||||
ARTICLE: "first-program-logic" "Writing some logic in your first program"
|
||||
|
@ -43,20 +38,16 @@ $nl
|
|||
$nl
|
||||
"When you do this, you will get an error about the " { $link dup } " word not being found. This is because this word is part of the " { $vocab-link "kernel" } " vocabulary, but this vocabulary is not part of the source file's " { $link "vocabulary-search" } ". You must explicitly list dependencies in source files. This allows Factor to automatically load required vocabularies and makes larger programs easier to maintain."
|
||||
$nl
|
||||
"To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary by entering the following in the listener:"
|
||||
{ $code "\\ dup see" }
|
||||
"This shows the definition of " { $link dup } ", along with an " { $link POSTPONE: IN: } " form."
|
||||
"To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary. Enter " { $snippet "dup" } " in the listener's input area, and press " { $operation com-follow } ". This will open the documentation browser tool, viewing the help for the " { $link dup } " word. One of the subheadings in the help article will mention the word's vocabulary."
|
||||
$nl
|
||||
"Now, add the following at the start of the source file:"
|
||||
"So now, add the following at the start of the source file:"
|
||||
{ $code "USING: kernel ;" }
|
||||
"Next, find out what vocabulary " { $link reverse } " lives in:"
|
||||
{ $code "\\ reverse see" }
|
||||
"Next, find out what vocabulary " { $link reverse } " lives in; type the word name " { $snippet "reverse" } " in the workspace listener's input area, and press " { $operation com-follow } "."
|
||||
$nl
|
||||
"It lives in the " { $vocab-link "sequences" } " vocabulary, so we add that to the search path:"
|
||||
{ $code "USING: kernel sequences ;" }
|
||||
"Finally, check what vocabulary " { $link = } " lives in:"
|
||||
{ $code "\\ = see" }
|
||||
"It's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path."
|
||||
|
||||
"Finally, check what vocabulary " { $link = } " lives in, and confirm that it's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path."
|
||||
$nl
|
||||
"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors. You can now go on and learn about " { $link "first-program-test" } "." ;
|
||||
|
||||
ARTICLE: "first-program-test" "Testing your first program"
|
||||
|
@ -81,9 +72,9 @@ $nl
|
|||
{ $code "." }
|
||||
"What we just did is called " { $emphasis "interactive testing" } ". A more advanced technique which comes into play with larger programs is " { $link "tools.test" } "."
|
||||
$nl
|
||||
"Create a file named " { $snippet "palindrome-tests.factor" } " in the same directory as " { $snippet "palindrome.factor" } ". Now, we can run unit tests from the listener:"
|
||||
{ $code "\"palindrome\" test" }
|
||||
"We will add some unit tests corresponding to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
|
||||
"Open the file named " { $snippet "palindrome-tests.factor" } "; it is located in the same directory as " { $snippet "palindrome.factor" } ", and it was created by the scaffold tool."
|
||||
$nl
|
||||
"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
|
||||
$nl
|
||||
"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
|
||||
{ $code
|
||||
|
@ -145,7 +136,7 @@ $nl
|
|||
ARTICLE: "first-program" "Your first program"
|
||||
"In this tutorial, we will write a simple Factor program which prompts the user to enter a word, and tests if it is a palindrome (that is, the word is spelled the same backwards and forwards)."
|
||||
$nl
|
||||
"In this tutorial, you will learn about basic Factor development tools, as well as application deployment."
|
||||
"In this tutorial, you will learn about basic Factor development tools. You may want to open a second workspace window by pressing " { $command workspace "workflow" workspace-window } "; this will allow you to read this tutorial and browse other documentation at the same time."
|
||||
{ $subsection "first-program-start" }
|
||||
{ $subsection "first-program-logic" }
|
||||
{ $subsection "first-program-test" }
|
||||
|
|
|
@ -4,7 +4,8 @@ USING: help.markup help.syntax byte-arrays strings ;
|
|||
IN: io.encodings.string
|
||||
|
||||
ARTICLE: "io.encodings.string" "Encoding and decoding strings"
|
||||
"Strings can be encoded or decoded to and from byte arrays through an encoding with the following words:"
|
||||
"Strings can be encoded or decoded to and from byte arrays through an encoding by passing "
|
||||
{ $link "encodings-descriptors" } " to the following words:"
|
||||
{ $subsection encode }
|
||||
{ $subsection decode } ;
|
||||
|
||||
|
|
|
@ -45,15 +45,20 @@ ARTICLE: "server-config-handler" "Client handler quotation"
|
|||
$nl
|
||||
"The two methods are equivalent, representing a functional versus an object-oriented approach to the problem." ;
|
||||
|
||||
ARTICLE: "server-examples" "Threaded server examples"
|
||||
"The " { $vocab-link "time-server" } " vocabulary implements a simple threaded server which sends the current time to the client. The " { $vocab-link "concurrency.distributed" } ", " { $vocab-link "ftp.server" } ", and " { $vocab-link "http.server" } " vocabularies demonstrate more complex usage of the threaded server library." ;
|
||||
|
||||
ARTICLE: "io.servers.connection" "Threaded servers"
|
||||
"The " { $vocab-link "io.servers.connection" } " vocabulary implements a generic server abstraction for " { $link "network-connection" } ". A set of threads listen for connections, and additional threads are spawned for each client connection. In addition to this basic functionality, it provides some advanced features such as logging, connection limits and secure socket support."
|
||||
{ $subsection threaded-server }
|
||||
{ $subsection "server-config" }
|
||||
{ $subsection "server-examples" }
|
||||
"Creating threaded servers with client handler quotations:"
|
||||
{ $subsection <threaded-server> }
|
||||
"Client handlers can also be implemented by subclassing a threaded server; see " { $link "server-config-handler" } " for details:"
|
||||
{ $subsection threaded-server }
|
||||
{ $subsection new-threaded-server }
|
||||
{ $subsection handle-client* }
|
||||
"The server must be configured before it can be started."
|
||||
{ $subsection "server-config" }
|
||||
"Starting the server:"
|
||||
{ $subsection start-server }
|
||||
{ $subsection start-server* }
|
||||
|
|
|
@ -29,5 +29,5 @@ IN: io.unix.launcher.parser
|
|||
|
||||
PEG: tokenize-command ( command -- ast/f )
|
||||
'argument' " " token repeat1 list-of
|
||||
" " token repeat0 swap over pack
|
||||
" " token repeat0 tuck pack
|
||||
just ;
|
||||
|
|
|
@ -276,7 +276,7 @@ M: winnt file-system-info ( path -- file-system-info )
|
|||
swap >>type
|
||||
swap >>mount-point ;
|
||||
|
||||
: find-first-volume ( word -- string handle )
|
||||
: find-first-volume ( -- string handle )
|
||||
MAX_PATH 1+ <byte-array> dup length
|
||||
dupd
|
||||
FindFirstVolume dup win32-error=0/f
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.syntax help.markup kernel macros prettyprint
|
||||
memoize ;
|
||||
memoize combinators arrays ;
|
||||
IN: locals
|
||||
|
||||
HELP: [|
|
||||
|
@ -84,6 +84,39 @@ HELP: MEMO::
|
|||
|
||||
{ POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
|
||||
|
||||
ARTICLE: "locals-literals" "Locals in array and hashtable literals"
|
||||
"Certain data type literals are permitted to contain free variables. Any such literals are written into code which constructs an instance of the type with the free variable values spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables."
|
||||
$nl
|
||||
"The data types which receive this special handling are the following:"
|
||||
{ $list
|
||||
{ $link "arrays" }
|
||||
{ $link "hashtables" }
|
||||
{ $link "vectors" }
|
||||
{ $link "tuples" }
|
||||
}
|
||||
"This feature changes the semantics of literal object identity. An ordinary word containing a literal pushes the same literal on the stack every time it is invoked:"
|
||||
{ $example
|
||||
"IN: scratchpad"
|
||||
"TUPLE: person first-name last-name ;"
|
||||
": ordinary-word-test ( -- tuple )"
|
||||
" T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;"
|
||||
"ordinary-word-test ordinary-word-test eq? ."
|
||||
"t"
|
||||
}
|
||||
"In a word with locals, literals expand into code which constructs the literal, and so every invocation pushes a new object:"
|
||||
{ $example
|
||||
"IN: scratchpad"
|
||||
"TUPLE: person first-name last-name ;"
|
||||
":: ordinary-word-test ( -- tuple )"
|
||||
" T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;"
|
||||
"ordinary-word-test ordinary-word-test eq? ."
|
||||
"f"
|
||||
}
|
||||
"One exception to the above rule is that array instances containing no free variables do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile-time."
|
||||
$nl
|
||||
"For example, here is an implementation of the " { $link 3array } " word which uses this feature:"
|
||||
{ $code ":: 3array ( x y z -- array ) { x y z } ;" } ;
|
||||
|
||||
ARTICLE: "locals-mutable" "Mutable locals"
|
||||
"In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's name with the " { $snippet "!" } " suffix."
|
||||
$nl
|
||||
|
@ -139,6 +172,7 @@ $nl
|
|||
"Lambda abstractions:"
|
||||
{ $subsection POSTPONE: [| }
|
||||
"Additional topics:"
|
||||
{ $subsection "locals-literals" }
|
||||
{ $subsection "locals-mutable" }
|
||||
{ $subsection "locals-limitations" }
|
||||
"Locals complement dynamically scoped variables implemented in the " { $vocab-link "namespaces" } " vocabulary." ;
|
||||
|
|
|
@ -1,12 +1,8 @@
|
|||
USING: help.markup help.syntax math ;
|
||||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax math sequences ;
|
||||
IN: math.bitwise
|
||||
|
||||
ARTICLE: "math-bitfields" "Constructing bit fields"
|
||||
"Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:"
|
||||
{ $subsection bitfield } ;
|
||||
|
||||
ABOUT: "math-bitfields"
|
||||
|
||||
HELP: bitfield
|
||||
{ $values { "values..." "a series of objects" } { "bitspec" "an array" } { "n" integer } }
|
||||
{ $description "Constructs an integer from a series of values on the stack together with a bit field specifier, which is an array whose elements have one of the following shapes:"
|
||||
|
@ -42,9 +38,307 @@ HELP: bits
|
|||
{ $example "USING: math.bitwise prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ;
|
||||
|
||||
HELP: bitroll
|
||||
{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } }
|
||||
{ $values { "x" integer } { "s" "a shift integer" } { "w" "a wrap integer" } { "y" integer }
|
||||
}
|
||||
{ $description "Roll n by s bits to the left, wrapping around after w bits." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
|
||||
{ $example "USING: math.bitwise prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
|
||||
} ;
|
||||
|
||||
HELP: bit-clear?
|
||||
{ $values
|
||||
{ "x" integer } { "n" integer }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Returns " { $link t } " if the nth bit is set to zero." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise prettyprint ;"
|
||||
"HEX: ff 8 bit-clear? ."
|
||||
"t"
|
||||
}
|
||||
{ $example "" "USING: math.bitwise prettyprint ;"
|
||||
"HEX: ff 7 bit-clear? ."
|
||||
"f"
|
||||
}
|
||||
} ;
|
||||
|
||||
{ bit? bit-clear? set-bit clear-bit } related-words
|
||||
|
||||
HELP: bit-count
|
||||
{ $values
|
||||
{ "x" integer }
|
||||
{ "n" integer }
|
||||
}
|
||||
{ $description "Returns the number of set bits as an integer." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise prettyprint ;"
|
||||
"HEX: f0 bit-count ."
|
||||
"4"
|
||||
}
|
||||
{ $example "USING: math.bitwise prettyprint ;"
|
||||
"-7 bit-count ."
|
||||
"2"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: bitroll-32
|
||||
{ $values
|
||||
{ "n" integer } { "s" integer }
|
||||
{ "n'" integer }
|
||||
}
|
||||
{ $description "Rolls the number " { $snippet "n" } " by " { $snippet "s" } " bits to the left, wrapping around after 32 bits." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise prettyprint ;"
|
||||
"HEX: 1 10 bitroll-32 .h"
|
||||
"400"
|
||||
}
|
||||
{ $example "USING: math.bitwise prettyprint ;"
|
||||
"HEX: 1 -10 bitroll-32 .h"
|
||||
"400000"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: bitroll-64
|
||||
{ $values
|
||||
{ "n" integer } { "s" "a shift integer" }
|
||||
{ "n'" integer }
|
||||
}
|
||||
{ $description "Rolls the number " { $snippet "n" } " by " { $snippet "s" } " bits to the left, wrapping around after 64 bits." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise prettyprint ;"
|
||||
"HEX: 1 10 bitroll-64 .h"
|
||||
"400"
|
||||
}
|
||||
{ $example "USING: math.bitwise prettyprint ;"
|
||||
"HEX: 1 -10 bitroll-64 .h"
|
||||
"40000000000000"
|
||||
}
|
||||
} ;
|
||||
|
||||
{ bitroll bitroll-32 bitroll-64 } related-words
|
||||
|
||||
HELP: clear-bit
|
||||
{ $values
|
||||
{ "x" integer } { "n" integer }
|
||||
{ "y" integer }
|
||||
}
|
||||
{ $description "Sets the nth bit of " { $snippet "x" } " to zero." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise kernel prettyprint ;"
|
||||
"HEX: ff 7 clear-bit .h"
|
||||
"7f"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: flags
|
||||
{ $values
|
||||
{ "values" sequence }
|
||||
}
|
||||
{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at compile-time, which makes this word as efficient as using a literal integer." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise kernel prettyprint ;"
|
||||
"IN: scratchpad"
|
||||
": MY-CONSTANT HEX: 1 ; inline"
|
||||
"{ HEX: 20 MY-CONSTANT BIN: 100 } flags .h"
|
||||
"25"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: mask
|
||||
{ $values
|
||||
{ "x" integer } { "n" integer }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "After the operation, only the bits that were set in both the mask and the original number are set." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise kernel prettyprint ;"
|
||||
"BIN: 11111111 BIN: 101 mask .b"
|
||||
"101"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: mask-bit
|
||||
{ $values
|
||||
{ "m" integer } { "n" integer }
|
||||
{ "m'" integer }
|
||||
}
|
||||
{ $description "Turns off all bits besides the nth bit." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise kernel prettyprint ;"
|
||||
"HEX: ff 2 mask-bit .b"
|
||||
"100"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: mask?
|
||||
{ $values
|
||||
{ "x" integer } { "n" integer }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Returns true if all of the bits in the mask " { $snippet "n" } " are set in the integer input " { $snippet "x" } "." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise kernel prettyprint ;"
|
||||
"HEX: ff HEX: f mask? ."
|
||||
"t"
|
||||
}
|
||||
|
||||
{ $example "USING: math.bitwise kernel prettyprint ;"
|
||||
"HEX: f0 HEX: 1 mask? ."
|
||||
"f"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: on-bits
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
{ "m" integer }
|
||||
}
|
||||
{ $description "Returns an integer with " { $snippet "n" } " bits set." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise kernel prettyprint ;"
|
||||
"6 on-bits .h"
|
||||
"3f"
|
||||
}
|
||||
{ $example "USING: math.bitwise kernel prettyprint ;"
|
||||
"64 on-bits .h"
|
||||
"ffffffffffffffff"
|
||||
}
|
||||
}
|
||||
;
|
||||
|
||||
HELP: set-bit
|
||||
{ $values
|
||||
{ "x" integer } { "n" integer }
|
||||
{ "y" integer }
|
||||
}
|
||||
{ $description "Sets the nth bit of " { $snippet "x" } "." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise kernel prettyprint ;"
|
||||
"0 5 set-bit .h"
|
||||
"20"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: shift-mod
|
||||
{ $values
|
||||
{ "n" integer } { "s" integer } { "w" integer }
|
||||
{ "n" integer }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: unmask
|
||||
{ $values
|
||||
{ "x" integer } { "n" integer }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Clears the bits in " { $snippet "x" } " if they are set in the mask " { $snippet "n" } "." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise kernel prettyprint ;"
|
||||
"HEX: ff HEX: 0f unmask .h"
|
||||
"f0"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: unmask?
|
||||
{ $values
|
||||
{ "x" integer } { "n" integer }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Tests whether unmasking the bits in " { $snippet "x" } " would return an integer greater than zero." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise kernel prettyprint ;"
|
||||
"HEX: ff HEX: 0f unmask? ."
|
||||
"t"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: w*
|
||||
{ $values
|
||||
{ "int" integer } { "int" integer }
|
||||
{ "int" integer }
|
||||
}
|
||||
{ $description "Multiplies two integers and wraps the result to 32 bits." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise kernel prettyprint ;"
|
||||
"HEX: ffffffff HEX: 2 w* ."
|
||||
"4294967294"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: w+
|
||||
{ $values
|
||||
{ "int" integer } { "int" integer }
|
||||
{ "int" integer }
|
||||
}
|
||||
{ $description "Adds two integers and wraps the result to 32 bits." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise kernel prettyprint ;"
|
||||
"HEX: ffffffff HEX: 2 w+ ."
|
||||
"1"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: w-
|
||||
{ $values
|
||||
{ "int" integer } { "int" integer }
|
||||
{ "int" integer }
|
||||
}
|
||||
{ $description "Subtracts two integers and wraps the result to 32 bits." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise kernel prettyprint ;"
|
||||
"HEX: 0 HEX: ff w- ."
|
||||
"4294967041"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: wrap
|
||||
{ $values
|
||||
{ "m" integer } { "n" integer }
|
||||
{ "m'" integer }
|
||||
}
|
||||
{ $description "Wraps an integer " { $snippet "m" } " by modding it by " { $snippet "n" } ". This word is uses bitwise arithmetic and does not actually call the modulus word, and as such can only mod by powers of two." }
|
||||
{ $examples "Equivalent to modding by 8:"
|
||||
{ $example
|
||||
"USING: math.bitwise prettyprint ;"
|
||||
"HEX: ffff 8 wrap .h"
|
||||
"7"
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "math-bitfields" "Constructing bit fields"
|
||||
"Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:"
|
||||
{ $subsection bitfield } ;
|
||||
|
||||
ARTICLE: "math.bitwise" "Bitwise arithmetic"
|
||||
"The " { $vocab-link "math.bitwise" } " vocabulary can implements bitwise arithmetic words that are useful for efficiency, low-level programming, and interfacing with C libraries." $nl
|
||||
"Setting and clearing bits:"
|
||||
{ $subsection set-bit }
|
||||
{ $subsection clear-bit }
|
||||
"Testing if bits are set or clear:"
|
||||
{ $subsection bit? }
|
||||
{ $subsection bit-clear? }
|
||||
"Operations with bitmasks:"
|
||||
{ $subsection mask }
|
||||
{ $subsection unmask }
|
||||
{ $subsection mask? }
|
||||
{ $subsection unmask? }
|
||||
"Generating an integer with n set bits:"
|
||||
{ $subsection on-bits }
|
||||
"Counting the number of set bits:"
|
||||
{ $subsection bit-count }
|
||||
"More efficient modding by powers of two:"
|
||||
{ $subsection wrap }
|
||||
"Bit-rolling:"
|
||||
{ $subsection bitroll }
|
||||
{ $subsection bitroll-32 }
|
||||
{ $subsection bitroll-64 }
|
||||
"32-bit arithmetic:"
|
||||
{ $subsection w+ }
|
||||
{ $subsection w- }
|
||||
{ $subsection w* }
|
||||
"Bitfields:"
|
||||
{ $subsection flags }
|
||||
{ $subsection "math-bitfields" } ;
|
||||
|
||||
ABOUT: "math.bitwise"
|
||||
|
|
|
@ -27,3 +27,5 @@ IN: math.bitwise.tests
|
|||
[ 3 ] [ foo ] unit-test
|
||||
[ 3 ] [ { a b } flags ] unit-test
|
||||
\ foo must-infer
|
||||
|
||||
[ 1 ] [ { 1 } flags ] unit-test
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math math.functions sequences
|
||||
sequences.private words namespaces macros hints
|
||||
|
@ -8,28 +8,29 @@ IN: math.bitwise
|
|||
! utilities
|
||||
: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
|
||||
: set-bit ( x n -- y ) 2^ bitor ; inline
|
||||
: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline
|
||||
: bit-clear? ( x n -- ? ) 2^ bitand 0 = ; inline
|
||||
: unmask ( x n -- ? ) bitnot bitand ; inline
|
||||
: unmask? ( x n -- ? ) unmask 0 > ; inline
|
||||
: mask ( x n -- ? ) bitand ; inline
|
||||
: mask? ( x n -- ? ) mask 0 > ; inline
|
||||
: wrap ( m n -- m' ) 1- bitand ; inline
|
||||
: bits ( m n -- m' ) 2^ wrap ; inline
|
||||
: mask-bit ( m n -- m' ) 1- 2^ mask ; inline
|
||||
: mask-bit ( m n -- m' ) 2^ mask ; inline
|
||||
: on-bits ( n -- m ) 2^ 1- ; inline
|
||||
|
||||
: shift-mod ( n s w -- n )
|
||||
>r shift r> 2^ wrap ; inline
|
||||
[ shift ] dip 2^ wrap ; inline
|
||||
|
||||
: bitroll ( x s w -- y )
|
||||
[ wrap ] keep
|
||||
[ shift-mod ]
|
||||
[ [ - ] keep shift-mod ] 3bi bitor ; inline
|
||||
[ wrap ] keep
|
||||
[ shift-mod ]
|
||||
[ [ - ] keep shift-mod ] 3bi bitor ; inline
|
||||
|
||||
: bitroll-32 ( n s -- n' ) 32 bitroll ;
|
||||
: bitroll-32 ( n s -- n' ) 32 bitroll ; inline
|
||||
|
||||
HINTS: bitroll-32 bignum fixnum ;
|
||||
|
||||
: bitroll-64 ( n s -- n' ) 64 bitroll ;
|
||||
: bitroll-64 ( n s -- n' ) 64 bitroll ; inline
|
||||
|
||||
HINTS: bitroll-64 bignum fixnum ;
|
||||
|
||||
|
@ -40,7 +41,7 @@ HINTS: bitroll-64 bignum fixnum ;
|
|||
|
||||
! flags
|
||||
MACRO: flags ( values -- )
|
||||
[ 0 ] [ [ execute bitor ] curry compose ] reduce ;
|
||||
[ 0 ] [ [ dup word? [ execute ] when bitor ] curry compose ] reduce ;
|
||||
|
||||
! bitfield
|
||||
<PRIVATE
|
||||
|
@ -51,7 +52,7 @@ M: integer (bitfield-quot) ( spec -- quot )
|
|||
[ swapd shift bitor ] curry ;
|
||||
|
||||
M: pair (bitfield-quot) ( spec -- quot )
|
||||
first2 over word? [ >r swapd execute r> ] [ ] ?
|
||||
first2 over word? [ [ swapd execute ] dip ] [ ] ?
|
||||
[ shift bitor ] append 2curry ;
|
||||
|
||||
PRIVATE>
|
||||
|
@ -91,4 +92,4 @@ M: bignum (bit-count)
|
|||
PRIVATE>
|
||||
|
||||
: bit-count ( x -- n )
|
||||
dup 0 >= [ (bit-count) ] [ bitnot (bit-count) ] if ; inline
|
||||
dup 0 < [ bitnot ] when (bit-count) ; inline
|
||||
|
|
|
@ -134,3 +134,6 @@ IN: math.functions.tests
|
|||
[ -4.0 ] [ -4.4 round ] unit-test
|
||||
[ 5.0 ] [ 4.5 round ] unit-test
|
||||
[ 4.0 ] [ 4.4 round ] unit-test
|
||||
|
||||
[ 6 59967 ] [ 3837888 factor-2s ] unit-test
|
||||
[ 6 -59967 ] [ -3837888 factor-2s ] unit-test
|
||||
|
|
|
@ -1,9 +1,12 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel math.constants math.private
|
||||
math.libm combinators math.order ;
|
||||
math.libm combinators math.order sequences ;
|
||||
IN: math.functions
|
||||
|
||||
: >fraction ( a/b -- a b )
|
||||
[ numerator ] [ denominator ] bi ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (rect>) ( x y -- z )
|
||||
|
@ -30,14 +33,35 @@ M: real sqrt
|
|||
2dup >r >r >r odd? r> call r> 2/ r> each-bit
|
||||
] if ; inline recursive
|
||||
|
||||
: ^n ( z w -- z^w )
|
||||
1 swap [
|
||||
[ dupd * ] when >r sq r>
|
||||
] each-bit nip ; inline
|
||||
: map-bits ( n quot: ( ? -- obj ) -- seq )
|
||||
accumulator [ each-bit ] dip ; inline
|
||||
|
||||
: factor-2s ( n -- r s )
|
||||
#! factor an integer into 2^r * s
|
||||
dup 0 = [ 1 ] [
|
||||
0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while
|
||||
] if ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC# ^n 1 ( z w -- z^w )
|
||||
|
||||
: (^n) 1 swap [ [ dupd * ] when [ sq ] dip ] each-bit nip ; inline
|
||||
|
||||
M: integer ^n
|
||||
[ factor-2s ] dip [ (^n) ] keep rot * shift ;
|
||||
|
||||
M: ratio ^n
|
||||
[ >fraction ] dip tuck [ ^n ] 2bi@ / ;
|
||||
|
||||
M: float ^n
|
||||
(^n) ;
|
||||
|
||||
: integer^ ( x y -- z )
|
||||
dup 0 > [ ^n ] [ neg ^n recip ] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: >rect ( z -- x y )
|
||||
[ real-part ] [ imaginary-part ] bi ; inline
|
||||
|
||||
|
@ -52,6 +76,8 @@ M: real sqrt
|
|||
|
||||
: polar> ( abs arg -- z ) cis * ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: ^mag ( w abs arg -- magnitude )
|
||||
>r >r >float-rect swap r> swap fpow r> rot * fexp /f ;
|
||||
inline
|
||||
|
@ -68,6 +94,8 @@ M: real sqrt
|
|||
: 0^ ( x -- z )
|
||||
dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: ^ ( x y -- z )
|
||||
{
|
||||
{ [ over zero? ] [ nip 0^ ] }
|
||||
|
|
|
@ -95,6 +95,10 @@ IN: math.intervals.tests
|
|||
|
||||
[ empty-interval ] [ 0 5 (a,b] empty-interval interval-intersect ] unit-test
|
||||
|
||||
[ t ] [
|
||||
0 1 (a,b) full-interval interval-intersect 0 1 (a,b) =
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
empty-interval empty-interval interval-subset?
|
||||
] unit-test
|
||||
|
@ -209,22 +213,28 @@ IN: math.intervals.tests
|
|||
|
||||
! Interval random tester
|
||||
: random-element ( interval -- n )
|
||||
dup to>> first over from>> first tuck - random +
|
||||
2dup swap interval-contains? [
|
||||
nip
|
||||
dup full-interval eq? [
|
||||
drop 32 random-bits 31 2^ -
|
||||
] [
|
||||
drop random-element
|
||||
dup to>> first over from>> first tuck - random +
|
||||
2dup swap interval-contains? [
|
||||
nip
|
||||
] [
|
||||
drop random-element
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: random-interval ( -- interval )
|
||||
2000 random 1000 - dup 2 1000 random + +
|
||||
1 random zero? [ [ neg ] bi@ swap ] when
|
||||
4 random {
|
||||
{ 0 [ [a,b] ] }
|
||||
{ 1 [ [a,b) ] }
|
||||
{ 2 [ (a,b) ] }
|
||||
{ 3 [ (a,b] ] }
|
||||
} case ;
|
||||
10 random 0 = [ full-interval ] [
|
||||
2000 random 1000 - dup 2 1000 random + +
|
||||
1 random zero? [ [ neg ] bi@ swap ] when
|
||||
4 random {
|
||||
{ 0 [ [a,b] ] }
|
||||
{ 1 [ [a,b) ] }
|
||||
{ 2 [ (a,b) ] }
|
||||
{ 3 [ (a,b] ] }
|
||||
} case
|
||||
] if ;
|
||||
|
||||
: random-unary-op ( -- pair )
|
||||
{
|
||||
|
@ -263,7 +273,7 @@ IN: math.intervals.tests
|
|||
{ bitand interval-bitand }
|
||||
{ bitor interval-bitor }
|
||||
{ bitxor interval-bitxor }
|
||||
{ shift interval-shift }
|
||||
! { shift interval-shift }
|
||||
{ min interval-min }
|
||||
{ max interval-max }
|
||||
}
|
||||
|
|
|
@ -7,6 +7,8 @@ IN: math.intervals
|
|||
|
||||
SYMBOL: empty-interval
|
||||
|
||||
SYMBOL: full-interval
|
||||
|
||||
TUPLE: interval { from read-only } { to read-only } ;
|
||||
|
||||
: <interval> ( from to -- int )
|
||||
|
@ -46,8 +48,7 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
|
||||
: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline
|
||||
|
||||
: [-inf,inf] ( -- interval )
|
||||
T{ interval f { -1./0. t } { 1./0. t } } ; inline
|
||||
: [-inf,inf] ( -- interval ) full-interval ; inline
|
||||
|
||||
: compare-endpoints ( p1 p2 quot -- ? )
|
||||
>r over first over first r> call [
|
||||
|
@ -99,8 +100,10 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
|
||||
: do-empty-interval ( i1 i2 quot -- i3 )
|
||||
{
|
||||
{ [ pick empty-interval eq? ] [ drop drop ] }
|
||||
{ [ pick empty-interval eq? ] [ 2drop ] }
|
||||
{ [ over empty-interval eq? ] [ drop nip ] }
|
||||
{ [ pick full-interval eq? ] [ 2drop ] }
|
||||
{ [ over full-interval eq? ] [ drop nip ] }
|
||||
[ call ]
|
||||
} cond ; inline
|
||||
|
||||
|
@ -112,8 +115,10 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
|
||||
: interval-intersect ( i1 i2 -- i3 )
|
||||
{
|
||||
{ [ dup empty-interval eq? ] [ nip ] }
|
||||
{ [ over empty-interval eq? ] [ drop ] }
|
||||
{ [ dup empty-interval eq? ] [ nip ] }
|
||||
{ [ over full-interval eq? ] [ nip ] }
|
||||
{ [ dup full-interval eq? ] [ drop ] }
|
||||
[
|
||||
[ interval>points ] bi@ swapd
|
||||
[ [ swap endpoint< ] most ]
|
||||
|
@ -127,8 +132,10 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
|
||||
: interval-union ( i1 i2 -- i3 )
|
||||
{
|
||||
{ [ dup empty-interval eq? ] [ drop ] }
|
||||
{ [ over empty-interval eq? ] [ nip ] }
|
||||
{ [ dup empty-interval eq? ] [ drop ] }
|
||||
{ [ over full-interval eq? ] [ drop ] }
|
||||
{ [ dup full-interval eq? ] [ nip ] }
|
||||
[ [ interval>points 2array ] bi@ append points>interval ]
|
||||
} cond ;
|
||||
|
||||
|
@ -137,9 +144,11 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
|
||||
: interval-contains? ( x int -- ? )
|
||||
dup empty-interval eq? [ 2drop f ] [
|
||||
[ from>> first2 [ >= ] [ > ] if ]
|
||||
[ to>> first2 [ <= ] [ < ] if ]
|
||||
2bi and
|
||||
dup full-interval eq? [ 2drop t ] [
|
||||
[ from>> first2 [ >= ] [ > ] if ]
|
||||
[ to>> first2 [ <= ] [ < ] if ]
|
||||
2bi and
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: interval-zero? ( int -- ? )
|
||||
|
@ -160,8 +169,11 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
|
||||
: interval-sq ( i1 -- i2 ) dup interval* ;
|
||||
|
||||
: special-interval? ( interval -- ? )
|
||||
{ empty-interval full-interval } memq? ;
|
||||
|
||||
: interval-singleton? ( int -- ? )
|
||||
dup empty-interval eq? [
|
||||
dup special-interval? [
|
||||
drop f
|
||||
] [
|
||||
interval>points
|
||||
|
@ -173,6 +185,7 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
: interval-length ( int -- n )
|
||||
{
|
||||
{ [ dup empty-interval eq? ] [ drop 0 ] }
|
||||
{ [ dup full-interval eq? ] [ drop 1/0. ] }
|
||||
[ interval>points [ first ] bi@ swap - ]
|
||||
} cond ;
|
||||
|
||||
|
@ -211,7 +224,7 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
[ [ interval-closure ] bi@ [ min ] interval-op ] do-empty-interval ;
|
||||
|
||||
: interval-interior ( i1 -- i2 )
|
||||
dup empty-interval eq? [
|
||||
dup special-interval? [
|
||||
interval>points [ first ] bi@ (a,b)
|
||||
] unless ;
|
||||
|
||||
|
@ -249,6 +262,7 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
: interval-abs ( i1 -- i2 )
|
||||
{
|
||||
{ [ dup empty-interval eq? ] [ ] }
|
||||
{ [ dup full-interval eq? ] [ drop 0 [a,inf] ] }
|
||||
{ [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
|
||||
[ (interval-abs) points>interval ]
|
||||
} cond ;
|
||||
|
@ -292,7 +306,7 @@ SYMBOL: incomparable
|
|||
|
||||
: interval< ( i1 i2 -- ? )
|
||||
{
|
||||
{ [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
|
||||
{ [ 2dup [ special-interval? ] either? ] [ incomparable ] }
|
||||
{ [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
|
||||
{ [ 2dup left-endpoint-< ] [ f ] }
|
||||
{ [ 2dup right-endpoint-< ] [ f ] }
|
||||
|
@ -307,7 +321,7 @@ SYMBOL: incomparable
|
|||
|
||||
: interval<= ( i1 i2 -- ? )
|
||||
{
|
||||
{ [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
|
||||
{ [ 2dup [ special-interval? ] either? ] [ incomparable ] }
|
||||
{ [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
|
||||
{ [ 2dup right-endpoint-<= ] [ t ] }
|
||||
[ incomparable ]
|
||||
|
@ -360,27 +374,27 @@ SYMBOL: incomparable
|
|||
interval-bitor ;
|
||||
|
||||
: assume< ( i1 i2 -- i3 )
|
||||
dup empty-interval eq? [ drop ] [
|
||||
dup special-interval? [ drop ] [
|
||||
to>> first [-inf,a) interval-intersect
|
||||
] if ;
|
||||
|
||||
: assume<= ( i1 i2 -- i3 )
|
||||
dup empty-interval eq? [ drop ] [
|
||||
dup special-interval? [ drop ] [
|
||||
to>> first [-inf,a] interval-intersect
|
||||
] if ;
|
||||
|
||||
: assume> ( i1 i2 -- i3 )
|
||||
dup empty-interval eq? [ drop ] [
|
||||
dup special-interval? [ drop ] [
|
||||
from>> first (a,inf] interval-intersect
|
||||
] if ;
|
||||
|
||||
: assume>= ( i1 i2 -- i3 )
|
||||
dup empty-interval eq? [ drop ] [
|
||||
dup special-interval? [ drop ] [
|
||||
from>> first [a,inf] interval-intersect
|
||||
] if ;
|
||||
|
||||
: integral-closure ( i1 -- i2 )
|
||||
dup empty-interval eq? [
|
||||
dup special-interval? [
|
||||
[ from>> first2 [ 1+ ] unless ]
|
||||
[ to>> first2 [ 1- ] unless ]
|
||||
bi [a,b]
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax math math.private
|
||||
math.ratios.private ;
|
||||
math.ratios.private math.functions ;
|
||||
IN: math.ratios
|
||||
|
||||
ARTICLE: "rationals" "Rational numbers"
|
||||
|
|
|
@ -3,9 +3,6 @@
|
|||
USING: accessors kernel kernel.private math math.functions math.private ;
|
||||
IN: math.ratios
|
||||
|
||||
: >fraction ( a/b -- a b )
|
||||
dup numerator swap denominator ; inline
|
||||
|
||||
: 2>fraction ( a/b c/d -- a c b d )
|
||||
[ >fraction ] bi@ swapd ; inline
|
||||
|
||||
|
|
|
@ -9,14 +9,6 @@ HELP: gl-color
|
|||
HELP: gl-error
|
||||
{ $description "If the most recent OpenGL call resulted in an error, print the error to " { $link output-stream } "." } ;
|
||||
|
||||
HELP: do-state
|
||||
{
|
||||
$values
|
||||
{ "mode" { "One of the " { $link "opengl-geometric-primitives" } } }
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "Wraps a quotation in " { $link glBegin } "/" { $link glEnd } " calls." } ;
|
||||
|
||||
HELP: do-enabled
|
||||
{ $values { "what" integer } { "quot" quotation } }
|
||||
{ $description "Wraps a quotation in " { $link glEnable } "/" { $link glDisable } " calls." } ;
|
||||
|
@ -25,37 +17,17 @@ HELP: do-matrix
|
|||
{ $values { "mode" { $link GL_MODELVIEW } " or " { $link GL_PROJECTION } } { "quot" quotation } }
|
||||
{ $description "Saves and restores the matrix specified by " { $snippet "mode" } " before and after calling the quotation." } ;
|
||||
|
||||
HELP: gl-vertex
|
||||
{ $values { "point" "a pair of integers" } }
|
||||
{ $description "Wrapper for " { $link glVertex2d } " taking a point object." } ;
|
||||
|
||||
HELP: gl-line
|
||||
{ $values { "a" "a pair of integers" } { "b" "a pair of integers" } }
|
||||
{ $description "Draws a line between two points." } ;
|
||||
|
||||
HELP: gl-fill-rect
|
||||
{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
|
||||
{ $description "Draws a filled rectangle with top-left corner " { $snippet "loc" } " and bottom-right corner " { $snippet "ext" } "." } ;
|
||||
{ $values { "dim" "a pair of integers" } }
|
||||
{ $description "Draws a filled rectangle with the top-left corner at the origin and the given dimensions." } ;
|
||||
|
||||
HELP: gl-rect
|
||||
{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
|
||||
{ $description "Draws the outline of a rectangle with top-left corner " { $snippet "loc" } " and bottom-right corner " { $snippet "ext" } "." } ;
|
||||
|
||||
HELP: rect-vertices
|
||||
{ $values { "lower-left" "A pair of numbers indicating the lower-left coordinates of the rectangle." } { "upper-right" "The upper-right coordinates of the rectangle." } }
|
||||
{ $description "Emits" { $link glVertex2d } " calls outlining the axis-aligned rectangle from " { $snippet "lower-left" } " to " { $snippet "upper-right" } " on the z=0 plane in counterclockwise order." } ;
|
||||
|
||||
HELP: gl-fill-poly
|
||||
{ $values { "points" "a sequence of pairs of integers" } }
|
||||
{ $description "Draws a filled polygon." } ;
|
||||
|
||||
HELP: gl-poly
|
||||
{ $values { "points" "a sequence of pairs of integers" } }
|
||||
{ $description "Draws the outline of a polygon." } ;
|
||||
|
||||
HELP: gl-gradient
|
||||
{ $values { "direction" "an orientation specifier" } { "colors" "a sequence of color specifiers" } { "dim" "a pair of integers" } }
|
||||
{ $description "Draws a rectangle with top-left corner " { $snippet "{ 0 0 }" } " and dimensions " { $snippet "dim" } ", filled with a smoothly shaded transition between the colors in " { $snippet "colors" } "." } ;
|
||||
{ $values { "dim" "a pair of integers" } }
|
||||
{ $description "Draws the outline of a rectangle with the top-left corner at the origin and the given dimensions." } ;
|
||||
|
||||
HELP: gen-texture
|
||||
{ $values { "id" integer } }
|
||||
|
@ -131,12 +103,10 @@ $nl
|
|||
{ $subsection "opengl-low-level" }
|
||||
"Wrappers:"
|
||||
{ $subsection gl-color }
|
||||
{ $subsection gl-vertex }
|
||||
{ $subsection gl-translate }
|
||||
{ $subsection gen-texture }
|
||||
{ $subsection bind-texture-unit }
|
||||
"Combinators:"
|
||||
{ $subsection do-state }
|
||||
{ $subsection do-enabled }
|
||||
{ $subsection do-attribs }
|
||||
{ $subsection do-matrix }
|
||||
|
@ -146,9 +116,6 @@ $nl
|
|||
{ $subsection gl-line }
|
||||
{ $subsection gl-fill-rect }
|
||||
{ $subsection gl-rect }
|
||||
{ $subsection gl-fill-poly }
|
||||
{ $subsection gl-poly }
|
||||
{ $subsection gl-gradient }
|
||||
;
|
||||
|
||||
ABOUT: "gl-utilities"
|
||||
|
|
|
@ -2,44 +2,31 @@
|
|||
! Portions copyright (C) 2007 Eduardo Cavazos.
|
||||
! Portions copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: alien alien.c-types continuations kernel libc math macros
|
||||
namespaces math.vectors math.constants math.functions
|
||||
math.parser opengl.gl opengl.glu combinators arrays sequences
|
||||
splitting words byte-arrays assocs colors accessors ;
|
||||
|
||||
namespaces math.vectors math.constants math.functions
|
||||
math.parser opengl.gl opengl.glu combinators arrays sequences
|
||||
splitting words byte-arrays assocs colors accessors
|
||||
generalizations locals memoize ;
|
||||
IN: opengl
|
||||
|
||||
: coordinates ( point1 point2 -- x1 y2 x2 y2 )
|
||||
[ first2 ] bi@ ;
|
||||
: color>raw ( object -- r g b a )
|
||||
>rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline
|
||||
|
||||
: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
|
||||
[ first2 [ >fixnum ] bi@ ] bi@ ;
|
||||
: gl-color ( color -- ) color>raw glColor4d ; inline
|
||||
|
||||
: gl-color ( color -- ) first4 glColor4d ; inline
|
||||
|
||||
: gl-clear-color ( color -- )
|
||||
first4 glClearColor ;
|
||||
: gl-clear-color ( color -- ) color>raw glClearColor ;
|
||||
|
||||
: gl-clear ( color -- )
|
||||
gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
|
||||
|
||||
: color>raw ( object -- r g b a )
|
||||
>rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ;
|
||||
|
||||
: set-color ( object -- ) color>raw glColor4d ;
|
||||
: set-clear-color ( object -- ) color>raw glClearColor ;
|
||||
|
||||
: gl-error ( -- )
|
||||
glGetError dup zero? [
|
||||
"GL error: " over gluErrorString append throw
|
||||
] unless drop ;
|
||||
|
||||
: do-state ( mode quot -- )
|
||||
swap glBegin call glEnd ; inline
|
||||
|
||||
: do-enabled ( what quot -- )
|
||||
over glEnable dip glDisable ; inline
|
||||
|
||||
: do-enabled-client-state ( what quot -- )
|
||||
over glEnableClientState dip glDisableClientState ; inline
|
||||
|
||||
|
@ -48,6 +35,7 @@ IN: opengl
|
|||
|
||||
: (all-enabled) ( seq quot -- )
|
||||
over [ glEnable ] each dip [ glDisable ] each ; inline
|
||||
|
||||
: (all-enabled-client-state) ( seq quot -- )
|
||||
[ dup [ glEnableClientState ] each ] dip
|
||||
dip
|
||||
|
@ -55,6 +43,7 @@ IN: opengl
|
|||
|
||||
MACRO: all-enabled ( seq quot -- )
|
||||
>r words>values r> [ (all-enabled) ] 2curry ;
|
||||
|
||||
MACRO: all-enabled-client-state ( seq quot -- )
|
||||
>r words>values r> [ (all-enabled-client-state) ] 2curry ;
|
||||
|
||||
|
@ -62,37 +51,57 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
swap [ glMatrixMode glPushMatrix call ] keep
|
||||
glMatrixMode glPopMatrix ; inline
|
||||
|
||||
: gl-vertex ( point -- )
|
||||
dup length {
|
||||
{ 2 [ first2 glVertex2d ] }
|
||||
{ 3 [ first3 glVertex3d ] }
|
||||
{ 4 [ first4 glVertex4d ] }
|
||||
} case ;
|
||||
|
||||
: gl-normal ( normal -- ) first3 glNormal3d ;
|
||||
|
||||
: gl-material ( face pname params -- )
|
||||
>c-float-array glMaterialfv ;
|
||||
|
||||
: gl-vertex-pointer ( seq -- )
|
||||
[ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline
|
||||
|
||||
: gl-color-pointer ( seq -- )
|
||||
[ 4 GL_FLOAT 0 ] dip glColorPointer ; inline
|
||||
|
||||
: gl-texture-coord-pointer ( seq -- )
|
||||
[ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline
|
||||
|
||||
: line-vertices ( a b -- )
|
||||
append >c-float-array gl-vertex-pointer ;
|
||||
|
||||
: gl-line ( a b -- )
|
||||
GL_LINES [ gl-vertex gl-vertex ] do-state ;
|
||||
line-vertices GL_LINES 0 2 glDrawArrays ;
|
||||
|
||||
: gl-fill-rect ( loc ext -- )
|
||||
coordinates glRectd ;
|
||||
: (rect-vertices) ( dim -- vertices )
|
||||
{
|
||||
[ drop 0 1 ]
|
||||
[ first 1- 1 ]
|
||||
[ [ first 1- ] [ second ] bi ]
|
||||
[ second 0 swap ]
|
||||
} cleave 8 narray >c-float-array ;
|
||||
|
||||
: gl-rect ( loc ext -- )
|
||||
GL_FRONT_AND_BACK GL_LINE glPolygonMode
|
||||
>r { 0.5 0.5 } v+ r> { 0.5 0.5 } v- gl-fill-rect
|
||||
GL_FRONT_AND_BACK GL_FILL glPolygonMode ;
|
||||
: rect-vertices ( dim -- )
|
||||
(rect-vertices) gl-vertex-pointer ;
|
||||
|
||||
: (gl-poly) ( points state -- )
|
||||
[ [ gl-vertex ] each ] do-state ;
|
||||
: (gl-rect) ( -- )
|
||||
GL_LINE_LOOP 0 4 glDrawArrays ;
|
||||
|
||||
: gl-fill-poly ( points -- )
|
||||
dup length 2 > GL_POLYGON GL_LINES ? (gl-poly) ;
|
||||
: gl-rect ( dim -- )
|
||||
rect-vertices (gl-rect) ;
|
||||
|
||||
: gl-poly ( points -- )
|
||||
GL_LINE_LOOP (gl-poly) ;
|
||||
: (fill-rect-vertices) ( dim -- vertices )
|
||||
{
|
||||
[ drop 0 0 ]
|
||||
[ first 0 ]
|
||||
[ first2 ]
|
||||
[ second 0 swap ]
|
||||
} cleave 8 narray >c-float-array ;
|
||||
|
||||
: fill-rect-vertices ( dim -- )
|
||||
(fill-rect-vertices) gl-vertex-pointer ;
|
||||
|
||||
: (gl-fill-rect) ( -- )
|
||||
GL_QUADS 0 4 glDrawArrays ;
|
||||
|
||||
: gl-fill-rect ( dim -- )
|
||||
fill-rect-vertices (gl-fill-rect) ;
|
||||
|
||||
: circle-steps ( steps -- angles )
|
||||
dup length v/n 2 pi * v*n ;
|
||||
|
@ -109,35 +118,24 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
: circle-points ( loc dim steps -- points )
|
||||
circle-steps unit-circle adjust-points scale-points ;
|
||||
|
||||
: gl-circle ( loc dim steps -- )
|
||||
circle-points gl-poly ;
|
||||
|
||||
: gl-fill-circle ( loc dim steps -- )
|
||||
circle-points gl-fill-poly ;
|
||||
|
||||
: prepare-gradient ( direction dim -- v1 v2 )
|
||||
tuck v* [ v- ] keep ;
|
||||
|
||||
: gl-gradient ( direction colors dim -- )
|
||||
GL_QUAD_STRIP [
|
||||
swap >r prepare-gradient r>
|
||||
[ length dup 1- v/n ] keep [
|
||||
>r >r 2dup r> r> set-color v*n
|
||||
dup gl-vertex v+ gl-vertex
|
||||
] 2each 2drop
|
||||
] do-state ;
|
||||
: circle-vertices ( loc dim steps -- vertices )
|
||||
circle-points concat >c-float-array ;
|
||||
|
||||
: (gen-gl-object) ( quot -- id )
|
||||
>r 1 0 <uint> r> keep *uint ; inline
|
||||
|
||||
: gen-texture ( -- id )
|
||||
[ glGenTextures ] (gen-gl-object) ;
|
||||
|
||||
: gen-gl-buffer ( -- id )
|
||||
[ glGenBuffers ] (gen-gl-object) ;
|
||||
|
||||
: (delete-gl-object) ( id quot -- )
|
||||
>r 1 swap <uint> r> call ; inline
|
||||
|
||||
: delete-texture ( id -- )
|
||||
[ glDeleteTextures ] (delete-gl-object) ;
|
||||
|
||||
: delete-gl-buffer ( id -- )
|
||||
[ glDeleteBuffers ] (delete-gl-object) ;
|
||||
|
||||
|
@ -205,35 +203,21 @@ TUPLE: sprite loc dim dim2 dlist texture ;
|
|||
|
||||
: gl-translate ( point -- ) first2 0.0 glTranslated ;
|
||||
|
||||
<PRIVATE
|
||||
MEMO: (rect-texture-coords) ( -- seq )
|
||||
{ 0 0 1 0 1 1 0 1 } >c-float-array ;
|
||||
|
||||
: top-left drop 0 0 glTexCoord2i 0.0 0.0 glVertex2d ; inline
|
||||
|
||||
: top-right 1 0 glTexCoord2i first 0.0 glVertex2d ; inline
|
||||
|
||||
: bottom-left 0 1 glTexCoord2i second 0.0 swap glVertex2d ; inline
|
||||
|
||||
: bottom-right 1 1 glTexCoord2i gl-vertex ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: four-sides ( dim -- )
|
||||
dup top-left dup top-right dup bottom-right bottom-left ;
|
||||
: rect-texture-coords ( -- )
|
||||
(rect-texture-coords) gl-texture-coord-pointer ;
|
||||
|
||||
: draw-sprite ( sprite -- )
|
||||
dup loc>> gl-translate
|
||||
GL_TEXTURE_2D over texture>> glBindTexture
|
||||
init-texture
|
||||
GL_QUADS [ dim2>> four-sides ] do-state
|
||||
GL_TEXTURE_2D 0 glBindTexture ;
|
||||
|
||||
: rect-vertices ( lower-left upper-right -- )
|
||||
GL_QUADS [
|
||||
over first2 glVertex2d
|
||||
dup first pick second glVertex2d
|
||||
dup first2 glVertex2d
|
||||
swap first swap second glVertex2d
|
||||
] do-state ;
|
||||
GL_TEXTURE_COORD_ARRAY [
|
||||
dup loc>> gl-translate
|
||||
GL_TEXTURE_2D over texture>> glBindTexture
|
||||
init-texture rect-texture-coords
|
||||
dim2>> fill-rect-vertices
|
||||
(gl-fill-rect)
|
||||
GL_TEXTURE_2D 0 glBindTexture
|
||||
] do-enabled-client-state ;
|
||||
|
||||
: make-sprite-dlist ( sprite -- id )
|
||||
GL_MODELVIEW [
|
||||
|
@ -256,6 +240,9 @@ PRIVATE>
|
|||
: with-translation ( loc quot -- )
|
||||
GL_MODELVIEW [ >r gl-translate r> call ] do-matrix ; inline
|
||||
|
||||
: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
|
||||
[ first2 [ >fixnum ] bi@ ] bi@ ;
|
||||
|
||||
: gl-set-clip ( loc dim -- )
|
||||
fix-coordinates glScissor ;
|
||||
|
||||
|
|
|
@ -487,7 +487,7 @@ M: ebnf-terminal (transform) ( ast -- parser )
|
|||
M: ebnf-foreign (transform) ( ast -- parser )
|
||||
dup word>> search
|
||||
[ "Foreign word '" swap word>> append "' not found" append throw ] unless*
|
||||
swap rule>> [ main ] unless* dupd swap rule [
|
||||
swap rule>> [ main ] unless* over rule [
|
||||
nip
|
||||
] [
|
||||
execute
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
USING: prettyprint.backend prettyprint.config
|
||||
prettyprint.sections prettyprint.private help.markup help.syntax
|
||||
io kernel words definitions quotations strings ;
|
||||
io kernel words definitions quotations strings generic classes ;
|
||||
IN: prettyprint
|
||||
|
||||
ARTICLE: "prettyprint-numbers" "Prettyprinting numbers"
|
||||
|
@ -150,6 +150,8 @@ $nl
|
|||
{ $subsection pprint-cell }
|
||||
"Printing a definition (see " { $link "definitions" } "):"
|
||||
{ $subsection see }
|
||||
"Printing the methods defined on a generic word or class (see " { $link "objects" } "):"
|
||||
{ $subsection see-methods }
|
||||
"More prettyprinter usage:"
|
||||
{ $subsection "prettyprint-numbers" }
|
||||
{ $subsection "prettyprint-stacks" }
|
||||
|
@ -167,17 +169,26 @@ HELP: with-pprint
|
|||
|
||||
HELP: pprint
|
||||
{ $values { "obj" object } }
|
||||
{ $description "Prettyprints an object to " { $link output-stream } ". Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
|
||||
{ $description "Prettyprints an object to " { $link output-stream } ". Output is influenced by many variables; see " { $link "prettyprint-variables" } "." }
|
||||
{ $warning
|
||||
"Unparsing a large object can take a long time and consume a lot of memory. If you need to print large objects, use " { $link pprint-short } " or set some " { $link "prettyprint-variables" } " to limit output size."
|
||||
} ;
|
||||
|
||||
{ pprint pprint* with-pprint } related-words
|
||||
|
||||
HELP: .
|
||||
{ $values { "obj" object } }
|
||||
{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
|
||||
{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." }
|
||||
{ $warning
|
||||
"Printing a large object can take a long time and consume a lot of memory. If you need to print large objects, use " { $link short. } " or set some " { $link "prettyprint-variables" } " to limit output size."
|
||||
} ;
|
||||
|
||||
HELP: unparse
|
||||
{ $values { "obj" object } { "str" "Factor source string" } }
|
||||
{ $description "Outputs a prettyprinted string representation of an object. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
|
||||
{ $description "Outputs a prettyprinted string representation of an object. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." }
|
||||
{ $warning
|
||||
"Unparsing a large object can take a long time and consume a lot of memory. If you need to unparse large objects, use " { $link unparse-short } " or set some " { $link "prettyprint-variables" } " to limit output size."
|
||||
} ;
|
||||
|
||||
HELP: pprint-short
|
||||
{ $values { "obj" object } }
|
||||
|
@ -240,6 +251,10 @@ HELP: see
|
|||
{ $values { "defspec" "a definition specifier" } }
|
||||
{ $contract "Prettyprints a definition." } ;
|
||||
|
||||
HELP: see-methods
|
||||
{ $values { "word" "a " { $link generic } " or a " { $link class } } }
|
||||
{ $contract "Prettyprints the methods defined on a generic word or class." } ;
|
||||
|
||||
HELP: definer
|
||||
{ $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } }
|
||||
{ $contract "Outputs the parsing words which delimit the definition." }
|
||||
|
|
|
@ -32,3 +32,14 @@ HELP: RENAME:
|
|||
"RENAME: + math => -"
|
||||
"2 3 - ! => 5" } } ;
|
||||
|
||||
ARTICLE: "qualified" "Qualified word lookup"
|
||||
"The " { $vocab-link "qualified" } " vocabulary provides a handful of parsing words which give more control over word lookup than is offered by " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } "."
|
||||
$nl
|
||||
"These words are useful when there is no way to avoid using two vocabularies with identical word names in the same source file."
|
||||
{ $subsection POSTPONE: QUALIFIED: }
|
||||
{ $subsection POSTPONE: QUALIFIED-WITH: }
|
||||
{ $subsection POSTPONE: FROM: }
|
||||
{ $subsection POSTPONE: EXCLUDE: }
|
||||
{ $subsection POSTPONE: RENAME: } ;
|
||||
|
||||
ABOUT: "qualified"
|
||||
|
|
|
@ -1,24 +1,33 @@
|
|||
USING: tools.test qualified ;
|
||||
IN: foo
|
||||
USING: tools.test qualified eval accessors parser ;
|
||||
IN: qualified.tests.foo
|
||||
: x 1 ;
|
||||
IN: bar
|
||||
: y 5 ;
|
||||
IN: qualified.tests.bar
|
||||
: x 2 ;
|
||||
IN: baz
|
||||
: y 4 ;
|
||||
IN: qualified.tests.baz
|
||||
: x 3 ;
|
||||
|
||||
QUALIFIED: foo
|
||||
QUALIFIED: bar
|
||||
[ 1 2 3 ] [ foo:x bar:x x ] unit-test
|
||||
QUALIFIED: qualified.tests.foo
|
||||
QUALIFIED: qualified.tests.bar
|
||||
[ 1 2 3 ] [ qualified.tests.foo:x qualified.tests.bar:x x ] unit-test
|
||||
|
||||
QUALIFIED-WITH: bar p
|
||||
QUALIFIED-WITH: qualified.tests.bar p
|
||||
[ 2 ] [ p:x ] unit-test
|
||||
|
||||
RENAME: x baz => y
|
||||
RENAME: x qualified.tests.baz => y
|
||||
[ 3 ] [ y ] unit-test
|
||||
|
||||
FROM: baz => x ;
|
||||
FROM: qualified.tests.baz => x ;
|
||||
[ 3 ] [ x ] unit-test
|
||||
[ 3 ] [ y ] unit-test
|
||||
|
||||
EXCLUDE: bar => x ;
|
||||
EXCLUDE: qualified.tests.bar => x ;
|
||||
[ 3 ] [ x ] unit-test
|
||||
[ 4 ] [ y ] unit-test
|
||||
|
||||
[ "USE: qualified IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ]
|
||||
[ error>> no-word-error? ] must-fail-with
|
||||
|
||||
[ "USE: qualified IN: qualified.tests RENAME: doesnotexist qualified.tests => blah" eval ]
|
||||
[ error>> no-word-error? ] must-fail-with
|
||||
|
|
|
@ -1,12 +1,12 @@
|
|||
! Copyright (C) 2007, 2008 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences assocs hashtables parser lexer
|
||||
vocabs words namespaces vocabs.loader debugger sets ;
|
||||
vocabs words namespaces vocabs.loader debugger sets fry ;
|
||||
IN: qualified
|
||||
|
||||
: define-qualified ( vocab-name prefix-name -- )
|
||||
[ load-vocab vocab-words ] [ CHAR: : suffix ] bi*
|
||||
[ -rot >r append r> ] curry assoc-map
|
||||
'[ [ [ _ ] dip append ] dip ] assoc-map
|
||||
use get push ;
|
||||
|
||||
: QUALIFIED:
|
||||
|
@ -19,27 +19,27 @@ IN: qualified
|
|||
|
||||
: expect=> ( -- ) scan "=>" assert= ;
|
||||
|
||||
: partial-vocab ( words name -- assoc )
|
||||
dupd [
|
||||
lookup [ "No such word: " swap append throw ] unless*
|
||||
] curry map zip ;
|
||||
|
||||
: partial-vocab-ignoring ( words name -- assoc )
|
||||
[ load-vocab vocab-words keys swap diff ] keep partial-vocab ;
|
||||
|
||||
: EXCLUDE:
|
||||
#! Syntax: EXCLUDE: vocab => words ... ;
|
||||
scan expect=>
|
||||
";" parse-tokens swap partial-vocab-ignoring use get push ; parsing
|
||||
: partial-vocab ( words vocab -- assoc )
|
||||
'[ dup _ lookup [ no-word-error ] unless* ]
|
||||
{ } map>assoc ;
|
||||
|
||||
: FROM:
|
||||
#! Syntax: FROM: vocab => words... ;
|
||||
scan dup load-vocab drop expect=>
|
||||
";" parse-tokens swap partial-vocab use get push ; parsing
|
||||
|
||||
: partial-vocab-excluding ( words vocab -- assoc )
|
||||
[ load-vocab vocab-words keys swap diff ] keep partial-vocab ;
|
||||
|
||||
: EXCLUDE:
|
||||
#! Syntax: EXCLUDE: vocab => words ... ;
|
||||
scan expect=>
|
||||
";" parse-tokens swap partial-vocab-excluding use get push ; parsing
|
||||
|
||||
: RENAME:
|
||||
#! Syntax: RENAME: word vocab => newname
|
||||
scan scan dup load-vocab drop lookup [ "No such word" throw ] unless*
|
||||
scan scan dup load-vocab drop
|
||||
dupd lookup [ ] [ no-word-error ] ?if
|
||||
expect=>
|
||||
scan associate use get push ; parsing
|
||||
|
||||
|
|
|
@ -16,7 +16,7 @@ TUPLE: mersenne-twister seq i ;
|
|||
: mt-a HEX: 9908b0df ; inline
|
||||
|
||||
: calculate-y ( n seq -- y )
|
||||
[ nth 32 mask-bit ]
|
||||
[ nth 31 mask-bit ]
|
||||
[ [ 1+ ] [ nth ] bi* 31 bits ] 2bi bitor ; inline
|
||||
|
||||
: (mt-generate) ( n seq -- next-mt )
|
||||
|
|
|
@ -1,10 +1,10 @@
|
|||
USING: help.markup help.syntax words definitions ;
|
||||
USING: help.markup help.syntax words definitions prettyprint ;
|
||||
IN: tools.crossref
|
||||
|
||||
ARTICLE: "tools.crossref" "Cross-referencing tools"
|
||||
{ $subsection usage. }
|
||||
{ $subsection apropos }
|
||||
{ $see-also "definitions" "words" } ;
|
||||
{ $see-also "definitions" "words" see see-methods } ;
|
||||
|
||||
ABOUT: "tools.crossref"
|
||||
|
||||
|
|
|
@ -9,16 +9,14 @@ IN: tools.deploy.windows
|
|||
"resource:factor.dll" swap copy-file-into ;
|
||||
|
||||
: copy-freetype ( bundle-name -- )
|
||||
deploy-ui? get [
|
||||
{
|
||||
"resource:freetype6.dll"
|
||||
"resource:zlib1.dll"
|
||||
} swap copy-files-into
|
||||
] [ drop ] if ;
|
||||
{
|
||||
"resource:freetype6.dll"
|
||||
"resource:zlib1.dll"
|
||||
} swap copy-files-into ;
|
||||
|
||||
: create-exe-dir ( vocab bundle-name -- vm )
|
||||
dup copy-dll
|
||||
deploy-ui? get [
|
||||
dup copy-dll
|
||||
dup copy-freetype
|
||||
dup "" copy-fonts
|
||||
] when
|
||||
|
@ -26,14 +24,14 @@ IN: tools.deploy.windows
|
|||
|
||||
M: winnt deploy*
|
||||
"resource:" [
|
||||
deploy-name over deploy-config at
|
||||
[
|
||||
{
|
||||
dup deploy-config [
|
||||
deploy-name get
|
||||
[
|
||||
[ create-exe-dir ]
|
||||
[ image-name ]
|
||||
[ drop ]
|
||||
[ drop deploy-config ]
|
||||
} 2cleave make-deploy-image
|
||||
]
|
||||
[ nip open-in-explorer ] 2bi
|
||||
2tri namespace make-deploy-image
|
||||
]
|
||||
[ nip open-in-explorer ] 2bi
|
||||
] bind
|
||||
] with-directory ;
|
||||
|
|
|
@ -148,7 +148,7 @@ ERROR: no-vocab vocab ;
|
|||
"{ $values" print
|
||||
[ " " write ($values.) ]
|
||||
[ [ nl " " write ($values.) ] unless-empty ] bi*
|
||||
" }" write nl
|
||||
nl "}" print
|
||||
] if
|
||||
] when* ;
|
||||
|
||||
|
|
|
@ -17,7 +17,7 @@ ARTICLE: "tools.test.run" "Running unit tests"
|
|||
{ $subsection test-all } ;
|
||||
|
||||
ARTICLE: "tools.test.failure" "Handling test failures"
|
||||
"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Sometimes, you want to develop a tool which inspects the test failures and takes some kind of action instead; one example is " { $vocab-link "builder" } "."
|
||||
"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Some tools inspect the test failures and takes some kind of action instead, for example, " { $vocab-link "mason" } "."
|
||||
$nl
|
||||
"The following words output an association list mapping vocabulary names to sequences of failures; a failure is an array having the shape " { $snippet "{ error test continuation }" } ", and the elements are as follows:"
|
||||
{ $list
|
||||
|
|
|
@ -196,6 +196,7 @@ M: freetype-renderer string-height ( open-font string -- h )
|
|||
:: (draw-string) ( open-font sprites string loc -- )
|
||||
GL_TEXTURE_2D [
|
||||
loc [
|
||||
-0.5 0.5 0.0 glTranslated
|
||||
string open-font string char-widths scan-sums [
|
||||
[ open-font sprites ] 2dip draw-char
|
||||
] 2each
|
||||
|
|
|
@ -1,12 +1,11 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel math models namespaces sequences
|
||||
strings quotations assocs combinators classes colors
|
||||
classes.tuple opengl math.vectors
|
||||
ui.commands ui.gadgets ui.gadgets.borders
|
||||
ui.gadgets.labels ui.gadgets.theme
|
||||
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
|
||||
ui.render math.geometry.rect ;
|
||||
strings quotations assocs combinators classes colors
|
||||
classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
|
||||
ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
|
||||
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
|
||||
ui.render math.geometry.rect locals alien.c-types ;
|
||||
|
||||
IN: ui.gadgets.buttons
|
||||
|
||||
|
@ -62,10 +61,10 @@ C: <button-paint> button-paint
|
|||
} cond ;
|
||||
|
||||
M: button-paint draw-interior
|
||||
button-paint draw-interior ;
|
||||
button-paint dup [ draw-interior ] [ 2drop ] if ;
|
||||
|
||||
M: button-paint draw-boundary
|
||||
button-paint draw-boundary ;
|
||||
button-paint dup [ draw-boundary ] [ 2drop ] if ;
|
||||
|
||||
: align-left ( button -- button )
|
||||
{ 0 1/2 } >>align ; inline
|
||||
|
@ -103,17 +102,34 @@ repeat-button H{
|
|||
#! the mouse is held down.
|
||||
repeat-button new-button bevel-button-theme ;
|
||||
|
||||
TUPLE: checkmark-paint color ;
|
||||
TUPLE: checkmark-paint < caching-pen color last-vertices ;
|
||||
|
||||
C: <checkmark-paint> checkmark-paint
|
||||
: <checkmark-paint> ( color -- paint )
|
||||
checkmark-paint new swap >>color ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: checkmark-points ( dim -- points )
|
||||
{
|
||||
[ { 0 0 } v* { 0 1 } v+ ]
|
||||
[ { 1 1 } v* { 0 1 } v+ ]
|
||||
[ { 0 1 } v* ]
|
||||
[ { 1 0 } v* ]
|
||||
} cleave 4array ;
|
||||
|
||||
: checkmark-vertices ( dim -- vertices )
|
||||
checkmark-points concat >c-float-array ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: checkmark-paint recompute-pen
|
||||
swap dim>> checkmark-vertices >>last-vertices drop ;
|
||||
|
||||
M: checkmark-paint draw-interior
|
||||
color>> set-color
|
||||
origin get [
|
||||
rect-dim
|
||||
{ 0 0 } over gl-line
|
||||
dup { 0 1 } v* swap { 1 0 } v* gl-line
|
||||
] with-translation ;
|
||||
[ compute-pen ]
|
||||
[ color>> gl-color ]
|
||||
[ last-vertices>> gl-vertex-pointer ] tri
|
||||
GL_LINES 0 4 glDrawArrays ;
|
||||
|
||||
: checkmark-theme ( gadget -- gadget )
|
||||
f
|
||||
|
@ -148,30 +164,47 @@ TUPLE: checkbox < button ;
|
|||
M: checkbox model-changed
|
||||
swap value>> >>selected? relayout-1 ;
|
||||
|
||||
TUPLE: radio-paint color ;
|
||||
TUPLE: radio-paint < caching-pen color interior-vertices boundary-vertices ;
|
||||
|
||||
C: <radio-paint> radio-paint
|
||||
: <radio-paint> ( color -- paint ) radio-paint new swap >>color ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: circle-steps 8 ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: radio-paint recompute-pen
|
||||
swap dim>>
|
||||
[ { 4 4 } swap { 9 9 } v- circle-steps circle-vertices >>interior-vertices ]
|
||||
[ { 1 1 } swap { 3 3 } v- circle-steps circle-vertices >>boundary-vertices ] bi
|
||||
drop ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (radio-paint) ( gadget paint -- )
|
||||
[ compute-pen ] [ color>> gl-color ] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: radio-paint draw-interior
|
||||
color>> set-color
|
||||
origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
|
||||
[ (radio-paint) ] [ interior-vertices>> gl-vertex-pointer ] bi
|
||||
GL_POLYGON 0 circle-steps glDrawArrays ;
|
||||
|
||||
M: radio-paint draw-boundary
|
||||
color>> set-color
|
||||
origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
|
||||
[ (radio-paint) ] [ boundary-vertices>> gl-vertex-pointer ] bi
|
||||
GL_LINE_LOOP 0 circle-steps glDrawArrays ;
|
||||
|
||||
: radio-knob-theme ( gadget -- gadget )
|
||||
f
|
||||
f
|
||||
black <radio-paint>
|
||||
black <radio-paint>
|
||||
<button-paint> >>interior
|
||||
black <radio-paint> >>boundary ;
|
||||
:: radio-knob-theme ( gadget -- gadget )
|
||||
[let | radio-paint [ black <radio-paint> ] |
|
||||
gadget
|
||||
f f radio-paint radio-paint <button-paint> >>interior
|
||||
radio-paint >>boundary
|
||||
{ 16 16 } >>dim
|
||||
] ;
|
||||
|
||||
: <radio-knob> ( -- gadget )
|
||||
<gadget>
|
||||
radio-knob-theme
|
||||
{ 16 16 } >>dim ;
|
||||
<gadget> radio-knob-theme ;
|
||||
|
||||
TUPLE: radio-control < button value ;
|
||||
|
||||
|
|
|
@ -127,10 +127,12 @@ M: editor ungraft*
|
|||
: draw-caret ( -- )
|
||||
editor get focused?>> [
|
||||
editor get
|
||||
dup caret-color>> set-color
|
||||
dup caret-loc origin get v+
|
||||
swap caret-dim over v+
|
||||
[ { 0.5 -0.5 } v+ ] bi@ gl-line
|
||||
[ caret-color>> gl-color ]
|
||||
[
|
||||
dup caret-loc origin get v+
|
||||
swap caret-dim over v+
|
||||
gl-line
|
||||
] bi
|
||||
] when ;
|
||||
|
||||
: line-translation ( n -- loc )
|
||||
|
@ -171,7 +173,7 @@ M: editor ungraft*
|
|||
|
||||
: draw-lines ( -- )
|
||||
\ first-visible-line get [
|
||||
editor get dup color>> set-color
|
||||
editor get dup color>> gl-color
|
||||
dup visible-lines
|
||||
[ draw-line 1 translate-lines ] with each
|
||||
] with-editor-translation ;
|
||||
|
@ -180,17 +182,19 @@ M: editor ungraft*
|
|||
dup editor-mark* swap editor-caret* sort-pair ;
|
||||
|
||||
: (draw-selection) ( x1 x2 -- )
|
||||
2dup = [ 2 + ] when
|
||||
0.0 swap editor get line-height glRectd ;
|
||||
over -
|
||||
dup 0 = [ 2 + ] when
|
||||
[ 0.0 2array ] [ editor get line-height 2array ] bi*
|
||||
swap [ gl-fill-rect ] with-translation ;
|
||||
|
||||
: draw-selected-line ( start end n -- )
|
||||
[ start/end-on-line ] keep tuck
|
||||
>r >r editor get offset>x r> r>
|
||||
[ editor get offset>x ] 2dip
|
||||
editor get offset>x
|
||||
(draw-selection) ;
|
||||
|
||||
: draw-selection ( -- )
|
||||
editor get selection-color>> set-color
|
||||
editor get selection-color>> gl-color
|
||||
editor get selection-start/end
|
||||
over first [
|
||||
2dup [
|
||||
|
|
|
@ -23,13 +23,10 @@ SYMBOL: grid-dim
|
|||
] with each ;
|
||||
|
||||
M: grid-lines draw-boundary
|
||||
origin get [
|
||||
-0.5 -0.5 0.0 glTranslated
|
||||
color>> set-color [
|
||||
dup grid set
|
||||
dup rect-dim half-gap v- grid-dim set
|
||||
compute-grid
|
||||
{ 0 1 } draw-grid-lines
|
||||
{ 1 0 } draw-grid-lines
|
||||
] with-scope
|
||||
] with-translation ;
|
||||
color>> gl-color [
|
||||
dup grid set
|
||||
dup rect-dim half-gap v- grid-dim set
|
||||
compute-grid
|
||||
{ 0 1 } draw-grid-lines
|
||||
{ 1 0 } draw-grid-lines
|
||||
] with-scope ;
|
||||
|
|
|
@ -30,16 +30,16 @@ M: labelled-gadget focusable-child* content>> ;
|
|||
|
||||
: title-theme ( gadget -- gadget )
|
||||
{ 1 0 } >>orientation
|
||||
T{ gradient f {
|
||||
{
|
||||
T{ rgba f 0.65 0.65 1.0 1.0 }
|
||||
T{ rgba f 0.65 0.45 1.0 1.0 }
|
||||
} } >>interior ;
|
||||
} <gradient> >>interior ;
|
||||
|
||||
: <title-label> ( text -- label ) <label> title-theme ;
|
||||
|
||||
: <title-bar> ( title quot -- gadget )
|
||||
<frame>
|
||||
swap dup [ <close-box> @left grid-add ] [ drop ] if
|
||||
swap [ <close-box> @left grid-add ] when*
|
||||
swap <title-label> @center grid-add ;
|
||||
|
||||
TUPLE: closable-gadget < frame content ;
|
||||
|
|
|
@ -34,7 +34,7 @@ M: label pref-dim*
|
|||
[ font>> open-font ] [ text>> ] bi text-dim ;
|
||||
|
||||
M: label draw-gadget*
|
||||
[ color>> set-color ]
|
||||
[ color>> gl-color ]
|
||||
[ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
|
||||
|
||||
M: label gadget-text* label-string % ;
|
||||
|
|
|
@ -56,8 +56,12 @@ M: list model-changed
|
|||
|
||||
M: list draw-gadget*
|
||||
origin get [
|
||||
dup color>> set-color
|
||||
selected-rect [ rect-extent gl-fill-rect ] when*
|
||||
dup color>> gl-color
|
||||
selected-rect [
|
||||
dup loc>> [
|
||||
dim>> gl-fill-rect
|
||||
] with-translation
|
||||
] when*
|
||||
] with-translation ;
|
||||
|
||||
M: list focusable-child* drop t ;
|
||||
|
|
|
@ -63,7 +63,11 @@ GENERIC: draw-selection ( loc obj -- )
|
|||
>r clip get over intersects? r> [ drop ] if ; inline
|
||||
|
||||
M: gadget draw-selection ( loc gadget -- )
|
||||
swap offset-rect [ rect-extent gl-fill-rect ] if-fits ;
|
||||
swap offset-rect [
|
||||
dup loc>> [
|
||||
dim>> gl-fill-rect
|
||||
] with-translation
|
||||
] if-fits ;
|
||||
|
||||
M: node draw-selection ( loc node -- )
|
||||
2dup value>> swap offset-rect [
|
||||
|
@ -74,7 +78,7 @@ M: node draw-selection ( loc node -- )
|
|||
|
||||
M: pane draw-gadget*
|
||||
dup gadget-selection? [
|
||||
dup selection-color>> set-color
|
||||
dup selection-color>> gl-color
|
||||
origin get over rect-loc v- swap selected-children
|
||||
[ draw-selection ] with each
|
||||
] [
|
||||
|
|
|
@ -4,7 +4,8 @@ USING: accessors arrays ui.gadgets ui.gadgets.viewports
|
|||
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
|
||||
ui.gadgets.sliders ui.gestures kernel math namespaces sequences
|
||||
models models.range models.compose
|
||||
combinators math.vectors classes.tuple math.geometry.rect ;
|
||||
combinators math.vectors classes.tuple math.geometry.rect
|
||||
combinators.short-circuit ;
|
||||
IN: ui.gadgets.scrollers
|
||||
|
||||
TUPLE: scroller < frame viewport x y follows ;
|
||||
|
@ -70,13 +71,10 @@ scroller H{
|
|||
: relative-scroll-rect ( rect gadget scroller -- newrect )
|
||||
viewport>> gadget-child relative-loc offset-rect ;
|
||||
|
||||
: find-scroller* ( gadget -- scroller )
|
||||
dup find-scroller dup [
|
||||
2dup viewport>> gadget-child
|
||||
swap child? [ nip ] [ 2drop f ] if
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
: find-scroller* ( gadget -- scroller/f )
|
||||
dup find-scroller
|
||||
{ [ nip ] [ viewport>> gadget-child swap child? ] [ nip ] }
|
||||
2&& ;
|
||||
|
||||
: scroll>rect ( rect gadget -- )
|
||||
dup find-scroller* dup [
|
||||
|
|
|
@ -17,44 +17,44 @@ IN: ui.gadgets.theme
|
|||
|
||||
: selection-color ( -- color ) light-purple ;
|
||||
|
||||
: plain-gradient
|
||||
T{ gradient f {
|
||||
: plain-gradient ( -- gradient )
|
||||
{
|
||||
T{ gray f 0.94 1.0 }
|
||||
T{ gray f 0.83 1.0 }
|
||||
T{ gray f 0.83 1.0 }
|
||||
T{ gray f 0.62 1.0 }
|
||||
} } ;
|
||||
} <gradient> ;
|
||||
|
||||
: rollover-gradient
|
||||
T{ gradient f {
|
||||
: rollover-gradient ( -- gradient )
|
||||
{
|
||||
T{ gray f 1.0 1.0 }
|
||||
T{ gray f 0.9 1.0 }
|
||||
T{ gray f 0.9 1.0 }
|
||||
T{ gray f 0.75 1.0 }
|
||||
} } ;
|
||||
} <gradient> ;
|
||||
|
||||
: pressed-gradient
|
||||
T{ gradient f {
|
||||
: pressed-gradient ( -- gradient )
|
||||
{
|
||||
T{ gray f 0.75 1.0 }
|
||||
T{ gray f 0.9 1.0 }
|
||||
T{ gray f 0.9 1.0 }
|
||||
T{ gray f 1.0 1.0 }
|
||||
} } ;
|
||||
} <gradient> ;
|
||||
|
||||
: selected-gradient
|
||||
T{ gradient f {
|
||||
: selected-gradient ( -- gradient )
|
||||
{
|
||||
T{ gray f 0.65 1.0 }
|
||||
T{ gray f 0.8 1.0 }
|
||||
T{ gray f 0.8 1.0 }
|
||||
T{ gray f 1.0 1.0 }
|
||||
} } ;
|
||||
} <gradient> ;
|
||||
|
||||
: lowered-gradient
|
||||
T{ gradient f {
|
||||
: lowered-gradient ( -- gradient )
|
||||
{
|
||||
T{ gray f 0.37 1.0 }
|
||||
T{ gray f 0.43 1.0 }
|
||||
T{ gray f 0.5 1.0 }
|
||||
} } ;
|
||||
} <gradient> ;
|
||||
|
||||
: sans-serif-font { "sans-serif" plain 12 } ;
|
||||
|
||||
|
|
|
@ -52,7 +52,7 @@ HELP: polygon
|
|||
} ;
|
||||
|
||||
HELP: <polygon>
|
||||
{ $values { "color" "a color specifier" } { "points" "a sequence of points" } }
|
||||
{ $values { "color" "a color specifier" } { "points" "a sequence of points" } { "polygon" polygon } }
|
||||
{ $description "Creates a new instance of " { $link polygon } "." } ;
|
||||
|
||||
HELP: <polygon-gadget>
|
||||
|
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien arrays hashtables io kernel math namespaces opengl
|
||||
opengl.gl opengl.glu sequences strings io.styles vectors
|
||||
combinators math.vectors ui.gadgets colors
|
||||
math.order math.geometry.rect ;
|
||||
USING: accessors alien alien.c-types arrays hashtables io kernel
|
||||
math namespaces opengl opengl.gl opengl.glu sequences strings
|
||||
io.styles vectors combinators math.vectors ui.gadgets colors
|
||||
math.order math.geometry.rect locals ;
|
||||
IN: ui.render
|
||||
|
||||
SYMBOL: clip
|
||||
|
@ -21,9 +21,9 @@ SYMBOL: viewport-translation
|
|||
: init-clip ( clip-rect rect -- )
|
||||
GL_SCISSOR_TEST glEnable
|
||||
[ rect-intersect ] keep
|
||||
rect-dim dup { 0 1 } v* viewport-translation set
|
||||
dim>> dup { 0 1 } v* viewport-translation set
|
||||
{ 0 0 } over gl-viewport
|
||||
0 swap first2 0 gluOrtho2D
|
||||
-0.5 swap first2 [ 0.5 - ] [ 0.5 + ] bi* 0.5 gluOrtho2D
|
||||
clip set
|
||||
do-clip ;
|
||||
|
||||
|
@ -31,12 +31,13 @@ SYMBOL: viewport-translation
|
|||
GL_SMOOTH glShadeModel
|
||||
GL_BLEND glEnable
|
||||
GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
|
||||
GL_VERTEX_ARRAY glEnableClientState
|
||||
init-matrices
|
||||
init-clip
|
||||
! white gl-clear is broken w.r.t window resizing
|
||||
! Linux/PPC Radeon 9200
|
||||
white set-color
|
||||
clip get rect-extent gl-fill-rect ;
|
||||
white gl-color
|
||||
clip get dim>> gl-fill-rect ;
|
||||
|
||||
GENERIC: draw-gadget* ( gadget -- )
|
||||
|
||||
|
@ -60,10 +61,15 @@ DEFER: draw-gadget
|
|||
: (draw-gadget) ( gadget -- )
|
||||
[
|
||||
dup translate
|
||||
dup dup interior>> draw-interior
|
||||
dup interior>> [
|
||||
origin get [ dupd draw-interior ] with-translation
|
||||
] when*
|
||||
dup draw-gadget*
|
||||
dup visible-children [ draw-gadget ] each
|
||||
dup boundary>> draw-boundary
|
||||
dup boundary>> [
|
||||
origin get [ dupd draw-boundary ] with-translation
|
||||
] when*
|
||||
drop
|
||||
] with-scope ;
|
||||
|
||||
: >absolute ( rect -- rect )
|
||||
|
@ -84,51 +90,102 @@ DEFER: draw-gadget
|
|||
[ [ (draw-gadget) ] with-clipping ]
|
||||
} cond ;
|
||||
|
||||
! Pen paint properties
|
||||
M: f draw-interior 2drop ;
|
||||
M: f draw-boundary 2drop ;
|
||||
! A pen that caches vertex arrays, etc
|
||||
TUPLE: caching-pen last-dim ;
|
||||
|
||||
GENERIC: recompute-pen ( gadget pen -- )
|
||||
|
||||
: compute-pen ( gadget pen -- )
|
||||
2dup [ dim>> ] [ last-dim>> ] bi* = [
|
||||
2drop
|
||||
] [
|
||||
[ swap dim>> >>last-dim drop ] [ recompute-pen ] 2bi
|
||||
] if ;
|
||||
|
||||
! Solid fill/border
|
||||
TUPLE: solid color ;
|
||||
TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
|
||||
|
||||
C: <solid> solid
|
||||
: <solid> ( color -- solid ) solid new swap >>color ;
|
||||
|
||||
M: solid recompute-pen
|
||||
swap dim>>
|
||||
[ (fill-rect-vertices) >>interior-vertices ]
|
||||
[ (rect-vertices) >>boundary-vertices ]
|
||||
bi drop ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Solid pen
|
||||
: (solid) ( gadget paint -- loc dim )
|
||||
color>> set-color rect-dim >r origin get dup r> v+ ;
|
||||
: (solid) ( gadget pen -- )
|
||||
[ compute-pen ] [ color>> gl-color ] bi ;
|
||||
|
||||
M: solid draw-interior (solid) gl-fill-rect ;
|
||||
PRIVATE>
|
||||
|
||||
M: solid draw-boundary (solid) gl-rect ;
|
||||
M: solid draw-interior
|
||||
[ (solid) ] [ interior-vertices>> gl-vertex-pointer ] bi
|
||||
(gl-fill-rect) ;
|
||||
|
||||
M: solid draw-boundary
|
||||
[ (solid) ] [ boundary-vertices>> gl-vertex-pointer ] bi
|
||||
(gl-rect) ;
|
||||
|
||||
! Gradient pen
|
||||
TUPLE: gradient colors ;
|
||||
TUPLE: gradient < caching-pen colors last-vertices last-colors ;
|
||||
|
||||
C: <gradient> gradient
|
||||
: <gradient> ( colors -- gradient ) gradient new swap >>colors ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
:: gradient-vertices ( direction dim colors -- seq )
|
||||
direction dim v* dim over v- swap
|
||||
colors length dup 1- v/n [ v*n ] with map
|
||||
[ dup rot v+ 2array ] with map
|
||||
concat concat >c-float-array ;
|
||||
|
||||
: gradient-colors ( colors -- seq )
|
||||
[ color>raw 4array dup 2array ] map concat concat >c-float-array ;
|
||||
|
||||
M: gradient recompute-pen ( gadget gradient -- )
|
||||
tuck
|
||||
[ [ orientation>> ] [ dim>> ] bi ] [ colors>> ] bi*
|
||||
[ gradient-vertices >>last-vertices ]
|
||||
[ gradient-colors >>last-colors ] bi
|
||||
drop ;
|
||||
|
||||
: draw-gradient ( colors -- )
|
||||
GL_COLOR_ARRAY [
|
||||
[ GL_QUAD_STRIP 0 ] dip length 2 * glDrawArrays
|
||||
] do-enabled-client-state ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: gradient draw-interior
|
||||
origin get [
|
||||
over orientation>>
|
||||
swap colors>>
|
||||
rot rect-dim
|
||||
gl-gradient
|
||||
] with-translation ;
|
||||
{
|
||||
[ compute-pen ]
|
||||
[ last-vertices>> gl-vertex-pointer ]
|
||||
[ last-colors>> gl-color-pointer ]
|
||||
[ colors>> draw-gradient ]
|
||||
} cleave ;
|
||||
|
||||
! Polygon pen
|
||||
TUPLE: polygon color points ;
|
||||
TUPLE: polygon color vertex-array count ;
|
||||
|
||||
C: <polygon> polygon
|
||||
: <polygon> ( color points -- polygon )
|
||||
[ concat >c-float-array ] [ length ] bi polygon boa ;
|
||||
|
||||
: draw-polygon ( polygon quot -- )
|
||||
origin get [
|
||||
>r dup color>> set-color points>> r> call
|
||||
] with-translation ; inline
|
||||
: draw-polygon ( polygon mode -- )
|
||||
swap
|
||||
[ color>> gl-color ]
|
||||
[ vertex-array>> gl-vertex-pointer ]
|
||||
[ 0 swap count>> glDrawArrays ]
|
||||
tri ;
|
||||
|
||||
M: polygon draw-boundary
|
||||
[ gl-poly ] draw-polygon drop ;
|
||||
GL_LINE_LOOP draw-polygon drop ;
|
||||
|
||||
M: polygon draw-interior
|
||||
[ gl-fill-poly ] draw-polygon drop ;
|
||||
dup count>> 2 > GL_POLYGON GL_LINES ?
|
||||
draw-polygon drop ;
|
||||
|
||||
: arrow-up { { 3 0 } { 6 6 } { 0 6 } } ;
|
||||
: arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;
|
||||
|
|
|
@ -50,7 +50,8 @@ M: listener-gadget tool-scroller
|
|||
listener>> input>> interactor-busy? ;
|
||||
|
||||
: listener-input ( string -- )
|
||||
get-workspace listener>> input>> set-editor-string ;
|
||||
get-workspace listener>> input>>
|
||||
[ set-editor-string ] [ request-focus ] bi ;
|
||||
|
||||
: (call-listener) ( quot listener -- )
|
||||
input>> interactor-call ;
|
||||
|
|
|
@ -22,3 +22,5 @@ IN: unix.groups.tests
|
|||
|
||||
[ ] [ effective-group-name [ ] with-effective-group ] unit-test
|
||||
[ ] [ effective-group-id [ ] with-effective-group ] unit-test
|
||||
|
||||
[ ] [ [ ] with-group-cache ] unit-test
|
||||
|
|
|
@ -19,8 +19,8 @@ C-STRUCT: statfs
|
|||
FUNCTION: int statfs ( char* path, statfs* buf ) ;
|
||||
|
||||
TUPLE: linux32-file-system-info < file-system-info
|
||||
type bsize blocks bfree bavail files ffree fsid
|
||||
namelen frsize spare ;
|
||||
bsize blocks bfree bavail files ffree fsid namelen
|
||||
frsize spare ;
|
||||
|
||||
M: linux >file-system-info ( struct -- statfs )
|
||||
[ \ linux32-file-system-info new ] dip
|
||||
|
|
|
@ -21,8 +21,8 @@ C-STRUCT: statfs64
|
|||
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
|
||||
|
||||
TUPLE: linux64-file-system-info < file-system-info
|
||||
type bsize blocks bfree bavail files ffree fsid
|
||||
namelen frsize spare ;
|
||||
bsize blocks bfree bavail files ffree fsid namelen
|
||||
frsize spare ;
|
||||
|
||||
M: linux >file-system-info ( struct -- statfs )
|
||||
[ \ linux64-file-system-info new ] dip
|
||||
|
|
|
@ -22,8 +22,8 @@ HELP: new-passwd
|
|||
HELP: passwd
|
||||
{ $description "A platform-specific tuple correspding to every field from the Unix passwd struct. BSD passwd structures have four extra slots: " { $slot "change" } ", " { $slot "class" } "," { $slot "expire" } ", " { $slot "fields" } "." } ;
|
||||
|
||||
HELP: passwd-cache
|
||||
{ $description "A symbol storing passwd structures indexed by user-ids when within a " { $link with-passwd-cache } "." } ;
|
||||
HELP: user-cache
|
||||
{ $description "A symbol storing passwd structures indexed by user-ids when within a " { $link with-user-cache } "." } ;
|
||||
|
||||
HELP: passwd>new-passwd
|
||||
{ $values
|
||||
|
@ -70,10 +70,10 @@ HELP: with-effective-user
|
|||
{ "string/id" "a string or a uid" } { "quot" quotation } }
|
||||
{ $description "Sets the effective username and calls the quotation. Restores the current username on success or on error after the call." } ;
|
||||
|
||||
HELP: with-passwd-cache
|
||||
HELP: with-user-cache
|
||||
{ $values
|
||||
{ "quot" quotation } }
|
||||
{ $description "Iterates over the password file using library calls and creates a cache in the " { $link passwd-cache } " symbol. The cache is a hashtable indexed by user id. When looking up many users, this approach is much faster than calling system calls." } ;
|
||||
{ $description "Iterates over the password file using library calls and creates a cache in the " { $link user-cache } " symbol. The cache is a hashtable indexed by user id. When looking up many users, this approach is much faster than calling system calls." } ;
|
||||
|
||||
HELP: with-real-user
|
||||
{ $values
|
||||
|
|
|
@ -22,3 +22,5 @@ IN: unix.users.tests
|
|||
|
||||
[ ] [ effective-username [ ] with-effective-user ] unit-test
|
||||
[ ] [ effective-user-id [ ] with-effective-user ] unit-test
|
||||
|
||||
[ ] [ [ ] with-user-cache ] unit-test
|
||||
|
|
|
@ -39,16 +39,16 @@ PRIVATE>
|
|||
[ getpwent dup ] [ passwd>new-passwd ] [ drop ] produce
|
||||
] with-pwent ;
|
||||
|
||||
SYMBOL: passwd-cache
|
||||
SYMBOL: user-cache
|
||||
|
||||
: with-passwd-cache ( quot -- )
|
||||
: with-user-cache ( quot -- )
|
||||
all-users [ [ uid>> ] keep ] H{ } map>assoc
|
||||
passwd-cache swap with-variable ; inline
|
||||
user-cache rot with-variable ; inline
|
||||
|
||||
GENERIC: user-passwd ( obj -- passwd )
|
||||
|
||||
M: integer user-passwd ( id -- passwd/f )
|
||||
passwd-cache get
|
||||
user-cache get
|
||||
[ at ] [ getpwuid passwd>new-passwd ] if* ;
|
||||
|
||||
M: string user-passwd ( string -- passwd/f )
|
||||
|
|
|
@ -176,7 +176,7 @@ find_os() {
|
|||
*FreeBSD*) OS=freebsd;;
|
||||
*OpenBSD*) OS=openbsd;;
|
||||
*DragonFly*) OS=dragonflybsd;;
|
||||
SunOS) OS=solaris;;
|
||||
SunOS) OS=solaris;;
|
||||
esac
|
||||
}
|
||||
|
||||
|
@ -264,24 +264,28 @@ check_os_arch_word() {
|
|||
$ECHO "WORD: $WORD"
|
||||
$ECHO "OS, ARCH, or WORD is empty. Please report this."
|
||||
|
||||
echo $MAKE_TARGET
|
||||
echo $MAKE_TARGET
|
||||
exit 5
|
||||
fi
|
||||
}
|
||||
|
||||
set_build_info() {
|
||||
check_os_arch_word
|
||||
MAKE_TARGET=$OS-$ARCH-$WORD
|
||||
if [[ $OS == macosx && $ARCH == ppc ]] ; then
|
||||
MAKE_IMAGE_TARGET=macosx-ppc
|
||||
MAKE_TARGET=macosx-ppc
|
||||
elif [[ $OS == linux && $ARCH == ppc ]] ; then
|
||||
MAKE_IMAGE_TARGET=linux-ppc
|
||||
MAKE_TARGET=linux-ppc
|
||||
elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then
|
||||
MAKE_IMAGE_TARGET=winnt-x86.64
|
||||
MAKE_TARGET=winnt-x86-64
|
||||
elif [[ $ARCH == x86 && $WORD == 64 ]] ; then
|
||||
MAKE_IMAGE_TARGET=unix-x86.64
|
||||
else
|
||||
MAKE_TARGET=$OS-x86-64
|
||||
else
|
||||
MAKE_IMAGE_TARGET=$ARCH.$WORD
|
||||
MAKE_TARGET=$OS-$ARCH-$WORD
|
||||
fi
|
||||
BOOT_IMAGE=boot.$MAKE_IMAGE_TARGET.image
|
||||
}
|
||||
|
@ -335,9 +339,21 @@ cd_factor() {
|
|||
check_ret cd
|
||||
}
|
||||
|
||||
check_makefile_exists() {
|
||||
if [[ ! -e "Makefile" ]] ; then
|
||||
echo ""
|
||||
echo "***Makefile not found***"
|
||||
echo "You are likely in the wrong directory."
|
||||
echo "Run this script from your factor directory:"
|
||||
echo " ./build-support/factor.sh"
|
||||
exit 6
|
||||
fi
|
||||
}
|
||||
|
||||
invoke_make() {
|
||||
$MAKE $MAKE_OPTS $*
|
||||
check_ret $MAKE
|
||||
check_makefile_exists
|
||||
$MAKE $MAKE_OPTS $*
|
||||
check_ret $MAKE
|
||||
}
|
||||
|
||||
make_clean() {
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
USING: help.markup help.syntax words classes classes.algebra
|
||||
definitions kernel alien sequences math quotations
|
||||
generic.standard generic.math combinators ;
|
||||
generic.standard generic.math combinators prettyprint ;
|
||||
IN: generic
|
||||
|
||||
ARTICLE: "method-order" "Method precedence"
|
||||
|
@ -46,7 +46,8 @@ $nl
|
|||
"Low-level method constructor:"
|
||||
{ $subsection <method> }
|
||||
"A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":"
|
||||
{ $subsection method-spec } ;
|
||||
{ $subsection method-spec }
|
||||
{ $see-also see see-methods } ;
|
||||
|
||||
ARTICLE: "method-combination" "Custom method combination"
|
||||
"Abstractly, a generic word can be thought of as a big chain of type conditional tests applied to the top of the stack, with methods as the bodies of each test. The " { $emphasis "method combination" } " is this control flow glue between the set of methods, and several aspects of it can be customized:"
|
||||
|
|
|
@ -16,7 +16,7 @@ HELP: standard-combination
|
|||
{ $examples
|
||||
"A generic word for append strings and characters to a sequence, dispatching on the object underneath the top of the stack:"
|
||||
{ $code
|
||||
"G: build-string 1 standard-combination ;"
|
||||
"GENERIC# build-string 1 ( elt str -- )"
|
||||
"M: string build-string swap push-all ;"
|
||||
"M: integer build-string push ;"
|
||||
}
|
||||
|
|
|
@ -1,10 +1,12 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.order strings arrays vectors sequences
|
||||
accessors ;
|
||||
sequences.private accessors ;
|
||||
IN: grouping
|
||||
|
||||
TUPLE: abstract-groups { seq read-only } { n read-only } ;
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: chunking-seq { seq read-only } { n read-only } ;
|
||||
|
||||
: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
|
||||
|
||||
|
@ -13,55 +15,73 @@ TUPLE: abstract-groups { seq read-only } { n read-only } ;
|
|||
|
||||
GENERIC: group@ ( n groups -- from to seq )
|
||||
|
||||
M: abstract-groups nth group@ subseq ;
|
||||
M: chunking-seq set-nth group@ <slice> 0 swap copy ;
|
||||
|
||||
M: abstract-groups set-nth group@ <slice> 0 swap copy ;
|
||||
M: chunking-seq like drop { } like ;
|
||||
|
||||
M: abstract-groups like drop { } like ;
|
||||
INSTANCE: chunking-seq sequence
|
||||
|
||||
INSTANCE: abstract-groups sequence
|
||||
MIXIN: subseq-chunking
|
||||
|
||||
M: subseq-chunking nth group@ subseq ;
|
||||
|
||||
MIXIN: slice-chunking
|
||||
|
||||
M: slice-chunking nth group@ <slice> ;
|
||||
|
||||
M: slice-chunking nth-unsafe group@ slice boa ;
|
||||
|
||||
TUPLE: abstract-groups < chunking-seq ;
|
||||
|
||||
M: abstract-groups length
|
||||
[ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
|
||||
|
||||
M: abstract-groups set-length
|
||||
[ n>> * ] [ seq>> ] bi set-length ;
|
||||
|
||||
M: abstract-groups group@
|
||||
[ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
|
||||
|
||||
TUPLE: abstract-clumps < chunking-seq ;
|
||||
|
||||
M: abstract-clumps length
|
||||
[ seq>> length ] [ n>> ] bi - 1+ ;
|
||||
|
||||
M: abstract-clumps set-length
|
||||
[ n>> + 1- ] [ seq>> ] bi set-length ;
|
||||
|
||||
M: abstract-clumps group@
|
||||
[ n>> over + ] [ seq>> ] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
TUPLE: groups < abstract-groups ;
|
||||
|
||||
: <groups> ( seq n -- groups )
|
||||
groups new-groups ; inline
|
||||
|
||||
M: groups length
|
||||
[ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
|
||||
INSTANCE: groups subseq-chunking
|
||||
|
||||
M: groups set-length
|
||||
[ n>> * ] [ seq>> ] bi set-length ;
|
||||
|
||||
M: groups group@
|
||||
[ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
|
||||
|
||||
TUPLE: sliced-groups < groups ;
|
||||
TUPLE: sliced-groups < abstract-groups ;
|
||||
|
||||
: <sliced-groups> ( seq n -- groups )
|
||||
sliced-groups new-groups ; inline
|
||||
|
||||
M: sliced-groups nth group@ <slice> ;
|
||||
INSTANCE: sliced-groups slice-chunking
|
||||
|
||||
TUPLE: clumps < abstract-groups ;
|
||||
TUPLE: clumps < abstract-clumps ;
|
||||
|
||||
: <clumps> ( seq n -- clumps )
|
||||
clumps new-groups ; inline
|
||||
|
||||
M: clumps length
|
||||
[ seq>> length ] [ n>> ] bi - 1+ ;
|
||||
INSTANCE: clumps subseq-chunking
|
||||
|
||||
M: clumps set-length
|
||||
[ n>> + 1- ] [ seq>> ] bi set-length ;
|
||||
|
||||
M: clumps group@
|
||||
[ n>> over + ] [ seq>> ] bi ;
|
||||
|
||||
TUPLE: sliced-clumps < clumps ;
|
||||
TUPLE: sliced-clumps < abstract-clumps ;
|
||||
|
||||
: <sliced-clumps> ( seq n -- clumps )
|
||||
sliced-clumps new-groups ; inline
|
||||
|
||||
M: sliced-clumps nth group@ <slice> ;
|
||||
INSTANCE: sliced-clumps slice-chunking
|
||||
|
||||
: group ( seq n -- array ) <groups> { } like ;
|
||||
|
||||
|
|
|
@ -5,8 +5,10 @@ ABOUT: "io.encodings"
|
|||
|
||||
ARTICLE: "io.encodings" "I/O encodings"
|
||||
"Bytes can't be understood in isolation as text. They must be interpreted under a certain encoding. Factor provides utilities for dealing with encoded text by declaring that a stream has a particular encoding, and utilities to encode and decode strings."
|
||||
{ $subsection "encodings-constructors" }
|
||||
{ $subsection "encodings-descriptors" }
|
||||
{ $subsection "encodings-constructors" }
|
||||
{ $subsection "io.encodings.string" }
|
||||
"New types of encodings can be defined:"
|
||||
{ $subsection "encodings-protocol" } ;
|
||||
|
||||
ARTICLE: "encodings-constructors" "Manually constructing an encoded stream"
|
||||
|
|
|
@ -644,7 +644,7 @@ $nl
|
|||
HELP: loop
|
||||
{ $values
|
||||
{ "pred" quotation } }
|
||||
{ $description "Calls the quotation repeatedly until the output is true." }
|
||||
{ $description "Calls the quotation repeatedly until it outputs " { $link f } "." }
|
||||
{ $examples "Loop until we hit a zero:"
|
||||
{ $unchecked-example "USING: kernel random math io ; "
|
||||
" [ \"hi\" write bl 10 random zero? not ] loop"
|
||||
|
|
|
@ -99,7 +99,10 @@ HELP: counter
|
|||
|
||||
HELP: with-scope
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Calls the quotation in a new namespace. Any variables set by the quotation are discarded when it returns." } ;
|
||||
{ $description "Calls the quotation in a new namespace. Any variables set by the quotation are discarded when it returns." }
|
||||
{ $examples
|
||||
{ $example "USING: math namespaces prettyprint ;" "IN: scratchpad" "SYMBOL: x" "0 x set" "[ x [ 5 + ] change x get . ] with-scope x get ." "5\n0" }
|
||||
} ;
|
||||
|
||||
HELP: with-variable
|
||||
{ $values { "value" object } { "key" "a variable, by convention a symbol" } { "quot" quotation } }
|
||||
|
|
|
@ -69,7 +69,7 @@ $nl
|
|||
{ $subsection POSTPONE: PRIVATE> }
|
||||
{ $subsection "vocabulary-search-errors" }
|
||||
{ $subsection "vocabulary-search-shadow" }
|
||||
{ $see-also "words" } ;
|
||||
{ $see-also "words" "qualified" } ;
|
||||
|
||||
ARTICLE: "reading-ahead" "Reading ahead"
|
||||
"Parsing words can consume input:"
|
||||
|
|
|
@ -71,10 +71,10 @@ ERROR: no-current-vocab ;
|
|||
] keep
|
||||
] { } map>assoc ;
|
||||
|
||||
TUPLE: no-word-error name ;
|
||||
ERROR: no-word-error name ;
|
||||
|
||||
: no-word ( name -- newword )
|
||||
dup no-word-error boa
|
||||
dup \ no-word-error boa
|
||||
swap words-named [ forward-reference? not ] filter
|
||||
word-restarts throw-restarts
|
||||
dup vocabulary>> (use+) ;
|
||||
|
|
|
@ -841,7 +841,8 @@ HELP: unclip
|
|||
|
||||
HELP: unclip-slice
|
||||
{ $values { "seq" sequence } { "rest-slice" slice } { "first" object } }
|
||||
{ $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first. Unlike " { $link unclip } ", this word does not make a copy of the input sequence, and runs in constant time." } ;
|
||||
{ $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first. Unlike " { $link unclip } ", this word does not make a copy of the input sequence, and runs in constant time." }
|
||||
{ $examples { $example "USING: math.order prettyprint sequences ;" "{ 3 -1 -10 5 7 } unclip-slice [ min ] reduce ." "-10" } } ;
|
||||
|
||||
HELP: unclip-last
|
||||
{ $values { "seq" sequence } { "butlast" sequence } { "last" object } }
|
||||
|
|
|
@ -30,7 +30,7 @@ IN: automata.ui
|
|||
|
||||
: draw-bitmap ( bitmap -- ) GL_POINTS glBegin (draw-bitmap) glEnd ;
|
||||
|
||||
: display ( -- ) black set-color bitmap> draw-bitmap ;
|
||||
: display ( -- ) black gl-color bitmap> draw-bitmap ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
@ -1,12 +1,15 @@
|
|||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ deploy-ui? t }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
H{
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-ui? t }
|
||||
{ deploy-io 2 }
|
||||
{ deploy-threads? t }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-unicode? f }
|
||||
{ deploy-name "Boids" }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-reflection 1 }
|
||||
}
|
||||
|
|
|
@ -1,46 +0,0 @@
|
|||
|
||||
USING: io.files io.launcher io.encodings.utf8 prettyprint
|
||||
builder.util builder.common builder.child builder.release
|
||||
builder.report builder.email builder.cleanup ;
|
||||
|
||||
IN: builder.build
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: create-build-dir ( -- )
|
||||
datestamp >stamp
|
||||
build-dir make-directory ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: enter-build-dir ( -- ) build-dir set-current-directory ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: clone-builds-factor ( -- )
|
||||
{ "git" "clone" builds/factor } to-strings try-process ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: record-id ( -- )
|
||||
"factor"
|
||||
[ git-id "../git-id" utf8 [ . ] with-file-writer ]
|
||||
with-directory ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: build ( -- )
|
||||
reset-status
|
||||
create-build-dir
|
||||
enter-build-dir
|
||||
clone-builds-factor
|
||||
record-id
|
||||
build-child
|
||||
release
|
||||
report
|
||||
email-report
|
||||
cleanup ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
MAIN: build
|
|
@ -1,21 +0,0 @@
|
|||
|
||||
USING: kernel debugger io.files threads calendar
|
||||
builder.common
|
||||
builder.updates
|
||||
builder.build ;
|
||||
|
||||
IN: builder
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: build-loop ( -- )
|
||||
builds-check
|
||||
[
|
||||
builds/factor set-current-directory
|
||||
new-code-available? [ build ] when
|
||||
]
|
||||
try
|
||||
5 minutes sleep
|
||||
build-loop ;
|
||||
|
||||
MAIN: build-loop
|
|
@ -1,68 +0,0 @@
|
|||
|
||||
USING: namespaces debugger io.files io.launcher accessors bootstrap.image
|
||||
calendar builder.util builder.common ;
|
||||
|
||||
IN: builder.child
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: make-vm ( -- )
|
||||
<process>
|
||||
gnu-make >>command
|
||||
"../compile-log" >>stdout
|
||||
+stdout+ >>stderr
|
||||
try-process ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: builds-factor-image ( -- img ) builds/factor my-boot-image-name append-path ;
|
||||
|
||||
: copy-image ( -- )
|
||||
builds-factor-image ".." copy-file-into
|
||||
builds-factor-image "." copy-file-into ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: boot-cmd ( -- cmd )
|
||||
{ "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
|
||||
|
||||
: boot ( -- )
|
||||
<process>
|
||||
boot-cmd >>command
|
||||
+closed+ >>stdin
|
||||
"../boot-log" >>stdout
|
||||
+stdout+ >>stderr
|
||||
60 minutes >>timeout
|
||||
try-process ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } ;
|
||||
|
||||
: test ( -- )
|
||||
<process>
|
||||
test-cmd >>command
|
||||
+closed+ >>stdin
|
||||
"../test-log" >>stdout
|
||||
+stdout+ >>stderr
|
||||
240 minutes >>timeout
|
||||
try-process ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: (build-child) ( -- )
|
||||
make-clean
|
||||
make-vm status-vm on
|
||||
copy-image
|
||||
boot status-boot on
|
||||
test status-test on
|
||||
status on ;
|
||||
|
||||
: build-child ( -- )
|
||||
"factor" set-current-directory
|
||||
[ (build-child) ] try
|
||||
".." set-current-directory ;
|
|
@ -1,26 +0,0 @@
|
|||
|
||||
USING: kernel namespaces io.files io.launcher bootstrap.image
|
||||
builder.util builder.common ;
|
||||
|
||||
IN: builder.cleanup
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: builder-debug
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
|
||||
|
||||
: delete-child-factor ( -- )
|
||||
build-dir [ { "rm" "-rf" "factor" } try-process ] with-directory ;
|
||||
|
||||
: cleanup ( -- )
|
||||
builder-debug get f =
|
||||
[
|
||||
"test-log" delete-file
|
||||
delete-child-factor
|
||||
compress-image
|
||||
]
|
||||
when ;
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
|
||||
USING: kernel namespaces sequences splitting
|
||||
io io.files io.launcher io.encodings.utf8 prettyprint
|
||||
vars builder.util ;
|
||||
|
||||
IN: builder.common
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: upload-to-factorcode
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: builds-dir
|
||||
|
||||
: builds ( -- path )
|
||||
builds-dir get
|
||||
home "/builds" append
|
||||
or ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VAR: stamp
|
||||
|
||||
: builds/factor ( -- path ) builds "factor" append-path ;
|
||||
: build-dir ( -- path ) builds stamp> append-path ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: prepare-build-machine ( -- )
|
||||
builds make-directory
|
||||
builds
|
||||
[ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ]
|
||||
with-directory ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: status-vm
|
||||
SYMBOL: status-boot
|
||||
SYMBOL: status-test
|
||||
SYMBOL: status-build
|
||||
SYMBOL: status-release
|
||||
SYMBOL: status
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: reset-status ( -- )
|
||||
{ status-vm status-boot status-test status-build status-release status }
|
||||
[ off ]
|
||||
each ;
|
|
@ -1,24 +0,0 @@
|
|||
|
||||
USING: kernel namespaces accessors smtp builder.util builder.common ;
|
||||
|
||||
IN: builder.email
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: builder-from
|
||||
SYMBOL: builder-recipients
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: subject-status ( -- str ) status get [ "report" ] [ "error" ] if ;
|
||||
|
||||
: subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ;
|
||||
|
||||
: email-report ( -- )
|
||||
<email>
|
||||
builder-from get >>from
|
||||
builder-recipients get >>to
|
||||
subject >>subject
|
||||
"report" file>string >>body
|
||||
send-email ;
|
||||
|
|
@ -1,69 +0,0 @@
|
|||
|
||||
USING: kernel combinators system sequences io.files io.launcher prettyprint
|
||||
builder.util
|
||||
builder.common ;
|
||||
|
||||
IN: builder.release.archive
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: base-name ( -- string )
|
||||
{ "factor" [ os unparse ] cpu- stamp> } to-strings "-" join ;
|
||||
|
||||
: extension ( -- extension )
|
||||
{
|
||||
{ [ os winnt? ] [ ".zip" ] }
|
||||
{ [ os macosx? ] [ ".dmg" ] }
|
||||
{ [ os unix? ] [ ".tar.gz" ] }
|
||||
}
|
||||
cond ;
|
||||
|
||||
: archive-name ( -- string ) base-name extension append ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ;
|
||||
|
||||
! : macosx-archive-cmd ( -- cmd )
|
||||
! { "hdiutil" "create"
|
||||
! "-srcfolder" "factor"
|
||||
! "-fs" "HFS+"
|
||||
! "-volname" "factor"
|
||||
! archive-name } ;
|
||||
|
||||
: macosx-archive-cmd ( -- cmd )
|
||||
{ "mkdir" "dmg-root" } try-process
|
||||
{ "cp" "-r" "factor" "dmg-root" } try-process
|
||||
{ "hdiutil" "create"
|
||||
"-srcfolder" "dmg-root"
|
||||
"-fs" "HFS+"
|
||||
"-volname" "factor"
|
||||
archive-name } to-strings try-process
|
||||
{ "rm" "-rf" "dmg-root" } try-process
|
||||
{ "true" } ;
|
||||
|
||||
: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: archive-cmd ( -- cmd )
|
||||
{
|
||||
{ [ os windows? ] [ windows-archive-cmd ] }
|
||||
{ [ os macosx? ] [ macosx-archive-cmd ] }
|
||||
{ [ os unix? ] [ unix-archive-cmd ] }
|
||||
}
|
||||
cond ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: make-archive ( -- ) archive-cmd to-strings try-process ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: releases ( -- path )
|
||||
builds "releases" append-path
|
||||
dup exists? not
|
||||
[ dup make-directory ]
|
||||
when ;
|
||||
|
||||
: save-archive ( -- ) archive-name releases move-file-into ;
|
|
@ -1,40 +0,0 @@
|
|||
|
||||
USING: kernel system namespaces sequences prettyprint io.files io.launcher
|
||||
bootstrap.image
|
||||
builder.util
|
||||
builder.common ;
|
||||
|
||||
IN: builder.release.branch
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: branch-name ( -- string ) "clean-" platform append ;
|
||||
|
||||
: refspec ( -- string ) "master:" branch-name append ;
|
||||
|
||||
: push-to-clean-branch ( -- )
|
||||
{ "git" "push" "factorcode.org:/git/factor.git" refspec }
|
||||
to-strings
|
||||
try-process ;
|
||||
|
||||
: upload-clean-image ( -- )
|
||||
{
|
||||
"scp"
|
||||
my-boot-image-name
|
||||
{ "factorcode.org:/var/www/factorcode.org/newsite/images/clean/" platform }
|
||||
}
|
||||
to-strings
|
||||
try-process ;
|
||||
|
||||
: (update-clean-branch) ( -- )
|
||||
"factor"
|
||||
[
|
||||
push-to-clean-branch
|
||||
upload-clean-image
|
||||
]
|
||||
with-directory ;
|
||||
|
||||
: update-clean-branch ( -- )
|
||||
upload-to-factorcode get
|
||||
[ (update-clean-branch) ]
|
||||
when ;
|
|
@ -1,27 +0,0 @@
|
|||
|
||||
USING: kernel debugger system namespaces sequences splitting combinators
|
||||
io io.files io.launcher prettyprint bootstrap.image
|
||||
combinators.cleave
|
||||
builder.util
|
||||
builder.common
|
||||
builder.release.branch
|
||||
builder.release.tidy
|
||||
builder.release.archive
|
||||
builder.release.upload ;
|
||||
|
||||
IN: builder.release
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: (release) ( -- )
|
||||
update-clean-branch
|
||||
tidy
|
||||
make-archive
|
||||
upload
|
||||
save-archive
|
||||
status-release on ;
|
||||
|
||||
: clean-build? ( -- ? )
|
||||
{ "load-everything-vocabs" "test-all-vocabs" } [ eval-file empty? ] all? ;
|
||||
|
||||
: release ( -- ) [ clean-build? [ (release) ] when ] try ;
|
|
@ -1,29 +0,0 @@
|
|||
|
||||
USING: kernel system io.files io.launcher builder.util ;
|
||||
|
||||
IN: builder.release.tidy
|
||||
|
||||
: common-files ( -- seq )
|
||||
{
|
||||
"boot.x86.32.image"
|
||||
"boot.x86.64.image"
|
||||
"boot.macosx-ppc.image"
|
||||
"boot.linux-ppc.image"
|
||||
"vm"
|
||||
"temp"
|
||||
"logs"
|
||||
".git"
|
||||
".gitignore"
|
||||
"Makefile"
|
||||
"unmaintained"
|
||||
"build-support"
|
||||
} ;
|
||||
|
||||
: remove-common-files ( -- )
|
||||
{ "rm" "-rf" common-files } to-strings try-process ;
|
||||
|
||||
: remove-factor-app ( -- )
|
||||
os macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
|
||||
|
||||
: tidy ( -- )
|
||||
"factor" [ remove-factor-app remove-common-files ] with-directory ;
|
|
@ -1,54 +0,0 @@
|
|||
|
||||
USING: kernel namespaces make sequences arrays io io.files
|
||||
builder.util
|
||||
builder.common
|
||||
builder.release.archive ;
|
||||
|
||||
IN: builder.release.upload
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: upload-host
|
||||
|
||||
SYMBOL: upload-username
|
||||
|
||||
SYMBOL: upload-directory
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: remote-location ( -- dest )
|
||||
upload-directory get platform append ;
|
||||
|
||||
: remote-archive-name ( -- dest )
|
||||
remote-location "/" archive-name 3append ;
|
||||
|
||||
: temp-archive-name ( -- dest )
|
||||
remote-archive-name ".incomplete" append ;
|
||||
|
||||
: upload-command ( -- args )
|
||||
"scp"
|
||||
archive-name
|
||||
[ upload-username get % "@" % upload-host get % ":" % temp-archive-name % ] "" make
|
||||
3array ;
|
||||
|
||||
: rename-command ( -- args )
|
||||
[
|
||||
"ssh" ,
|
||||
upload-host get ,
|
||||
"-l" ,
|
||||
upload-username get ,
|
||||
"mv" ,
|
||||
temp-archive-name ,
|
||||
remote-archive-name ,
|
||||
] { } make ;
|
||||
|
||||
: upload-temp-file ( -- )
|
||||
upload-command [ "Error uploading binary to factorcode" print ] run-or-bail ;
|
||||
|
||||
: rename-temp-file ( -- )
|
||||
rename-command [ "Error renaming binary on factorcode" print ] run-or-bail ;
|
||||
|
||||
: upload ( -- )
|
||||
upload-to-factorcode get
|
||||
[ upload-temp-file rename-temp-file ]
|
||||
when ;
|
|
@ -1,35 +0,0 @@
|
|||
|
||||
USING: kernel namespaces debugger system io io.files io.sockets
|
||||
io.encodings.utf8 prettyprint benchmark
|
||||
builder.util builder.common ;
|
||||
|
||||
IN: builder.report
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: (report) ( -- )
|
||||
|
||||
"Build machine: " write host-name print
|
||||
"CPU: " write cpu .
|
||||
"OS: " write os .
|
||||
"Build directory: " write build-dir print
|
||||
"git id: " write "git-id" eval-file print nl
|
||||
|
||||
status-vm get f = [ "compile-log" cat "vm compile error" throw ] when
|
||||
status-boot get f = [ "boot-log" 100 cat-n "Boot error" throw ] when
|
||||
status-test get f = [ "test-log" 100 cat-n "Test error" throw ] when
|
||||
|
||||
"Boot time: " write "boot-time" eval-file milli-seconds>time print
|
||||
"Load time: " write "load-time" eval-file milli-seconds>time print
|
||||
"Test time: " write "test-time" eval-file milli-seconds>time print nl
|
||||
|
||||
"Did not pass load-everything: " print "load-everything-vocabs" cat
|
||||
|
||||
"Did not pass test-all: " print "test-all-vocabs" cat
|
||||
"test-failures" cat
|
||||
|
||||
"help-lint results:" print "help-lint" cat
|
||||
|
||||
"Benchmarks: " print "benchmarks" eval-file benchmarks. ;
|
||||
|
||||
: report ( -- ) "report" utf8 [ [ (report) ] try ] with-file-writer ;
|
|
@ -1,35 +0,0 @@
|
|||
|
||||
USING: kernel namespaces assocs
|
||||
io.files io.encodings.utf8 prettyprint
|
||||
help.lint
|
||||
benchmark
|
||||
tools.time
|
||||
bootstrap.stage2
|
||||
tools.test tools.vocabs
|
||||
builder.util ;
|
||||
|
||||
IN: builder.test
|
||||
|
||||
: do-load ( -- )
|
||||
try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ;
|
||||
|
||||
: do-tests ( -- )
|
||||
run-all-tests
|
||||
[ keys "../test-all-vocabs" utf8 [ . ] with-file-writer ]
|
||||
[ "../test-failures" utf8 [ test-failures. ] with-file-writer ]
|
||||
bi ;
|
||||
|
||||
: do-help-lint ( -- )
|
||||
"" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ;
|
||||
|
||||
: do-benchmarks ( -- )
|
||||
run-benchmarks "../benchmarks" utf8 [ . ] with-file-writer ;
|
||||
|
||||
: do-all ( -- )
|
||||
bootstrap-time get "../boot-time" utf8 [ . ] with-file-writer
|
||||
[ do-load ] benchmark "../load-time" utf8 [ . ] with-file-writer
|
||||
[ do-tests ] benchmark "../test-time" utf8 [ . ] with-file-writer
|
||||
do-help-lint
|
||||
do-benchmarks ;
|
||||
|
||||
MAIN: do-all
|
|
@ -1,31 +0,0 @@
|
|||
|
||||
USING: kernel io.launcher bootstrap.image bootstrap.image.download
|
||||
builder.util builder.common ;
|
||||
|
||||
IN: builder.updates
|
||||
|
||||
: git-pull-cmd ( -- cmd )
|
||||
{
|
||||
"git"
|
||||
"pull"
|
||||
"--no-summary"
|
||||
"git://factorcode.org/git/factor.git"
|
||||
"master"
|
||||
} ;
|
||||
|
||||
: updates-available? ( -- ? )
|
||||
git-id
|
||||
git-pull-cmd try-process
|
||||
git-id
|
||||
= not ;
|
||||
|
||||
: new-image-available? ( -- ? )
|
||||
my-boot-image-name need-new-image?
|
||||
[ download-my-image t ]
|
||||
[ f ]
|
||||
if ;
|
||||
|
||||
: new-code-available? ( -- ? )
|
||||
updates-available?
|
||||
new-image-available?
|
||||
or ;
|
|
@ -1,106 +0,0 @@
|
|||
|
||||
USING: kernel words namespaces classes parser continuations
|
||||
io io.files io.launcher io.sockets
|
||||
math math.parser
|
||||
system
|
||||
combinators sequences splitting quotations arrays strings tools.time
|
||||
sequences.deep accessors assocs.lib
|
||||
io.encodings.utf8
|
||||
combinators.cleave calendar calendar.format eval ;
|
||||
|
||||
IN: builder.util
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: minutes>ms ( min -- ms ) 60 * 1000 * ;
|
||||
|
||||
: file>string ( file -- string ) utf8 file-contents ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
DEFER: to-strings
|
||||
|
||||
: to-string ( obj -- str )
|
||||
dup class
|
||||
{
|
||||
{ \ string [ ] }
|
||||
{ \ quotation [ call ] }
|
||||
{ \ word [ execute ] }
|
||||
{ \ fixnum [ number>string ] }
|
||||
{ \ array [ to-strings concat ] }
|
||||
}
|
||||
case ;
|
||||
|
||||
: to-strings ( seq -- str )
|
||||
dup [ string? ] all?
|
||||
[ ]
|
||||
[ [ to-string ] map flatten ]
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: host-name* ( -- name ) host-name "." split first ;
|
||||
|
||||
: datestamp ( -- string )
|
||||
now
|
||||
{ year>> month>> day>> hour>> minute>> } <arr>
|
||||
[ pad-00 ] map "-" join ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: milli-seconds>time ( n -- string )
|
||||
1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
|
||||
|
||||
: eval-file ( file -- obj ) utf8 file-contents eval ;
|
||||
|
||||
: cat ( file -- ) utf8 file-contents print ;
|
||||
|
||||
: run-or-bail ( desc quot -- )
|
||||
[ [ try-process ] curry ]
|
||||
[ [ throw ] compose ]
|
||||
bi*
|
||||
recover ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
USING: bootstrap.image bootstrap.image.download io.streams.null ;
|
||||
|
||||
: retrieve-image ( -- ) [ my-arch download-image ] with-null-stream ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: longer? ( seq seq -- ? ) [ length ] bi@ > ;
|
||||
|
||||
: maybe-tail* ( seq n -- seq )
|
||||
2dup longer?
|
||||
[ tail* ]
|
||||
[ drop ]
|
||||
if ;
|
||||
|
||||
: cat-n ( file n -- )
|
||||
[ utf8 file-lines ] [ ] bi*
|
||||
maybe-tail*
|
||||
[ print ] each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
USE: prettyprint
|
||||
|
||||
: to-file ( object file -- ) utf8 [ . ] with-file-writer ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: cpu- ( -- cpu ) cpu unparse "." split "-" join ;
|
||||
|
||||
: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: gnu-make ( -- string )
|
||||
os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: git-id ( -- id )
|
||||
{ "git" "show" } utf8 <process-reader> [ readln ] with-input-stream
|
||||
" " split second ;
|
|
@ -1,7 +1,8 @@
|
|||
USING: accessors alien.c-types arrays combinators destructors http.client
|
||||
io io.encodings.ascii io.files kernel math math.matrices math.parser
|
||||
math.vectors opengl opengl.capabilities opengl.gl sequences sequences.lib
|
||||
splitting vectors words ;
|
||||
USING: accessors alien.c-types arrays combinators destructors
|
||||
http.client io io.encodings.ascii io.files kernel math
|
||||
math.matrices math.parser math.vectors opengl
|
||||
opengl.capabilities opengl.gl opengl.demo-support sequences
|
||||
sequences.lib splitting vectors words ;
|
||||
IN: bunny.model
|
||||
|
||||
: numbers ( str -- seq )
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue