}
} ;
-ARTICLE: "alias" "Alias"
+ARTICLE: "alias" "Word aliasing"
"The " { $vocab-link "alias" } " vocabulary implements a way to make many different names for the same word. Although creating new names for words is generally frowned upon, aliases are useful for the Win32 API and other cases where words need to be renamed for symmetry." $nl
"Make a new word that aliases another word:"
{ $subsection define-alias }
: arch ( os cpu -- arch )
{
- { "ppc" [ name>> "-ppc" append ] }
- { "x86.64" [ name>> "winnt" = "winnt" "unix" ? "-x86.64" append ] }
+ { "ppc" [ "-ppc" append ] }
+ { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
[ nip ]
} case ;
SYMBOL: jit-return
SYMBOL: jit-profiling
SYMBOL: jit-declare-word
+SYMBOL: jit-save-stack
! Default definition for undefined words
SYMBOL: undefined-quot
{ jit-profiling 35 }
{ jit-push-immediate 36 }
{ jit-declare-word 42 }
+ { jit-save-stack 43 }
{ undefined-quot 60 }
} at header-size + ;
jit-return
jit-profiling
jit-declare-word
+ jit-save-stack
undefined-quot
} [ emit-userenv ] each ;
math.parser generic sets debugger command-line ;
IN: bootstrap.stage2
+SYMBOL: core-bootstrap-time
+
SYMBOL: bootstrap-time
: default-image-name ( -- string )
: 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
[
! We time bootstrap
- millis >r
+ millis
default-image-name "output-image" set-global
[
load-components
+ millis over - core-bootstrap-time set-global
+
run-bootstrap-init
] with-compiler-errors
:errors
] [ 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
[
V{ } clone node-stack set
##prologue
+ begin-basic-block
emit-nodes
basic-block get [
##epilogue
: emit-dispatch ( node -- )
##epilogue
- ds-pop ^^offset>slot i ##dispatch
+ ds-pop ^^offset>slot i 0 ##dispatch
dispatch-branches ;
: <dispatch-block> ( -- word )
literal>> ^^load-literal ds-push iterate-next ;
! #shuffle
-: emit-shuffle ( effect -- )
- [ out>> ] [ in>> dup length ds-load zip ] bi
- '[ _ at ] map ds-store ;
-
M: #shuffle emit-node
- shuffle-effect emit-shuffle iterate-next ;
-
-M: #>r emit-node
- [ in-d>> length ] [ out-r>> empty? ] bi
- [ neg ##inc-d ] [ ds-load rs-store ] if
- iterate-next ;
-
-M: #r> emit-node
- [ in-r>> length ] [ out-d>> empty? ] bi
- [ neg ##inc-r ] [ rs-load ds-store ] if
+ dup
+ H{ } clone
+ [ [ in-d>> [ length ds-load ] keep ] dip '[ _ set-at ] 2each ]
+ [ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
+ [ nip ] 2tri
+ [ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
+ [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi
iterate-next ;
! #return
INSN: ##return ;
! Jump tables
-INSN: ##dispatch src temp ;
+INSN: ##dispatch src temp offset ;
INSN: ##dispatch-label label ;
! Slot access
: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
[ (binary-conditional) ]
- [ drop dup successors>> first useless-branch? ] 2bi
- [ [ number>> ] 3dip negate-cc ] [ [ swap number>> ] 3dip ] if ;
+ [ drop dup successors>> second useless-branch? ] 2bi
+ [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
M: ##compare-branch linearize-insn
binary-conditional _compare-branch emit-branch ;
: post-order-traversal ( bb -- )
dup id>> visited get key? [ drop ] [
dup id>> visited get conjoin
- [ successors>> [ post-order-traversal ] each ] [ , ] bi
+ [
+ successors>> <reversed>
+ [ post-order-traversal ] each
+ ] [ , ] bi
] if ;
: post-order ( bb -- blocks )
1 ##inc-d D 0 ##replace ;
: ds-load ( n -- vregs )
- [ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ;
+ dup 0 =
+ [ drop f ]
+ [ [ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ] if ;
: ds-store ( vregs -- )
- <reversed> [ length ##inc-d ] [ [ <ds-loc> ##replace ] each-index ] bi ;
+ [
+ <reversed>
+ [ length ##inc-d ]
+ [ [ <ds-loc> ##replace ] each-index ] bi
+ ] unless-empty ;
: rs-load ( n -- vregs )
- [ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ;
+ dup 0 =
+ [ drop f ]
+ [ [ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ] if ;
: rs-store ( vregs -- )
- <reversed> [ length ##inc-r ] [ [ <rs-loc> ##replace ] each-index ] bi ;
+ [
+ <reversed>
+ [ length ##inc-r ]
+ [ [ <rs-loc> ##replace ] each-index ] bi
+ ] unless-empty ;
: 2inputs ( -- vreg1 vreg2 )
D 1 ^^peek D 0 ^^peek -2 ##inc-d ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences layouts accessors combinators namespaces
-math
+math fry
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.simplify
] when
] when ;
+: dispatch-offset ( expr -- n )
+ [ in2>> vn>constant tag-bits get neg shift ] [ op>> ] bi
+ \ ##sub-imm eq? [ neg ] when ;
+
+: add-dispatch-offset? ( insn -- expr ? )
+ src>> vreg>expr dup op>> { ##add-imm ##sub-imm } memq? ; inline
+
+M: ##dispatch rewrite
+ dup add-dispatch-offset? [
+ [ clone ] dip
+ [ in1>> vn>vreg >>src ]
+ [ dispatch-offset '[ _ + ] change-offset ] bi
+ ] [ drop ] if ;
+
M: insn rewrite ;
[ t ] [
{
T{ ##peek f V int-regs 1 D 0 }
- T{ ##dispatch f V int-regs 1 V int-regs 2 }
+ T{ ##dispatch f V int-regs 1 V int-regs 2 0 }
} dup value-numbering =
] unit-test
! 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
M: ##dispatch-label generate-insn label>> %dispatch-label ;
M: ##dispatch generate-insn
- [ src>> register ] [ temp>> register ] bi %dispatch ;
+ [ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
: >slot<
{
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 -- ? )
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
-: rel-here ( class -- )
- 0 swap rt-here rel-fixup ;
+: rel-here ( offset class -- )
+ rt-here rel-fixup ;
: init-fixup ( -- )
BV{ } clone relocation-table set
: rc-indirect-arm-pc 8 ; inline
! Relocation types
-: rt-primitive 0 ; inline
-: rt-dlsym 1 ; inline
-: rt-literal 2 ; inline
-: rt-dispatch 3 ; inline
-: rt-xt 4 ; inline
-: rt-here 5 ; inline
-: rt-label 6 ; inline
-: rt-immediate 7 ; inline
+: rt-primitive 0 ; inline
+: rt-dlsym 1 ; inline
+: rt-literal 2 ; inline
+: rt-dispatch 3 ; inline
+: rt-xt 4 ; inline
+: rt-here 5 ; inline
+: rt-label 6 ; inline
+: rt-immediate 7 ; inline
+: rt-stack-chain 8 ; inline
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]
--- /dev/null
+USING: generalizations accessors arrays compiler kernel
+kernel.private math hashtables.private math.private namespaces
+sequences sequences.private tools.test namespaces.private
+slots.private sequences.private byte-arrays alien
+alien.accessors layouts words definitions compiler.units io
+combinators vectors float-arrays ;
+IN: compiler.tests
+
+! Originally, this file did black box testing of templating
+! optimization. We now have a different codegen, but the tests
+! in here are still useful.
+
+! Oops!
+[ 5000 ] [ [ 5000 ] compile-call ] unit-test
+[ "hi" ] [ [ "hi" ] compile-call ] unit-test
+
+[ 1 2 3 4 ] [ [ 1 2 3 4 ] compile-call ] unit-test
+
+[ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
+[ 0 ] [ 3 [ tag ] compile-call ] unit-test
+[ 0 3 ] [ 3 [ [ tag ] keep ] compile-call ] unit-test
+
+[ 2 3 ] [ 3 [ 2 swap ] compile-call ] unit-test
+
+[ 2 1 3 4 ] [ 1 2 [ swap 3 4 ] compile-call ] unit-test
+
+[ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test
+
+[ { 1 2 3 } { 1 4 3 } 3 3 ]
+[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
+unit-test
+
+! Test literals in either side of a shuffle
+[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test
+
+[ 2 ] [ 1 2 [ swap fixnum/i ] compile-call ] unit-test
+
+: foo ( -- ) ;
+
+[ 5 5 ]
+[ 1.2 [ tag [ foo ] keep ] compile-call ]
+unit-test
+
+[ 1 2 2 ]
+[ { 1 2 } [ dup 2 slot swap 3 slot [ foo ] keep ] compile-call ]
+unit-test
+
+[ 3 ]
+[
+ global [ 3 \ foo set ] bind
+ \ foo [ global >n get ndrop ] compile-call
+] unit-test
+
+: blech drop ;
+
+[ 3 ]
+[
+ global [ 3 \ foo set ] bind
+ \ foo [ global [ get ] swap blech call ] compile-call
+] unit-test
+
+[ 3 ]
+[
+ global [ 3 \ foo set ] bind
+ \ foo [ global [ get ] swap >n call ndrop ] compile-call
+] unit-test
+
+[ 3 ]
+[
+ global [ 3 \ foo set ] bind
+ \ foo [ global [ get ] bind ] compile-call
+] unit-test
+
+[ 12 13 ] [
+ -12 -13 [ [ 0 swap fixnum-fast ] bi@ ] compile-call
+] unit-test
+
+[ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test
+
+[ 12 13 ] [
+ -12 -13 [ [ 0 swap fixnum- ] bi@ ] compile-call
+] unit-test
+
+[ 1 ] [
+ SBUF" " [ 1 slot 1 [ slot ] keep ] compile-call nip
+] unit-test
+
+! Test slow shuffles
+[ 3 1 2 3 4 5 6 7 8 9 ] [
+ 1 2 3 4 5 6 7 8 9
+ [ >r >r >r >r >r >r >r >r >r 3 r> r> r> r> r> r> r> r> r> ]
+ compile-call
+] unit-test
+
+[ 2 2 2 2 2 2 2 2 2 2 1 ] [
+ 1 2
+ [ swap >r dup dup dup dup dup dup dup dup dup r> ] compile-call
+] unit-test
+
+[ ] [ [ 9 [ ] times ] compile-call ] unit-test
+
+[ ] [
+ [
+ [ 200 dup [ 200 3array ] curry map drop ] times
+ ] [ define-temp ] with-compilation-unit drop
+] unit-test
+
+! Test how dispatch handles the end of a basic block
+: try-breaking-dispatch ( n a b -- x str )
+ float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
+
+: try-breaking-dispatch-2 ( -- ? )
+ 1 1.0 2.5 try-breaking-dispatch "bye" = >r 3.5 = r> and ;
+
+[ t ] [
+ 10000000 [ drop try-breaking-dispatch-2 ] all?
+] unit-test
+
+! Regression
+: (broken) ( x -- y ) ;
+
+[ 2.0 { 2.0 0.0 } ] [
+ 2.0 1.0
+ [ float/f 0.0 [ drop (broken) ] 2keep 2array ] compile-call
+] unit-test
+
+! Regression
+: hellish-bug-1 ( a b -- ) 2drop ;
+
+: hellish-bug-2 ( i array x -- x )
+ 2dup 1 slot eq? [ 2drop ] [
+ 2dup array-nth tombstone? [
+ [
+ [ array-nth ] 2keep >r 1 fixnum+fast r> array-nth
+ pick 2dup hellish-bug-1 3drop
+ ] 2keep
+ ] unless >r 2 fixnum+fast r> hellish-bug-2
+ ] if ; inline recursive
+
+: hellish-bug-3 ( hash array -- )
+ 0 swap hellish-bug-2 drop ;
+
+[ ] [
+ H{ { 1 2 } { 3 4 } } dup array>>
+ [ 0 swap hellish-bug-2 drop ] compile-call
+] unit-test
+
+! Regression
+: foox ( obj -- obj )
+ dup not
+ [ drop 3 ] [ dup tuple? [ drop 4 ] [ drop 5 ] if ] if ;
+
+[ 3 ] [ f foox ] unit-test
+
+TUPLE: my-tuple ;
+
+[ 4 ] [ T{ my-tuple } foox ] unit-test
+
+[ 5 ] [ "hi" foox ] unit-test
+
+! Making sure we don't needlessly unbox/rebox
+[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ >r eq? r> ] compile-call ] unit-test
+
+[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-call >r eq? r> ] unit-test
+
+[ t ] [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-call nip eq? ] unit-test
+
+[ 1 B{ 1 2 3 4 } ] [
+ B{ 1 2 3 4 } [
+ { byte-array } declare
+ [ 0 alien-unsigned-1 ] keep
+ ] compile-call
+] unit-test
+
+[ 1 t ] [
+ B{ 1 2 3 4 } [
+ { c-ptr } declare
+ [ 0 alien-unsigned-1 ] keep hi-tag
+ ] compile-call byte-array type-number =
+] unit-test
+
+[ t ] [
+ B{ 1 2 3 4 } [
+ { c-ptr } declare
+ 0 alien-cell hi-tag
+ ] compile-call alien type-number =
+] unit-test
+
+[ 2 1 ] [
+ 2 1
+ [ 2dup fixnum< [ >r die r> ] when ] compile-call
+] unit-test
+
+! Regression
+: a-dummy ( a -- ) drop "hi" print ;
+
+[ ] [
+ 1 [
+ dup 0 2 3dup pick >= [ >= ] [ 2drop f ] if [
+ drop - >fixnum {
+ [ a-dummy ]
+ [ a-dummy ]
+ [ a-dummy ]
+ } dispatch
+ ] [ 2drop no-case ] if
+ ] compile-call
+] unit-test
+
+! Regression
+: dispatch-alignment-regression ( -- c )
+ { tuple vector } 3 slot { word } declare
+ dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
+
+[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
+
+[ vector ] [ dispatch-alignment-regression ] unit-test
+
+! Regression
+: 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
+
+! New optimization
+: test-1 ( a -- b ) 8 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
+
+[ "a" ] [ 8 test-1 ] unit-test
+[ "b" ] [ 9 test-1 ] unit-test
+
+: test-2 ( a -- b ) 1 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
+
+[ "a" ] [ 1 test-2 ] unit-test
+[ "b" ] [ 2 test-2 ] unit-test
+++ /dev/null
-USING: generalizations accessors arrays compiler kernel
-kernel.private math hashtables.private math.private namespaces
-sequences sequences.private tools.test namespaces.private
-slots.private sequences.private byte-arrays alien
-alien.accessors layouts words definitions compiler.units io
-combinators vectors float-arrays ;
-IN: compiler.tests
-
-! Originally, this file did black box testing of templating
-! optimization. We now have a different codegen, but the tests
-! in here are still useful.
-
-! Oops!
-[ 5000 ] [ [ 5000 ] compile-call ] unit-test
-[ "hi" ] [ [ "hi" ] compile-call ] unit-test
-
-[ 1 2 3 4 ] [ [ 1 2 3 4 ] compile-call ] unit-test
-
-[ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
-[ 0 ] [ 3 [ tag ] compile-call ] unit-test
-[ 0 3 ] [ 3 [ [ tag ] keep ] compile-call ] unit-test
-
-[ 2 3 ] [ 3 [ 2 swap ] compile-call ] unit-test
-
-[ 2 1 3 4 ] [ 1 2 [ swap 3 4 ] compile-call ] unit-test
-
-[ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test
-
-[ { 1 2 3 } { 1 4 3 } 3 3 ]
-[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
-unit-test
-
-! Test literals in either side of a shuffle
-[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test
-
-[ 2 ] [ 1 2 [ swap fixnum/i ] compile-call ] unit-test
-
-: foo ( -- ) ;
-
-[ 5 5 ]
-[ 1.2 [ tag [ foo ] keep ] compile-call ]
-unit-test
-
-[ 1 2 2 ]
-[ { 1 2 } [ dup 2 slot swap 3 slot [ foo ] keep ] compile-call ]
-unit-test
-
-[ 3 ]
-[
- global [ 3 \ foo set ] bind
- \ foo [ global >n get ndrop ] compile-call
-] unit-test
-
-: blech drop ;
-
-[ 3 ]
-[
- global [ 3 \ foo set ] bind
- \ foo [ global [ get ] swap blech call ] compile-call
-] unit-test
-
-[ 3 ]
-[
- global [ 3 \ foo set ] bind
- \ foo [ global [ get ] swap >n call ndrop ] compile-call
-] unit-test
-
-[ 3 ]
-[
- global [ 3 \ foo set ] bind
- \ foo [ global [ get ] bind ] compile-call
-] unit-test
-
-[ 12 13 ] [
- -12 -13 [ [ 0 swap fixnum-fast ] bi@ ] compile-call
-] unit-test
-
-[ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test
-
-[ 12 13 ] [
- -12 -13 [ [ 0 swap fixnum- ] bi@ ] compile-call
-] unit-test
-
-[ 1 ] [
- SBUF" " [ 1 slot 1 [ slot ] keep ] compile-call nip
-] unit-test
-
-! Test slow shuffles
-[ 3 1 2 3 4 5 6 7 8 9 ] [
- 1 2 3 4 5 6 7 8 9
- [ >r >r >r >r >r >r >r >r >r 3 r> r> r> r> r> r> r> r> r> ]
- compile-call
-] unit-test
-
-[ 2 2 2 2 2 2 2 2 2 2 1 ] [
- 1 2
- [ swap >r dup dup dup dup dup dup dup dup dup r> ] compile-call
-] unit-test
-
-[ ] [ [ 9 [ ] times ] compile-call ] unit-test
-
-[ ] [
- [
- [ 200 dup [ 200 3array ] curry map drop ] times
- ] [ define-temp ] with-compilation-unit drop
-] unit-test
-
-! Test how dispatch handles the end of a basic block
-: try-breaking-dispatch ( n a b -- x str )
- float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
-
-: try-breaking-dispatch-2 ( -- ? )
- 1 1.0 2.5 try-breaking-dispatch "bye" = >r 3.5 = r> and ;
-
-[ t ] [
- 10000000 [ drop try-breaking-dispatch-2 ] all?
-] unit-test
-
-! Regression
-: (broken) ( x -- y ) ;
-
-[ 2.0 { 2.0 0.0 } ] [
- 2.0 1.0
- [ float/f 0.0 [ drop (broken) ] 2keep 2array ] compile-call
-] unit-test
-
-! Regression
-: hellish-bug-1 ( a b -- ) 2drop ;
-
-: hellish-bug-2 ( i array x -- x )
- 2dup 1 slot eq? [ 2drop ] [
- 2dup array-nth tombstone? [
- [
- [ array-nth ] 2keep >r 1 fixnum+fast r> array-nth
- pick 2dup hellish-bug-1 3drop
- ] 2keep
- ] unless >r 2 fixnum+fast r> hellish-bug-2
- ] if ; inline recursive
-
-: hellish-bug-3 ( hash array -- )
- 0 swap hellish-bug-2 drop ;
-
-[ ] [
- H{ { 1 2 } { 3 4 } } dup array>>
- [ 0 swap hellish-bug-2 drop ] compile-call
-] unit-test
-
-! Regression
-: foox ( obj -- obj )
- dup not
- [ drop 3 ] [ dup tuple? [ drop 4 ] [ drop 5 ] if ] if ;
-
-[ 3 ] [ f foox ] unit-test
-
-TUPLE: my-tuple ;
-
-[ 4 ] [ T{ my-tuple } foox ] unit-test
-
-[ 5 ] [ "hi" foox ] unit-test
-
-! Making sure we don't needlessly unbox/rebox
-[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ >r eq? r> ] compile-call ] unit-test
-
-[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-call >r eq? r> ] unit-test
-
-[ t ] [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-call nip eq? ] unit-test
-
-[ 1 B{ 1 2 3 4 } ] [
- B{ 1 2 3 4 } [
- { byte-array } declare
- [ 0 alien-unsigned-1 ] keep
- ] compile-call
-] unit-test
-
-[ 1 t ] [
- B{ 1 2 3 4 } [
- { c-ptr } declare
- [ 0 alien-unsigned-1 ] keep hi-tag
- ] compile-call byte-array type-number =
-] unit-test
-
-[ t ] [
- B{ 1 2 3 4 } [
- { c-ptr } declare
- 0 alien-cell hi-tag
- ] compile-call alien type-number =
-] unit-test
-
-[ 2 1 ] [
- 2 1
- [ 2dup fixnum< [ >r die r> ] when ] compile-call
-] unit-test
-
-! Regression
-: a-dummy ( a -- ) drop "hi" print ;
-
-[ ] [
- 1 [
- dup 0 2 3dup pick >= [ >= ] [ 2drop f ] if [
- drop - >fixnum {
- [ a-dummy ]
- [ a-dummy ]
- [ a-dummy ]
- } dispatch
- ] [ 2drop no-case ] if
- ] compile-call
-] unit-test
-
-! Regression
-: dispatch-alignment-regression ( -- c )
- { tuple vector } 3 slot { word } declare
- dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
-
-[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
-
-[ vector ] [ dispatch-alignment-regression ] unit-test
-
-! Regression
-: bad-value-bug ( a -- b ) [ 3 ] [ 3 ] if f <array> ;
-
-[ { f f f } ] [ t bad-value-bug ] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors quotations kernel sequences namespaces
-assocs words arrays vectors hints combinators stack-checker
-stack-checker.state stack-checker.visitor stack-checker.errors
-stack-checker.backend compiler.tree ;
+assocs words arrays vectors hints combinators compiler.tree
+stack-checker
+stack-checker.state
+stack-checker.errors
+stack-checker.visitor
+stack-checker.backend
+stack-checker.recursive-state ;
IN: compiler.tree.builder
: with-tree-builder ( quot -- nodes )
: build-tree ( quot -- nodes )
#! Not safe to call from inference transforms.
- [ f infer-quot ] with-tree-builder nip ;
+ [ f initial-recursive-state infer-quot ] with-tree-builder nip ;
: build-tree-with ( in-stack quot -- nodes out-stack )
#! Not safe to call from inference transforms.
[
- [ >vector meta-d set ] [ f infer-quot ] bi*
+ [ >vector meta-d set ]
+ [ f initial-recursive-state infer-quot ] bi*
] with-tree-builder nip
unclip-last in-d>> ;
dup
[ "inline" word-prop ]
[ "recursive" word-prop ] bi and [
- 1quotation f infer-quot
+ 1quotation f initial-recursive-state infer-quot
] [
- [ specialized-def ]
- [ dup 2array 1array ] bi infer-quot
+ [ specialized-def ] [ initial-recursive-state ] bi
+ infer-quot
] if ;
: check-cannot-infer ( word -- )
GENERIC: check-node* ( node -- )
M: #shuffle check-node*
- [ [ mapping>> values ] [ in-d>> ] bi subset? [ "Bad mapping inputs" throw ] unless ]
- [ [ mapping>> keys ] [ out-d>> ] bi set= [ "Bad mapping outputs" throw ] unless ]
+ [ [ mapping>> values ] [ [ in-d>> ] [ in-r>> ] bi append ] bi subset? [ "Bad mapping inputs" throw ] unless ]
+ [ [ mapping>> keys ] [ [ out-d>> ] [ out-r>> ] bi append ] bi set= [ "Bad mapping outputs" throw ] unless ]
bi ;
: check-lengths ( seq -- )
M: #copy check-node* inputs/outputs 2array check-lengths ;
-: check->r/r> ( node -- )
- inputs/outputs [ drop ] [ 2array check-lengths ] if-empty ;
-
-M: #>r check-node* check->r/r> ;
-
-M: #r> check-node* check->r/r> ;
-
M: #return-recursive check-node* inputs/outputs 2array check-lengths ;
M: #phi check-node*
M: #call check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
-M: #shuffle check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
-
-M: #>r check-stack-flow* [ check-in-d ] [ check-out-r ] bi ;
-
-M: #r> check-stack-flow* [ check-in-r ] [ check-out-d ] bi ;
+M: #shuffle check-stack-flow*
+ { [ check-in-d ] [ check-in-r ] [ check-out-d ] [ check-out-r ] } cleave ;
: assert-datastack-empty ( -- )
datastack get empty? [ "Data stack not empty" throw ] unless ;
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
[ { 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
#! 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 ;
[ drop filter-live ] [ swap nths ] 2bi
[ make-values ] keep
[ drop ] [ zip ] 2bi
- #shuffle ;
+ #data-shuffle ;
: insert-drops ( nodes values indices -- nodes' )
'[
M: #call compute-live-values* nip look-at-inputs ;
-M: #>r compute-live-values*
- [ out-r>> ] [ in-d>> ] bi look-at-mapping ;
-
-M: #r> compute-live-values*
- [ out-d>> ] [ in-r>> ] bi look-at-mapping ;
-
M: #shuffle compute-live-values*
mapping>> at look-at-value ;
zip filter-mapping values ;
: filter-live ( values -- values' )
- [ live-value? ] filter ;
+ dup empty? [ [ live-value? ] filter ] unless ;
:: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle )
inputs
outputs
mapping-keys
mapping-values
- filter-corresponding zip #shuffle ; inline
+ filter-corresponding zip #data-shuffle ; inline
:: drop-dead-values ( outputs -- #shuffle )
[let* | new-outputs [ outputs make-values ]
M: #introduce remove-dead-code* ( #introduce -- nodes )
maybe-drop-dead-outputs ;
-M: #>r remove-dead-code*
- [ filter-live ] change-out-r
- [ filter-live ] change-in-d
- dup in-d>> empty? [ drop f ] when ;
-
-M: #r> remove-dead-code*
- [ filter-live ] change-out-d
- [ filter-live ] change-in-r
- dup in-r>> empty? [ drop f ] when ;
-
M: #push remove-dead-code*
dup out-d>> first live-value? [ drop f ] unless ;
M: #shuffle remove-dead-code*
[ filter-live ] change-in-d
[ filter-live ] change-out-d
+ [ filter-live ] change-in-r
+ [ filter-live ] change-out-r
[ filter-mapping ] change-mapping
- dup in-d>> empty? [ drop f ] when ;
+ dup [ in-d>> empty? ] [ in-r>> empty? ] bi and [ drop f ] when ;
M: #copy remove-dead-code*
[ in-d>> ] [ out-d>> ] bi
- 2dup swap zip #shuffle
+ 2dup swap zip #data-shuffle
remove-dead-code* ;
M: #terminate remove-dead-code*
USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
prettyprint prettyprint.backend prettyprint.sections math words
-combinators io sorting hints qualified
+combinators combinators.short-circuit io sorting hints qualified
compiler.tree
compiler.tree.recursive
compiler.tree.normalization
M: shuffle-node pprint* effect>> effect>string text ;
+: (shuffle-effect) ( in out #shuffle -- effect )
+ mapping>> '[ _ at ] map <effect> ;
+
+: shuffle-effect ( #shuffle -- effect )
+ [ in-d>> ] [ out-d>> ] [ ] tri (shuffle-effect) ;
+
+: #>r? ( #shuffle -- ? )
+ {
+ [ in-d>> length 1 = ]
+ [ out-r>> length 1 = ]
+ [ in-r>> empty? ]
+ [ out-d>> empty? ]
+ } 1&& ;
+
+: #r>? ( #shuffle -- ? )
+ {
+ [ in-d>> empty? ]
+ [ out-r>> empty? ]
+ [ in-r>> length 1 = ]
+ [ out-d>> length 1 = ]
+ } 1&& ;
+
M: #shuffle node>quot
- shuffle-effect dup pretty-shuffle
- [ % ] [ shuffle-node boa , ] ?if ;
+ {
+ { [ dup #>r? ] [ drop \ >r , ] }
+ { [ dup #r>? ] [ drop \ r> , ] }
+ {
+ [ dup [ in-r>> empty? ] [ out-r>> empty? ] bi and ]
+ [
+ shuffle-effect dup pretty-shuffle
+ [ % ] [ shuffle-node boa , ] ?if
+ ]
+ }
+ [ drop "COMPLEX SHUFFLE" , ]
+ } cond ;
M: #push node>quot literal>> , ;
M: #dispatch node>quot
children>> [ nodes>quot ] map , \ dispatch , ;
-M: #>r node>quot
- [ in-d>> length ] [ out-r>> empty? \ drop \ >r ? ] bi
- <repetition> % ;
-
-DEFER: rdrop
-
-M: #r> node>quot
- [ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi
- <repetition> % ;
-
M: #alien-invoke node>quot params>> , \ #alien-invoke , ;
M: #alien-indirect node>quot params>> , \ #alien-indirect , ;
M: #introduce node-uses-values drop f ;
M: #push node-uses-values drop f ;
-M: #r> node-uses-values in-r>> ;
M: #phi node-uses-values phi-in-d>> concat remove-bottom prune ;
M: #declare node-uses-values declaration>> keys ;
M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
+M: #shuffle node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
M: #alien-callback node-uses-values drop f ;
M: node node-uses-values in-d>> ;
GENERIC: node-defs-values ( node -- values )
-M: #>r node-defs-values out-r>> ;
+M: #shuffle node-defs-values [ out-d>> ] [ out-r>> ] bi append ;
M: #branch node-defs-values drop f ;
M: #declare node-defs-values drop f ;
M: #return node-defs-values drop f ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces sequences kernel math
-combinators sets disjoint-sets fry stack-checker.state ;
+combinators sets disjoint-sets fry stack-checker.values ;
IN: compiler.tree.escape-analysis.allocations
! A map from values to one of the following:
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
propagate
cleanup
escape-analysis
+ dup check-nodes
0 swap [ count-unboxed-allocations* ] each-node ;
[ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
: 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 ]
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences words memoize classes.builtin
+fry assocs
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
M: #copy finalize* drop f ;
M: #shuffle finalize*
- dup shuffle-effect
- [ in>> ] [ out>> ] bi sequence=
- [ drop f ] when ;
+ dup
+ [ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
+ [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
+ bi and [ drop f ] when ;
: builtin-predicate? ( #call -- ? )
word>> "predicating" word-prop builtin-class? ;
: select-input ( node n -- #shuffle )
[ [ in-d>> ] [ out-d>> ] bi ] dip
- pick nth over first associate #shuffle ;
+ pick nth over first associate #data-shuffle ;
M: #call apply-identities*
dup word>> "identities" word-prop [
[ rename-map get at ] keep or ;
: rename-values ( values -- values' )
- rename-map get '[ [ _ at ] keep or ] map ;
+ dup empty? [ rename-map get '[ [ _ at ] keep or ] map ] unless ;
: add-renamings ( old new -- )
[ rename-values ] dip
M: #shuffle rename-node-values*
[ rename-values ] change-in-d
+ [ rename-values ] change-in-r
[ [ rename-value ] assoc-map ] change-mapping ;
M: #push rename-node-values* ;
-M: #r> rename-node-values*
- [ rename-values ] change-in-r ;
-
M: #terminate rename-node-values*
[ rename-values ] change-in-d
[ rename-values ] change-in-r ;
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
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?
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?
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*
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
: 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<=
: 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 {
: literals<= ( info1 info2 -- ? )
{
{ [ dup literal?>> not ] [ 2drop t ] }
- { [ over literal?>> not ] [ 2drop f ] }
+ { [ over literal?>> not ] [ drop class>> null-class? ] }
[ [ literal>> ] bi@ eql? ]
} cond ;
]
} 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< ;
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
[ 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
! 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
: 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) ;
[ 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' )
{
] 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 ]
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 ;
[ 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) ;
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) ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry arrays generic assocs kernel math namespaces parser
-sequences words vectors math.intervals effects classes
+sequences words vectors math.intervals classes
accessors combinators stack-checker.state stack-checker.visitor
stack-checker.inlining ;
IN: compiler.tree
TUPLE: #renaming < node ;
-TUPLE: #shuffle < #renaming mapping in-d out-d ;
+TUPLE: #shuffle < #renaming mapping in-d out-d in-r out-r ;
-: #shuffle ( inputs outputs mapping -- node )
+: #shuffle ( in-d out-d in-r out-r mapping -- node )
\ #shuffle new
swap >>mapping
- swap >>out-d
- swap >>in-d ;
-
-: #drop ( inputs -- node )
- { } { } #shuffle ;
-
-TUPLE: #>r < #renaming in-d out-r ;
-
-: #>r ( inputs outputs -- node )
- \ #>r new
swap >>out-r
+ swap >>in-r
+ swap >>out-d
swap >>in-d ;
-TUPLE: #r> < #renaming in-r out-d ;
+: #data-shuffle ( in-d out-d mapping -- node )
+ [ f f ] dip #shuffle ; inline
-: #r> ( inputs outputs -- node )
- \ #r> new
- swap >>out-d
- swap >>in-r ;
+: #drop ( inputs -- node )
+ { } { } #data-shuffle ;
TUPLE: #terminate < node in-d in-r ;
GENERIC: inputs/outputs ( #renaming -- inputs outputs )
M: #shuffle inputs/outputs mapping>> unzip swap ;
-M: #>r inputs/outputs [ in-d>> ] [ out-r>> ] bi ;
-M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ;
M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
-: shuffle-effect ( #shuffle -- effect )
- [ in-d>> ] [ out-d>> ] [ mapping>> ] tri
- '[ _ at ] map
- <effect> ;
-
: recursive-phi-in ( #enter-recursive -- seq )
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
M: vector #push, #push node, ;
M: vector #shuffle, #shuffle node, ;
M: vector #drop, #drop node, ;
-M: vector #>r, #>r node, ;
-M: vector #r>, #r> node, ;
+M: vector #>r, [ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
+M: vector #r>, [ swap [ f swap ] dip f ] [ swap zip ] 2bi #shuffle, ;
M: vector #return, #return node, ;
M: vector #enter-recursive, #enter-recursive node, ;
M: vector #return-recursive, #return-recursive node, ;
[ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
: flatten-values ( values -- values' )
- (flatten-values) flatten ;
+ dup empty? [ (flatten-values) flatten ] unless ;
: prepare-slot-access ( #call -- tuple-values outputs slot-values )
[ in-d>> flatten-values ]
] tri ;
: slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
- [ drop ] [ zip ] 2bi #shuffle ;
+ [ drop ] [ zip ] 2bi #data-shuffle ;
: unbox-slot-access ( #call -- nodes )
dup out-d>> first unboxed-slot-access? [
[ flatten-values ] change-in-d
[ flatten-values ] change-out-d ;
-M: #>r unbox-tuples*
- [ flatten-values ] change-in-d
- [ flatten-values ] change-out-r ;
-
-M: #r> unbox-tuples*
- [ flatten-values ] change-in-r
- [ flatten-values ] change-out-d ;
-
M: #shuffle unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-out-d
+ [ flatten-values ] change-in-r
+ [ flatten-values ] change-out-r
[ unzip [ flatten-values ] bi@ zip ] change-mapping ;
M: #terminate unbox-tuples*
HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- )
-HOOK: %dispatch cpu ( src temp -- )
+HOOK: %dispatch cpu ( src temp offset -- )
HOOK: %dispatch-label cpu ( word -- )
HOOK: %slot cpu ( dst obj slot tag temp -- )
! 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 ( -- )
\r
[\r
0 6 LOAD32\r
- 4 1 MR\r
+ 7 6 0 LWZ\r
+ 1 7 0 STW\r
+] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define\r
+\r
+[\r
+ 0 6 LOAD32\r
6 MTCTR\r
BCTR\r
] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define\r
! 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
<<
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 ;
! 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
<<
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 ;
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:
! 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 ;
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
: 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 ;
M: ppc %jump-label ( label -- ) B ;
M: ppc %return ( -- ) BLR ;
-M:: ppc %dispatch ( src temp -- )
- 0 temp LOAD32 rc-absolute-ppc-2/2 rel-here
- temp temp src ADD
- temp temp 5 cells LWZ
+M:: ppc %dispatch ( src temp offset -- )
+ 0 temp LOAD32
+ 4 offset + cells rc-absolute-ppc-2/2 rel-here
+ temp temp src LWZX
temp MTCTR
BCTR ;
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 ;
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
"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 -- )
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 + ;
-
-: 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-integer ( src n -- ) spill-integer@ 1 swap STW ;
+M: ppc %reload-integer ( dst n -- ) spill-integer@ 1 swap 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 ;
cpu.x86 cpu.architecture compiler compiler.units
compiler.constants compiler.alien compiler.codegen
compiler.codegen.fixup compiler.cfg.instructions
-compiler.cfg.builder compiler.cfg.intrinsics ;
+compiler.cfg.builder compiler.cfg.intrinsics make ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;
+M:: x86.32 %dispatch ( src temp offset -- )
+ ! Load jump table base.
+ src HEX: ffffffff ADD
+ offset cells rc-absolute-cell rel-here
+ ! Go
+ src HEX: 7f [+] JMP
+ ! Fix up the displacement above
+ cell code-alignment
+ [ 7 + building get dup pop* push ]
+ [ align-code ]
+ bi ;
+
M: x86.32 reserved-area-size 0 ;
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
[ 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)
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
-cpu.x86.assembler layouts vocabs parser ;
+cpu.x86.assembler layouts vocabs parser compiler.constants ;
IN: bootstrap.x86
4 \ cell set
: fixnum>slot@ ( -- ) arg0 1 SAR ;
: rex-length ( -- n ) 0 ;
+[
+ arg0 0 [] MOV ! load stack_chain
+ arg0 [] stack-reg MOV ! save stack pointer
+] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define
+
+[
+ (JMP) drop
+] rc-relative rt-primitive 1 jit-primitive jit-define
+
<< "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >>
call
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math namespaces make sequences
system layouts alien alien.c-types alien.accessors alien.structs
-slots splitting assocs combinators cpu.x86.assembler
+slots splitting assocs combinators make locals cpu.x86.assembler
cpu.x86 cpu.architecture compiler.constants
compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
+M:: x86.64 %dispatch ( src temp offset -- )
+ ! Load jump table base.
+ temp HEX: ffffffff MOV
+ offset cells rc-absolute-cell rel-here
+ ! Add jump table base
+ src temp ADD
+ src HEX: 7f [+] JMP
+ ! Fix up the displacement above
+ cell code-alignment
+ [ 15 + building get dup pop* push ]
+ [ align-code ]
+ bi ;
+
: 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 ;
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 -- )
[
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
: %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 ;
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 ;
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>> {
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
! 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 ;
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
-cpu.x86.assembler layouts vocabs parser ;
+cpu.x86.assembler layouts vocabs parser compiler.constants math ;
IN: bootstrap.x86
8 \ cell set
: fixnum>slot@ ( -- ) ;
: rex-length ( -- n ) 1 ;
+[
+ arg0 0 MOV ! load stack_chain
+ arg0 arg0 [] MOV
+ arg0 [] stack-reg MOV ! save stack pointer
+] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define
+
+[
+ arg1 0 MOV ! load XT
+ arg1 JMP ! go
+] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
+
<< "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >>
call
--- /dev/null
+unportable
! 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 } ;
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 ;
--- /dev/null
+unportable
! 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 } ;
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
ds-reg [] arg0 MOV ! store literal on datastack
] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
-[
- arg0 0 MOV ! load XT
- arg1 stack-reg MOV ! pass callstack pointer as arg 2
- arg0 JMP ! go
-] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
-
[
(JMP) drop
] rc-relative rt-xt 1 jit-word-jump jit-define
: align-code ( n -- )
0 <repetition> % ;
-M:: x86 %dispatch ( src temp -- )
- ! Load jump table base. We use a temporary register
- ! since on AMD64 we have to load a 64-bit immediate. On
- ! x86, this is redundant.
- ! Add jump table base
- temp HEX: ffffffff MOV rc-absolute-cell rel-here
- src temp ADD
- src HEX: 7f [+] JMP
- ! Fix up the displacement above
- cell code-alignment dup bootstrap-cell 8 = 15 9 ? +
- building get dup pop* push
- align-code ;
-
M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
: 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 + ;
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 -- )
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 -- ? )
[ 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
: 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
: emacsclient ( file line -- )
[
- "emacsclient" ,
+ \ emacsclient get "emacsclient" or ,
"--no-wait" ,
"+" swap number>string append ,
,
--- /dev/null
+Kibleur Christophe
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Kibleur Christophe.
+! See http://factorcode.org/license.txt for BSD license.
+USING: editors io.files io.launcher kernel math.parser
+namespaces sequences windows.shell32 make ;
+IN: editors.etexteditor
+
+: etexteditor-path ( -- str )
+ \ etexteditor-path get-global [
+ program-files "e\\e.exe" append-path
+ ] unless* ;
+
+: etexteditor ( file line -- )
+ [
+ etexteditor-path ,
+ [ , ] [ "--line" , number>string , ] bi*
+ ] { } make run-detached drop ;
+
+[ etexteditor ] edit-hook set-global
--- /dev/null
+etexteditor integration
--- /dev/null
+unportable
! 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 ;
--- /dev/null
+USING: assocs classes help.markup help.syntax io.streams.string
+http http.server.dispatchers http.server.responses
+furnace.redirection strings multiline ;
+IN: furnace.actions
+
+HELP: <action>
+{ $values { "action" action } }
+{ $description "Creates a new action." } ;
+
+HELP: <chloe-content>
+{ $values
+ { "path" "a pathname string" }
+ { "response" response }
+}
+{ $description "Creates an HTTP response which serves a Chloe template. See " { $link "html.templates.chloe" } "." } ;
+
+HELP: <page-action>
+{ $values { "page" action } }
+{ $description "Creates a new action which serves a Chloe template when servicing a GET request." } ;
+
+HELP: action
+{ $description "The class of Furnace actions. New instances are created with " { $link <action> } ". New instances of subclasses can be created with " { $link new-action } ". The " { $link page-action } " class is a useful subclass."
+$nl
+"Action slots are documented in " { $link "furnace.actions.config" } "." } ;
+
+HELP: new-action
+{ $values
+ { "class" class }
+ { "action" action }
+}
+{ $description "Constructs a subclass of " { $link action } "." } ;
+
+HELP: page-action
+{ $description "The class of Chloe page actions. These are actions whose " { $slot "display" } " slot is pre-set to serve the Chloe template stored in the " { $slot "page" } " slot." } ;
+
+HELP: param
+{ $values
+ { "name" string }
+ { "value" string }
+}
+{ $description "Outputs the value of a query parameter (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
+{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ;
+
+HELP: params
+{ $var-description "A variable holding an assoc of query parameters (if the current request is a GET or HEAD request) or POST parameters (if the current request is a POST request)." }
+{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ;
+
+HELP: validate-integer-id
+{ $description "A utility word which validates an integer parameter named " { $snippet "id" } "." }
+{ $examples
+ { $code
+ "<action>"
+ " ["
+ " validate-integer-id"
+ " \"id\" value <person> select-tuple from-object"
+ " ] >>init"
+ }
+} ;
+
+HELP: validate-params
+{ $values
+ { "validators" "an association list mapping parameter names to validator quotations" }
+}
+{ $description "Validates query or POST parameters, depending on the request type, and stores them in " { $link "html.forms.values" } ". The validator quotations can execute " { $link "validators" } "." }
+{ $examples
+ "A simple validator from " { $vocab-link "webapps.todo" } "; this word is invoked from the " { $slot "validate" } " quotation of action for editing a todo list item:"
+ { $code
+ <" : validate-todo ( -- )
+ {
+ { "summary" [ v-one-line ] }
+ { "priority" [ v-integer 0 v-min-value 10 v-max-value ] }
+ { "description" [ v-required ] }
+ } validate-params ;">
+ }
+} ;
+
+HELP: validation-failed
+{ $description "Stops processing the current request and takes action depending on the type of the current request:"
+ { $list
+ { "For GET or HEAD requests, the client receives a " { $link <400> } " response." }
+ { "For POST requests, the client is sent back to the page containing the form submission, with current form values and validation errors passed in a " { $link "furnace.conversations" } "." }
+ }
+"This word is called by " { $link validate-params } " and can also be called directly. For more details, see " { $link "furnace.actions.lifecycle" } "." } ;
+
+ARTICLE: "furnace.actions.page.example" "Furnace page action example"
+"The " { $vocab-link "webapps.counter" } " vocabulary defines a subclass of " { $link dispatcher } ":"
+{ $code "TUPLE: counter-app < dispatcher ;" }
+"The " { $snippet "<counter-app>" } " constructor word creates a new instance of the " { $snippet "counter-app" } " class, and adds a " { $link page-action } " instance to the dispatcher. This " { $link page-action } " has its " { $slot "template" } " slot set as follows,"
+{ $code "{ counter-app \"counter\" } >>template" }
+"This means the action will serve the Chloe template located at " { $snippet "resource:extra/webapps/counter/counter.xml" } " upon receiving a GET request." ;
+
+ARTICLE: "furnace.actions.page" "Furnace page actions"
+"Page actions implement the common case of an action that simply serves a Chloe template in response to a GET request."
+{ $subsection page-action }
+{ $subsection <page-action> }
+"When using a page action, instead of setting the " { $slot "display" } " slot, the " { $slot "template" } " slot is set instead. The " { $slot "init" } ", " { $slot "authorize" } ", " { $slot "validate" } " and " { $slot "submit" } " slots can still be set as usual."
+$nl
+"The " { $slot "template" } " slot of a " { $link page-action } " contains a pair with shape " { $snippet "{ responder name }" } ", where " { $snippet "responder" } " is a responder class, usually a subclass of " { $link dispatcher } ", and " { $snippet "name" } " is the name of a template file, without the " { $snippet ".xml" } " extension, relative to the directory containing the responder's vocabulary source file."
+{ $subsection "furnace.actions.page.example" } ;
+
+ARTICLE: "furnace.actions.config" "Furnace action configuration"
+"Actions have the following slots:"
+{ $table
+ { { $slot "rest" } { "A parameter name to map the rest of the URL, after the action name, to. If this is not set, then navigating to a URL where the action is not the last path component will return to the client with an error." } }
+ { { $slot "init" } { "A quotation called at the beginning of a GET or HEAD request. Typically this quotation configures " { $link "html.forms" } " and parses query parameters." } }
+ { { $slot "authorize" } { "A quotation called at the beginning of a GET, HEAD or POST request. In GET requests, it is called after the " { $slot "init" } " quotation; in POST requests, it is called after the " { $slot "validate" } " quotation. By convention, this quotation performs custom authorization checks which depend on query parameters or POST parameters." } }
+ { { $slot "display" } { "A quotation called after the " { $slot "init" } " quotation in a GET request. This quotation must return an HTTP " { $link response } "." } }
+ { { $slot "validate" } { "A quotation called at the beginning of a POST request to validate POST parameters." } }
+ { { $slot "submit" } { "A quotation called after the " { $slot "validate" } " quotation in a POST request. This quotation must return an HTTP " { $link response } "." } }
+}
+"At least one of the " { $slot "display" } " and " { $slot "submit" } " slots must be set, otherwise the action will be useless." ;
+
+ARTICLE: "furnace.actions.validation" "Form validation with actions"
+"The action code is set up so that the " { $slot "init" } " quotation can validate query parameters, and the " { $slot "validate" } " quotation can validate POST parameters."
+$nl
+"A word to validate parameters and make them available as HTML form values (see " { $link "html.forms.values" } "); typically this word is invoked from the " { $slot "init" } " and " { $slot "validate" } " quotations:"
+{ $subsection validate-params }
+"The above word expects an association list mapping parameter names to validator quotations; validator quotations can use the words in the "
+"Custom validation logic can invoke a word when validation fails; " { $link validate-params } " invokes this word for you:"
+{ $subsection validation-failed }
+"If validation fails, no more action code is executed, and the client is redirected back to the originating page, where validation errors can be displayed. Note that validation errors are rendered automatically by the " { $link "html.components" } " words, and in particular, " { $link "html.templates.chloe" } " use these words." ;
+
+ARTICLE: "furnace.actions.lifecycle" "Furnace action lifecycle"
+{ $heading "GET request lifecycle" }
+"A GET request results in the following sequence of events:"
+{ $list
+ { "The " { $snippet "init" } " quotation is called." }
+ { "The " { $snippet "authorize" } " quotation is called." }
+ { "If the GET request was generated as a result of form validation failing during a POST, then the form values entered by the user, along with validation errors, are stored in " { $link "html.forms.values" } "." }
+ { "The " { $snippet "display" } " quotation is called; it is expected to output an HTTP " { $link response } " on the stack." }
+}
+"Any one of the above steps can perform validation; if " { $link validation-failed } " is called during a GET request, the client receives a " { $link <400> } " error."
+{ $heading "HEAD request lifecycle" }
+"A HEAD request proceeds exactly like a GET request. The only difference is that the " { $slot "body" } " slot of the " { $link response } " object is never rendered."
+{ $heading "POST request lifecycle" }
+"A POST request results in the following sequence of events:"
+{ $list
+ { "The " { $snippet "validate" } " quotation is called." }
+ { "The " { $snippet "authorize" } " quotation is called." }
+ { "The " { $snippet "submit" } " quotation is called; it is expected to output an HTTP " { $link response } " on the stack. By convention, this response should be a " { $link <redirect> } "." }
+}
+"Any one of the above steps can perform validation; if " { $link validation-failed } " is called during a POST request, the client is sent back to the page containing the form submission, with current form values and validation errors passed in a " { $link "furnace.conversations" } "." ;
+
+ARTICLE: "furnace.actions.impl" "Furnace actions implementation"
+"The following words are used by the action implementation and there is rarely any reason to call them directly:"
+{ $subsection new-action }
+{ $subsection param }
+{ $subsection params } ;
+
+ARTICLE: "furnace.actions" "Furnace actions"
+"The " { $vocab-link "furnace.actions" } " vocabulary implements a type of responder, called an " { $emphasis "action" } ", which handles the form validation lifecycle."
+$nl
+"Other than form validation capability, actions are also often simpler to use than implementing new responders directly, since creating a new class is not required, and the action dispatches on the request type (GET, HEAD, or POST)."
+$nl
+"The class of actions:"
+{ $subsection action }
+"Creating a new action:"
+{ $subsection <action> }
+"Once created, an action needs to be configured; typically the creation and configuration of an action is encapsulated into a single word:"
+{ $subsection "furnace.actions.config" }
+"Validating forms with actions:"
+{ $subsection "furnace.actions.validation" }
+"More about the form validation lifecycle:"
+{ $subsection "furnace.actions.lifecycle" }
+"A convenience class:"
+{ $subsection "furnace.actions.page" }
+"Low-level features:"
+{ $subsection "furnace.actions.impl" } ;
+
+ABOUT: "furnace.actions"
\r
SYMBOL: rest\r
\r
-: render-validation-messages ( -- )\r
- form get errors>>\r
- [\r
- <ul "errors" =class ul>\r
- [ <li> escape-string write </li> ] each\r
- </ul>\r
- ] unless-empty ;\r
-\r
-CHLOE: validation-messages\r
- drop [ render-validation-messages ] [code] ;\r
-\r
-TUPLE: action rest authorize init display validate submit ;\r
+TUPLE: action rest init authorize display validate submit ;\r
\r
: new-action ( class -- action )\r
new [ ] >>init [ ] >>validate [ ] >>authorize ; inline\r
--- /dev/null
+IN: furnace.alloy
+USING: help.markup help.syntax db multiline ;
+
+HELP: init-furnace-tables
+{ $description "Initializes database tables used by asides, conversations and session management. This word must be invoked inside a " { $link with-db } " scope." } ;
+
+HELP: <alloy>
+{ $values { "responder" "a responder" } { "db" db } { "responder'" "an alloy responder" } }
+{ $description "Wraps the responder with support for asides, conversations, sessions and database persistence." }
+{ $examples
+ "The " { $vocab-link "webapps.counter" } " vocabulary uses an alloy to configure the counter:"
+ { $code
+ <" : counter-db ( -- db ) "counter.db" <sqlite-db> ;
+
+: run-counter ( -- )
+ <counter-app>
+ counter-db <alloy>
+ main-responder set-global
+ 8080 httpd ;">
+ }
+} ;
+
+HELP: start-expiring
+{ $values { "db" db } }
+{ $description "Starts a timer which expires old session state from the given database." } ;
+
+ARTICLE: "furnace.alloy" "Furnace alloy responder"
+"The " { $vocab-link "furnace.alloy" } " vocabulary implements a convenience responder which combines several Furnace features into one easy-to-use wrapper:"
+{ $list
+ { $link "furnace.asides" }
+ { $link "furnace.conversations" }
+ { $link "furnace.sessions" }
+ { $link "furnace.db" }
+}
+"A word to wrap a responder in an alloy:"
+{ $subsection <alloy> }
+"Initializing database tables for asides, conversations and sessions:"
+{ $subsection init-furnace-tables }
+"Start a timer to expire asides, conversations and sessions:"
+{ $subsection start-expiring } ;
+
+ABOUT: "furnace.alloy"
--- /dev/null
+USING: help.markup help.syntax io.streams.string urls
+furnace.redirection http furnace.sessions furnace.db ;
+IN: furnace.asides
+
+HELP: <asides>
+{ $values
+ { "responder" "a responder" }
+ { "responder'" asides }
+}
+{ $description "Creates a new " { $link asides } " responder wrapping an existing responder." } ;
+
+HELP: begin-aside
+{ $values { "url" url } }
+{ $description "Begins an aside. When the current action returns a " { $link <redirect> } ", the redirect will have query parameters which reference the current page via an opaque handle." } ;
+
+HELP: end-aside
+{ $values { "default" url } { "response" response } }
+{ $description "Ends an aside. If an aside is currently active, the response redirects the client " } ;
+
+ARTICLE: "furnace.asides" "Furnace asides"
+"The " { $vocab-link "furnace.asides" } " vocabulary provides support for sending a user to a page which can then return to the former location."
+$nl
+"To use asides, wrap your responder in an aside responder:"
+{ $subsection <asides> }
+"The aside responder must be wrapped inside a session responder (" { $link <sessions> } "), which in turn must be wrapped inside a database persistence responder (" { $link <db-persistence> } "). The " { $vocab-link "furnace.alloy" } " vocabulary combines all of these responders into one."
+$nl
+"Saving the current page in an aside which propagates through " { $link <redirect> } " responses:"
+{ $subsection begin-aside }
+"Returning from an aside:"
+{ $subsection end-aside }
+"Asides are used by " { $vocab-link "furnace.auth.login" } "; when the client requests a protected page, an aside begins and the client is redirected to a login page. Upon a successful login, the aside ends and the client returns to the protected page. If the client directly visits the login page and logs in, there is no current aside, so the client is sent to the default URL passed to " { $link end-aside } ", which in the case of login is the root URL." ;
+
+ABOUT: "furnace.asides"
<p>
<button>Update</button>
- <t:validation-messages />
+ <t:validation-errors />
</p>
</t:form>
<p>
<button>Set password</button>
- <t:validation-messages />
+ <t:validation-errors />
</p>
</t:form>
<p>
<button>Register</button>
- <t:validation-messages />
+ <t:validation-errors />
</p>
<p>
<button>Log in</button>
- <t:validation-messages />
+ <t:validation-errors />
</p>
--- /dev/null
+! Copyright (C) 2008 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string ;
+IN: furnace.boilerplate
+
+HELP: <boilerplate>
+{ $values
+ { "responder" null }
+ { "boilerplate" null }
+}
+{ $description "" } ;
+
+HELP: boilerplate
+{ $description "" } ;
+
+HELP: wrap-boilerplate?
+{ $values
+ { "response" null }
+ { "?" "a boolean" }
+}
+{ $description "" } ;
+
+ARTICLE: "furnace.boilerplate" "Furnace boilerplate support"
+{ $vocab-link "furnace.boilerplate" }
+;
+
+ABOUT: "furnace.boilerplate"
--- /dev/null
+USING: help.markup help.syntax ;
+IN: furnace.conversations
+
+ARTICLE: "furnace.conversations" "Furnace conversation scope"
+
+;
--- /dev/null
+USING: help.markup help.syntax db http.server ;
+IN: furnace.db
+
+HELP: <db-persistence>
+{ $values
+ { "responder" "a responder" } { "db" db }
+ { "responder'" db-persistence }
+}
+{ $description "Wraps a responder with database persistence support. The responder's " { $link call-responder* } " method will run in a " { $link with-db } " scope." } ;
+
+ARTICLE: "furnace.db" "Furnace database support"
+"The " { $vocab-link "furnace.db" } " vocabulary implements a responder which maintains a database connection pool and runs each request in a " { $link with-db } " scope."
+{ $subsection <db-persistence> }
+"The " { $vocab-link "furnace.alloy" } " vocabulary combines database persistence with several other features." ;
+
+ABOUT: "furnace.db"
--- /dev/null
+USING: assocs help.markup help.syntax io.streams.string quotations sequences strings urls ;
+IN: furnace
+
+HELP: adjust-redirect-url
+{ $values
+ { "url" url }
+ { "url'" url }
+}
+{ $description "" } ;
+
+HELP: adjust-url
+{ $values
+ { "url" url }
+ { "url'" url }
+}
+{ $description "" } ;
+
+HELP: base-path
+{ $values
+ { "string" string }
+ { "pair" null }
+}
+{ $description "" } ;
+
+HELP: client-state
+{ $values
+ { "key" null }
+ { "value/f" null }
+}
+{ $description "" } ;
+
+HELP: cookie-client-state
+{ $values
+ { "key" null } { "request" null }
+ { "value/f" null }
+}
+{ $description "" } ;
+
+HELP: each-responder
+{ $values
+ { "quot" quotation }
+}
+{ $description "" } ;
+
+HELP: exit-continuation
+{ $description "" } ;
+
+HELP: exit-with
+{ $values
+ { "value" null }
+}
+{ $description "" } ;
+
+HELP: hidden-form-field
+{ $values
+ { "value" null } { "name" null }
+}
+{ $description "" } ;
+
+HELP: link-attr
+{ $values
+ { "tag" null } { "responder" null }
+}
+{ $description "" } ;
+
+HELP: modify-form
+{ $values
+ { "responder" null }
+}
+{ $description "" } ;
+
+HELP: modify-query
+{ $values
+ { "query" null } { "responder" null }
+ { "query'" null }
+}
+{ $description "" } ;
+
+HELP: modify-redirect-query
+{ $values
+ { "query" null } { "responder" null }
+ { "query'" null }
+}
+{ $description "" } ;
+
+HELP: nested-forms-key
+{ $description "" } ;
+
+HELP: nested-responders
+{ $values
+
+ { "seq" sequence }
+}
+{ $description "" } ;
+
+HELP: post-client-state
+{ $values
+ { "key" null } { "request" null }
+ { "value/f" null }
+}
+{ $description "" } ;
+
+HELP: referrer
+{ $values
+
+ { "referrer/f" null }
+}
+{ $description "" } ;
+
+HELP: request-params
+{ $values
+ { "request" null }
+ { "assoc" assoc }
+}
+{ $description "" } ;
+
+HELP: resolve-base-path
+{ $values
+ { "string" string }
+ { "string'" string }
+}
+{ $description "" } ;
+
+HELP: resolve-template-path
+{ $values
+ { "pair" null }
+ { "path" "a pathname string" }
+}
+{ $description "" } ;
+
+HELP: same-host?
+{ $values
+ { "url" url }
+ { "?" "a boolean" }
+}
+{ $description "" } ;
+
+HELP: user-agent
+{ $values
+
+ { "user-agent" null }
+}
+{ $description "" } ;
+
+HELP: vocab-path
+{ $values
+ { "vocab" "a vocabulary specifier" }
+ { "path" "a pathname string" }
+}
+{ $description "" } ;
+
+HELP: with-exit-continuation
+{ $values
+ { "quot" quotation }
+}
+{ $description "" } ;
+
+ARTICLE: "furnace" "Furnace web framework"
+"The " { $vocab-link "furnace" } " vocabulary implements a full-featured web framework on top of the " { $link "http.server" } ". Some of its features include:"
+{ $list
+ "Session management capable of load-balancing and fail-over"
+ "Form components and validation"
+ "Authentication system with basic authentication or login pages, and pluggable authentication backends"
+ "Easy Atom feed syndication"
+ "Conversation scope and asides for complex page flow"
+}
+"Major functionality:"
+{ $subsection "furnace.actions" }
+{ $subsection "furnace.syndication" }
+{ $subsection "furnace.boilerplate" }
+{ $subsection "furnace.db" }
+"Server-side state:"
+{ $subsection "furnace.sessions" }
+{ $subsection "furnace.conversations" }
+{ $subsection "furnace.asides" }
+"HTML components:"
+{ $subsection "html.components" }
+{ $subsection "html.forms" }
+"Content templates:"
+{ $subsection "html.templates" }
+{ $subsection "html.templates.chloe" }
+{ $subsection "html.templates.fhtml" }
+"Utilities:"
+{ $subsection "furnace.alloy" }
+{ $subsection "furnace.json" }
+{ $subsection "furnace.redirection" }
+{ $subsection "furnace.referrer" } ;
+
+ABOUT: "furnace"
: with-exit-continuation ( quot -- )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
+USE: vocabs.loader
+"furnace.actions" require
+"furnace.alloy" require
+"furnace.asides" require
+"furnace.auth" require
+"furnace.auth.basic" require
+"furnace.auth.features.deactivate-user" require
+"furnace.auth.features.edit-profile" require
+"furnace.auth.features.recover-password" require
+"furnace.auth.features.registration" require
+"furnace.auth.login" require
+"furnace.auth.providers.assoc" require
+"furnace.auth.providers.db" require
+"furnace.auth.providers.null" require
+"furnace.boilerplate" require
"furnace.chloe-tags" require
+"furnace.conversations" require
+"furnace.db" require
+"furnace.json" require
+"furnace.redirection" require
+"furnace.referrer" require
+"furnace.scopes" require
+"furnace.sessions" require
+"furnace.syndication" require
--- /dev/null
+USING: kernel http.server help.markup help.syntax http ;
+IN: furnace.json
+
+HELP: <json-content>
+{ $values { "body" object } { "response" response } }
+{ $description "Creates an HTTP response which serves a serialized JSON object to the client." } ;
+
+ARTICLE: "furnace.json" "Furnace JSON support"
+"The " { $vocab-link "furnace.json" } " vocabulary provides a utility word for serving HTTP responses with JSON content."
+{ $subsection <json-content> } ;
+
+ABOUT: "furnace.json"
--- /dev/null
+USING: help.markup help.syntax io.streams.string quotations urls
+http.server http ;
+IN: furnace.redirection
+
+HELP: <redirect-responder>
+{ $values { "url" url } { "responder" "a responder" } }
+{ $description "Creates a responder which unconditionally redirects the client to the given URL." } ;
+
+HELP: <redirect>
+{ $values { "url" url } { "response" response } }
+{ $description "Creates a response which redirects the client to the given URL." } ;
+
+HELP: <secure-only> ( responder -- responder' )
+{ $values { "responder" "a responder" } { "responder'" "a responder" } }
+{ $description "Creates a new responder which ensures that the client is connecting via HTTPS before delegating to the underlying responder. If the client is connecting via HTTP, a redirect is sent instead." } ;
+
+HELP: <secure-redirect>
+{ $values
+ { "url" url }
+ { "response" response }
+}
+{ $description "Creates a responder which unconditionally redirects the client to the given URL after setting its protocol to HTTPS." }
+{ $notes "This word is intended to be used with a relative URL. The client is redirected to the relative URL, but with HTTPS instead of HTTP." } ;
+
+HELP: >secure-url
+{ $values
+ { "url" url }
+ { "url'" url }
+}
+{ $description "Sets the protocol of a URL to HTTPS." } ;
+
+HELP: if-secure
+{ $values
+ { "quot" quotation }
+ { "response" response }
+}
+{ $description "Runs a quotation if the current request was made over HTTPS, otherwise returns a redirect to have the client request the current page again via HTTPS." } ;
+
+ARTICLE: "furnace.redirection.secure" "Secure redirection"
+"The words in this section help with implementing sites which require SSL/TLS for additional security."
+$nl
+"Converting a HTTP URL into an HTTPS URL:"
+{ $subsection >secure-url }
+"Redirecting the client to an HTTPS URL:"
+{ $subsection <secure-redirect> }
+"Tools for writing responders which require SSL/TLS connections:"
+{ $subsection if-secure }
+{ $subsection <secure-only> } ;
+
+ARTICLE: "furnace.redirection" "Furnace redirection support"
+"The " { $vocab-link "furnace.redirection" } " vocabulary builds additional functionality on top of " { $vocab-link "http.server.redirection" } ", and integrates with various Furnace features such as " { $link "furnace.asides" } " and " { $link "furnace.conversations" } "."
+$nl
+"A redirection response which takes asides and conversations into account:"
+{ $subsection <redirect> }
+"A responder which unconditionally redirects the client to another URL:"
+{ $subsection <redirect-responder> }
+{ $subsection "furnace.redirection.secure" } ;
+
+ABOUT: "furnace.redirection"
--- /dev/null
+USING: help.markup help.syntax io.streams.string ;
+IN: furnace.referrer
+
+HELP: <check-form-submissions>
+{ $values
+ { "responder" "a responder" }
+ { "responder'" "a responder" }
+}
+{ $description "Wraps the responder in a filter responder which ensures that form submissions originate from a page on the same server. Any submissions which do not are sent back with a 403 error." } ;
+
+ARTICLE: "furnace.referrer" "Form submission referrer checking"
+"The " { $vocab-link "furnace.referrer" } " implements a simple security measure which can be used to thwart cross-site scripting attacks."
+{ $subsection <check-form-submissions> } ;
+
+ABOUT: "furnace.referrer"
--- /dev/null
+! Copyright (C) 2008 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string quotations strings ;
+IN: furnace.sessions
+
+HELP: <session-cookie>
+{ $values
+
+ { "cookie" null }
+}
+{ $description "" } ;
+
+HELP: <session>
+{ $values
+ { "id" null }
+ { "session" null }
+}
+{ $description "" } ;
+
+HELP: <sessions>
+{ $values
+ { "responder" null }
+ { "responder'" null }
+}
+{ $description "" } ;
+
+HELP: begin-session
+{ $values
+
+ { "session" null }
+}
+{ $description "" } ;
+
+HELP: check-session
+{ $values
+ { "state/f" null }
+ { "state/f" null }
+}
+{ $description "" } ;
+
+HELP: empty-session
+{ $values
+
+ { "session" null }
+}
+{ $description "" } ;
+
+HELP: existing-session
+{ $values
+ { "path" "a pathname string" } { "session" null }
+ { "response" null }
+}
+{ $description "" } ;
+
+HELP: get-session
+{ $values
+ { "id" null }
+ { "session" null }
+}
+{ $description "" } ;
+
+HELP: init-session
+{ $values
+ { "session" null }
+}
+{ $description "" } ;
+
+HELP: init-session*
+{ $values
+ { "responder" null }
+}
+{ $description "" } ;
+
+HELP: put-session-cookie
+{ $values
+ { "response" null }
+ { "response'" null }
+}
+{ $description "" } ;
+
+HELP: remote-host
+{ $values
+
+ { "string" string }
+}
+{ $description "" } ;
+
+HELP: request-session
+{ $values
+
+ { "session/f" null }
+}
+{ $description "" } ;
+
+HELP: save-session-after
+{ $values
+ { "session" null }
+}
+{ $description "" } ;
+
+HELP: schange
+{ $values
+ { "key" null } { "quot" quotation }
+}
+{ $description "" } ;
+
+HELP: session
+{ $description "" } ;
+
+HELP: session-changed
+{ $description "" } ;
+
+HELP: session-id-key
+{ $description "" } ;
+
+HELP: sessions
+{ $description "" } ;
+
+HELP: sget
+{ $values
+ { "key" null }
+ { "value" null }
+}
+{ $description "" } ;
+
+HELP: sset
+{ $values
+ { "value" null } { "key" null }
+}
+{ $description "" } ;
+
+HELP: touch-session
+{ $values
+ { "session" null }
+}
+{ $description "" } ;
+
+HELP: verify-session
+{ $values
+ { "session" null }
+ { "session" null }
+}
+{ $description "" } ;
+
+ARTICLE: "furnace.sessions" "Furnace sessions"
+{ $vocab-link "furnace.sessions" }
+;
+
+ABOUT: "furnace.sessions"
--- /dev/null
+! Copyright (C) 2008 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string kernel sequences strings urls ;
+IN: furnace.syndication
+
+HELP: <feed-action>
+{ $values
+
+ { "action" null }
+}
+{ $description "" } ;
+
+HELP: <feed-content>
+{ $values
+ { "body" null }
+ { "response" null }
+}
+{ $description "" } ;
+
+HELP: >entry
+{ $values
+ { "object" object }
+ { "entry" null }
+}
+{ $description "" } ;
+
+HELP: feed-action
+{ $description "" } ;
+
+HELP: feed-entry-date
+{ $values
+ { "object" object }
+ { "timestamp" null }
+}
+{ $description "" } ;
+
+HELP: feed-entry-description
+{ $values
+ { "object" object }
+ { "description" null }
+}
+{ $description "" } ;
+
+HELP: feed-entry-title
+{ $values
+ { "object" object }
+ { "string" string }
+}
+{ $description "" } ;
+
+HELP: feed-entry-url
+{ $values
+ { "object" object }
+ { "url" url }
+}
+{ $description "" } ;
+
+HELP: process-entries
+{ $values
+ { "seq" sequence }
+ { "seq'" sequence }
+}
+{ $description "" } ;
+
+ARTICLE: "furnace.syndication" "Furnace Atom syndication support"
+{ $vocab-link "furnace.syndication" }
+;
+
+ABOUT: "furnace.syndication"
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax sequences strings ;
+IN: grouping
+
+ARTICLE: "grouping" "Groups and clumps"
+"Splitting a sequence into disjoint, fixed-length subsequences:"
+{ $subsection group }
+"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
+{ $subsection groups }
+{ $subsection <groups> }
+{ $subsection <sliced-groups> }
+"Splitting a sequence into overlapping, fixed-length subsequences:"
+{ $subsection clump }
+"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
+{ $subsection clumps }
+{ $subsection <clumps> }
+{ $subsection <sliced-clumps> }
+"The difference can be summarized as the following:"
+{ $list
+ { "With groups, the subsequences form the original sequence when concatenated:"
+ { $unchecked-example "dup n groups concat sequence= ." "t" }
+ }
+ { "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
+ { $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" }
+ }
+} ;
+
+ABOUT: "grouping"
+
+HELP: groups
+{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+$nl
+"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
+{ $see-also group } ;
+
+HELP: group
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
+{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." }
+{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." }
+{ $examples
+ { $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
+} ;
+
+HELP: <groups>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
+{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
+{ $examples
+ { $example
+ "USING: arrays kernel prettyprint sequences grouping ;"
+ "9 >array 3 <groups> dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
+ }
+} ;
+
+HELP: <sliced-groups>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
+{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
+{ $examples
+ { $example
+ "USING: arrays kernel prettyprint sequences grouping ;"
+ "9 >array 3 <sliced-groups>"
+ "dup [ reverse-here ] each concat >array ."
+ "{ 2 1 0 5 4 3 8 7 6 }"
+ }
+} ;
+
+HELP: clumps
+{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+$nl
+"New clumps are created by calling " { $link <clumps> } " and " { $link <sliced-clumps> } "." } ;
+
+HELP: clump
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
+{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." }
+{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
+{ $examples
+ { $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
+} ;
+
+HELP: <clumps>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
+{ $examples
+ "Running averages:"
+ { $example
+ "USING: grouping sequences math prettyprint kernel ;"
+ "IN: scratchpad"
+ ": share-price"
+ " { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;"
+ ""
+ "share-price 4 <clumps> [ [ sum ] [ length ] bi / ] map ."
+ "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"
+ }
+} ;
+
+HELP: <sliced-clumps>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ;
+
+{ clumps groups } related-words
+
+{ clump group } related-words
+
+{ <clumps> <groups> } related-words
+
+{ <sliced-clumps> <sliced-groups> } related-words
--- /dev/null
+USING: grouping tools.test kernel sequences arrays ;
+IN: grouping.tests
+
+[ { 1 2 3 } 0 group ] must-fail
+
+[ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test
+
+[ { V{ "a" "b" } V{ f f } } ] [
+ V{ "a" "b" } clone 2 <groups>
+ 2 over set-length
+ >array
+] unit-test
+
+[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.order strings arrays vectors sequences
+sequences.private accessors ;
+IN: grouping
+
+<PRIVATE
+
+TUPLE: chunking-seq { seq read-only } { n read-only } ;
+
+: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
+
+: new-groups ( seq n class -- groups )
+ >r check-groups r> boa ; inline
+
+GENERIC: group@ ( n groups -- from to seq )
+
+M: chunking-seq set-nth group@ <slice> 0 swap copy ;
+
+M: chunking-seq like drop { } like ;
+
+INSTANCE: chunking-seq 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
+
+INSTANCE: groups subseq-chunking
+
+TUPLE: sliced-groups < abstract-groups ;
+
+: <sliced-groups> ( seq n -- groups )
+ sliced-groups new-groups ; inline
+
+INSTANCE: sliced-groups slice-chunking
+
+TUPLE: clumps < abstract-clumps ;
+
+: <clumps> ( seq n -- clumps )
+ clumps new-groups ; inline
+
+INSTANCE: clumps subseq-chunking
+
+TUPLE: sliced-clumps < abstract-clumps ;
+
+: <sliced-clumps> ( seq n -- clumps )
+ sliced-clumps new-groups ; inline
+
+INSTANCE: sliced-clumps slice-chunking
+
+: group ( seq n -- array ) <groups> { } like ;
+
+: clump ( seq n -- array ) <clumps> { } like ;
--- /dev/null
+Grouping sequence elements into subsequences
--- /dev/null
+collections
: data-set-nth ( entry n heap -- )
>r [ >>index drop ] 2keep r>
- data>> set-nth-unsafe ;
+ data>> set-nth-unsafe ; inline
: data-push ( entry heap -- n )
dup heap-size [
{ $heading "Encodings" }
{ $subsection "encodings-introduction" }
{ $subsection "io.encodings" }
-"Wrapper streams:"
+{ $heading "Wrapper streams" }
{ $subsection "io.streams.duplex" }
{ $subsection "io.streams.plain" }
{ $subsection "io.streams.string" }
{ $subsection "io.streams.byte-array" }
-"Utilities:"
+{ $heading "Utilities" }
{ $subsection "stream-binary" }
{ $subsection "styles" }
{ $subsection "checksums" }
-"Implementation:"
+{ $heading "Implementation" }
{ $subsection "io.streams.c" }
{ $subsection "io.ports" }
{ $see-also "destructors" } ;
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"
$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"
{ $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
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" }
{ $values { "assoc" assoc } { "validators" "an assoc mapping value names to quotations" } }
{ $description "Validates values in the assoc by looking up the corresponding validation quotation, and storing the results in named values of the current form." } ;
+HELP: validation-error
+{ $values { "message" string } }
+{ $description "Reports a validation error not associated with a specific form field." }
+{ $notes "Such errors can be rendered by calling the " { $link render-validation-errors } " word." } ;
+
+HELP: render-validation-errors
+{ $description "Renders any validation errors reported by calls to the " { $link validation-error } " word." } ;
+
ARTICLE: "html.forms.forms" "HTML form infrastructure"
"The below words are used to implement the " { $vocab-link "furnace.actions" } " vocabulary. Calling them directly is rarely necessary."
$nl
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors strings namespaces assocs hashtables
-mirrors math fry sequences words continuations ;
+USING: kernel accessors strings namespaces assocs hashtables io
+mirrors math fry sequences words continuations html.elements
+xml.entities ;
IN: html.forms
TUPLE: form errors values validation-failed ;
: validate-values ( assoc validators -- )
swap '[ [ dup _ at ] dip validate-value ] assoc-each ;
+
+: render-validation-errors ( -- )
+ form get errors>>
+ [
+ <ul "errors" =class ul>
+ [ <li> escape-string write </li> ] each
+ </ul>
+ ] unless-empty ;
"</t:button>"
}
} }
+ { { $snippet "t:validation-errors" } {
+ "Renders validation errors in the current form which are not associated with any field. Such errors are reported by invoking " { $link validation-error } "."
+ } }
} ;
ARTICLE: "html.templates.chloe.tags" "Standard Chloe tags"
CHLOE: call-next-template
drop reset-buffer \ call-next-template , ;
+CHLOE: validation-errors
+ drop [ render-validation-errors ] [code] ;
+
: attr>word ( value -- word/f )
":" split1 swap lookup ;
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 } ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string strings ;
+IN: io.files.listing
+
+HELP: directory.
+{ $values
+ { "path" "a pathname string" }
+}
+{ $description "Prints information about all files in a directory to the output stream in a cross-platform way similar to the Unix " { $snippet "ls" } " command." } ;
+
+ARTICLE: "io.files.listing" "Listing files"
+"The " { $vocab-link "io.files.listing" } " vocabulary implements directory file listing in a cross-platform way." $nl
+"Listing a directory:"
+{ $subsection directory. } ;
+
+ABOUT: "io.files.listing"
--- /dev/null
+! Copyright (C) 2008 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test io.files.listing strings kernel ;
+IN: io.files.listing.tests
+
+[ ] [ "" directory. ] unit-test
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators io io.files kernel
+math.parser sequences system vocabs.loader calendar ;
+
+IN: io.files.listing
+
+<PRIVATE
+
+: ls-time ( timestamp -- string )
+ [ hour>> ] [ minute>> ] bi
+ [ number>string 2 CHAR: 0 pad-left ] bi@ ":" swap 3append ;
+
+: ls-timestamp ( timestamp -- string )
+ [ month>> month-abbreviation ]
+ [ day>> number>string 2 CHAR: \s pad-left ]
+ [
+ dup year>> dup now year>> =
+ [ drop ls-time ] [ nip number>string ] if
+ 5 CHAR: \s pad-left
+ ] tri 3array " " join ;
+
+: read>string ( ? -- string ) "r" "-" ? ; inline
+
+: write>string ( ? -- string ) "w" "-" ? ; inline
+
+: execute>string ( ? -- string ) "x" "-" ? ; inline
+
+HOOK: (directory.) os ( path -- lines )
+
+PRIVATE>
+
+: directory. ( path -- )
+ [ (directory.) ] with-directory-files [ print ] each ;
+
+{
+ { [ os unix? ] [ "io.files.listing.unix" ] }
+ { [ os windows? ] [ "io.files.listing.windows" ] }
+} cond require
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators kernel system unicode.case
+io.unix.files io.files.listing generalizations strings
+arrays sequences io.files math.parser unix.groups unix.users
+io.files.listing.private ;
+IN: io.files.listing.unix
+
+<PRIVATE
+
+: unix-execute>string ( str bools -- str' )
+ swap {
+ { { t t } [ >lower ] }
+ { { t f } [ >upper ] }
+ { { f t } [ drop "x" ] }
+ [ 2drop "-" ]
+ } case ;
+
+: permissions-string ( permissions -- str )
+ {
+ [ type>> file-type>ch 1string ]
+ [ user-read? read>string ]
+ [ user-write? write>string ]
+ [ [ uid? ] [ user-execute? ] bi 2array "s" unix-execute>string ]
+ [ group-read? read>string ]
+ [ group-write? write>string ]
+ [ [ gid? ] [ group-execute? ] bi 2array "s" unix-execute>string ]
+ [ other-read? read>string ]
+ [ other-write? write>string ]
+ [ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
+ } cleave 10 narray concat ;
+
+M: unix (directory.) ( path -- lines )
+ [ [
+ [
+ dup file-info
+ {
+ [ permissions-string ]
+ [ nlink>> number>string 3 CHAR: \s pad-left ]
+ ! [ uid>> ]
+ ! [ gid>> ]
+ [ size>> number>string 15 CHAR: \s pad-left ]
+ [ modified>> ls-timestamp ]
+ } cleave 4 narray swap suffix " " join
+ ] map
+ ] with-group-cache ] with-user-cache ;
+
+PRIVATE>
--- /dev/null
+Doug Coleman
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar.format combinators io.files
+kernel math.parser sequences splitting system io.files.listing
+generalizations io.files.listing.private ;
+IN: io.files.listing.windows
+
+<PRIVATE
+
+: directory-or-size ( file-info -- str )
+ dup directory? [
+ drop "<DIR>" 20 CHAR: \s pad-right
+ ] [
+ size>> number>string 20 CHAR: \s pad-left
+ ] if ;
+
+M: windows (directory.) ( entries -- lines )
+ [
+ dup file-info {
+ [ modified>> timestamp>ymdhms ]
+ [ directory-or-size ]
+ } cleave 2 narray swap suffix " " join
+ ] map ;
+
+PRIVATE>
$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* }
PRIVATE>
+: ch>file-type ( ch -- type )
+ {
+ { CHAR: b [ +block-device+ ] }
+ { CHAR: c [ +character-device+ ] }
+ { CHAR: d [ +directory+ ] }
+ { CHAR: l [ +symbolic-link+ ] }
+ { CHAR: s [ +socket+ ] }
+ { CHAR: p [ +fifo+ ] }
+ { CHAR: - [ +regular-file+ ] }
+ [ drop +unknown+ ]
+ } case ;
+
+: file-type>ch ( type -- string )
+ {
+ { +block-device+ [ CHAR: b ] }
+ { +character-device+ [ CHAR: c ] }
+ { +directory+ [ CHAR: d ] }
+ { +symbolic-link+ [ CHAR: l ] }
+ { +socket+ [ CHAR: s ] }
+ { +fifo+ [ CHAR: p ] }
+ { +regular-file+ [ CHAR: - ] }
+ [ drop CHAR: - ]
+ } case ;
+
: UID OCT: 0004000 ; inline
: GID OCT: 0002000 ; inline
: STICKY OCT: 0001000 ; inline
PEG: tokenize-command ( command -- ast/f )
'argument' " " token repeat1 list-of
- " " token repeat0 swap over pack
+ " " token repeat0 tuck pack
just ;
+sparse-file+ +reparse-point+ +compressed+ +offline+
+not-content-indexed+ +encrypted+ ;
-: win32-file-attribute ( n attr symbol -- n )
- >r dupd mask? r> swap [ , ] [ drop ] if ;
+TUPLE: windows-file-info < file-info attributes ;
+
+: win32-file-attribute ( n attr symbol -- )
+ rot mask? [ , ] [ drop ] if ;
: win32-file-attributes ( n -- seq )
[
- FILE_ATTRIBUTE_READONLY +read-only+ win32-file-attribute
- FILE_ATTRIBUTE_HIDDEN +hidden+ win32-file-attribute
- FILE_ATTRIBUTE_SYSTEM +system+ win32-file-attribute
- FILE_ATTRIBUTE_DIRECTORY +directory+ win32-file-attribute
- FILE_ATTRIBUTE_ARCHIVE +archive+ win32-file-attribute
- FILE_ATTRIBUTE_DEVICE +device+ win32-file-attribute
- FILE_ATTRIBUTE_NORMAL +normal+ win32-file-attribute
- FILE_ATTRIBUTE_TEMPORARY +temporary+ win32-file-attribute
- FILE_ATTRIBUTE_SPARSE_FILE +sparse-file+ win32-file-attribute
- FILE_ATTRIBUTE_REPARSE_POINT +reparse-point+ win32-file-attribute
- FILE_ATTRIBUTE_COMPRESSED +compressed+ win32-file-attribute
- FILE_ATTRIBUTE_OFFLINE +offline+ win32-file-attribute
- FILE_ATTRIBUTE_NOT_CONTENT_INDEXED +not-content-indexed+ win32-file-attribute
- FILE_ATTRIBUTE_ENCRYPTED +encrypted+ win32-file-attribute
- drop
+ {
+ [ +read-only+ FILE_ATTRIBUTE_READONLY win32-file-attribute ]
+ [ +hidden+ FILE_ATTRIBUTE_HIDDEN win32-file-attribute ]
+ [ +system+ FILE_ATTRIBUTE_SYSTEM win32-file-attribute ]
+ [ +directory+ FILE_ATTRIBUTE_DIRECTORY win32-file-attribute ]
+ [ +archive+ FILE_ATTRIBUTE_ARCHIVE win32-file-attribute ]
+ [ +device+ FILE_ATTRIBUTE_DEVICE win32-file-attribute ]
+ [ +normal+ FILE_ATTRIBUTE_NORMAL win32-file-attribute ]
+ [ +temporary+ FILE_ATTRIBUTE_TEMPORARY win32-file-attribute ]
+ [ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE win32-file-attribute ]
+ [ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT win32-file-attribute ]
+ [ +compressed+ FILE_ATTRIBUTE_COMPRESSED win32-file-attribute ]
+ [ +offline+ FILE_ATTRIBUTE_OFFLINE win32-file-attribute ]
+ [ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED win32-file-attribute ]
+ [ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED win32-file-attribute ]
+ } cleave
] { } make ;
: win32-file-type ( n -- symbol )
FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
- [ \ file-info new ] dip
+ [ \ windows-file-info new ] dip
{
[ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ]
+ [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes >>attributes ]
[
[ WIN32_FIND_DATA-nFileSizeLow ]
[ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size
] keep ;
: BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
- [ \ file-info new ] dip
+ [ \ windows-file-info new ] dip
{
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ]
+ [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes >>attributes ]
[
[ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
[ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size
swap >>type
swap >>mount-point ;
-: find-first-volume ( word -- string handle )
+: volume>paths ( string -- array )
+ 16384 "ushort" <c-array> tuck dup length
+ 0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
+ win32-error-string throw
+ ] [
+ *uint "ushort" heap-size * head
+ utf16n alien>string CHAR: \0 split
+ ] if ;
+
+: find-first-volume ( -- string handle )
MAX_PATH 1+ <byte-array> dup length
dupd
FindFirstVolume dup win32-error=0/f
[ utf16n alien>string ] dip ;
-: find-next-volume ( handle -- string )
+: find-next-volume ( handle -- string/f )
MAX_PATH 1+ <byte-array> dup length
- [ FindNextVolume win32-error=0/f ] 2keep drop
- utf16n alien>string ;
+ over [ FindNextVolume ] dip swap 0 = [
+ GetLastError ERROR_NO_MORE_FILES =
+ [ drop f ] [ win32-error ] if
+ ] [
+ utf16n alien>string
+ ] if ;
-: mounted ( -- array )
+: find-volumes ( -- array )
find-first-volume
[
'[
]
] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ;
+M: winnt file-systems ( -- array )
+ find-volumes [ volume>paths ] map
+ concat [
+ [ file-system-info ]
+ [ drop winnt-file-system-info new swap >>mount-point ] recover
+ ] map ;
+
: file-times ( path -- timestamp timestamp timestamp )
[
normalize-path open-existing &dispose handle>>
--- /dev/null
+Slava Pestov
+James Cash
--- /dev/null
+IN: linked-assocs
+USING: help.markup help.syntax assocs ;
+
+HELP: linked-assoc
+{ $class-description "The class of linked assocs. Linked assoc are implemented by combining an assoc with a dlist. The assoc is used for lookup and retrieval of single values, while the dlist is used for getting lists of keys/values, which will be in insertion order." } ;
+
+HELP: <linked-assoc>
+{ $values { "exemplar" "an exemplar assoc" } { "assoc" linked-assoc } }
+{ $description "Creates an empty linked assoc backed by a new instance of the same type as the exemplar." } ;
+
+HELP: <linked-hash>
+{ $values { "assoc" linked-assoc } }
+{ $description "Creates an empty linked assoc backed by a hashtable." } ;
+
+ARTICLE: "linked-assocs" "Linked assocs"
+"A " { $emphasis "linked assoc" } " is an assoc which combines an underlying assoc with a dlist to form a structure which has the insertion and retrieval characteristics of the underlying assoc (typically a hashtable), but with the ability to get the entries in insertion order by calling " { $link >alist } "."
+$nl
+"Linked assocs are implemented in the " { $vocab-link "linked-assocs" } " vocabulary."
+{ $subsection linked-assoc }
+{ $subsection <linked-hash> }
+{ $subsection <linked-assoc> } ;
+
+ABOUT: "linked-assocs"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences assocs tools.test linked-assocs math ;
+IN: linked-assocs.test
+
+{ { 1 2 3 } } [
+ <linked-hash> 1 "b" pick set-at
+ 2 "c" pick set-at
+ 3 "a" pick set-at
+ values
+] unit-test
+
+{ 2 t } [
+ <linked-hash> 1 "b" pick set-at
+ 2 "c" pick set-at
+ 3 "a" pick set-at
+ "c" swap at*
+] unit-test
+
+{ { 2 3 4 } { "c" "a" "d" } 3 } [
+ <linked-hash> 1 "a" pick set-at
+ 2 "c" pick set-at
+ 3 "a" pick set-at
+ 4 "d" pick set-at
+ [ values ] [ keys ] [ assoc-size ] tri
+] unit-test
+
+{ f 1 } [
+ <linked-hash> 1 "c" pick set-at
+ 2 "b" pick set-at
+ "c" over delete-at
+ "c" over at swap assoc-size
+] unit-test
+
+{ { } 0 } [
+ <linked-hash> 1 "a" pick set-at
+ 2 "c" pick set-at
+ 3 "a" pick set-at
+ 4 "d" pick set-at
+ dup clear-assoc [ keys ] [ assoc-size ] bi
+] unit-test
+
+{ { } { 1 2 3 } } [
+ <linked-hash> dup clone
+ 1 "c" pick set-at
+ 2 "q" pick set-at
+ 3 "a" pick set-at
+ [ values ] bi@
+] unit-test
+
+{ 9 } [
+ <linked-hash>
+ { [ 3 * ] [ 1- ] } "first" pick set-at
+ { [ [ 1- ] bi@ ] [ 2 / ] } "second" pick set-at
+ 4 6 pick values [ first call ] each
+ + swap values <reversed> [ second call ] each
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Slava Pestov, James Cash.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs arrays kernel deques dlists sequences fry ;
+IN: linked-assocs
+
+TUPLE: linked-assoc assoc dlist ;
+
+: <linked-assoc> ( exemplar -- assoc )
+ 0 swap new-assoc <dlist> linked-assoc boa ;
+
+: <linked-hash> ( -- assoc )
+ H{ } <linked-assoc> ;
+
+M: linked-assoc assoc-size assoc>> assoc-size ;
+
+M: linked-assoc at* assoc>> at* [ [ obj>> second ] when ] keep ;
+
+M: linked-assoc delete-at
+ [ [ assoc>> ] [ dlist>> ] bi [ at ] dip '[ _ delete-node ] when* ]
+ [ assoc>> delete-at ] 2bi ;
+
+<PRIVATE
+: add-to-dlist ( value key lassoc -- node )
+ [ swap 2array ] dip dlist>> push-back* ;
+PRIVATE>
+
+M: linked-assoc set-at
+ [ 2dup assoc>> key? [ 2dup delete-at ] when add-to-dlist ] 2keep
+ assoc>> set-at ;
+
+: dlist>seq ( dlist -- seq )
+ [ ] pusher [ dlist-each ] dip ;
+
+M: linked-assoc >alist
+ dlist>> dlist>seq ;
+
+M: linked-assoc clear-assoc
+ [ assoc>> clear-assoc ] [ dlist>> clear-deque ] bi ;
+
+M: linked-assoc clone
+ [ assoc>> clone ] [ dlist>> clone ] bi
+ linked-assoc boa ;
+
+INSTANCE: linked-assoc assoc
--- /dev/null
+Assocs that yield items in insertion order
USING: help.syntax help.markup kernel macros prettyprint
-memoize ;
+memoize combinators arrays ;
IN: locals
HELP: [|
{ 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
"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." ;
prettyprint.backend definitions prettyprint hashtables
prettyprint.sections sets sequences.private effects
effects.parser generic generic.parser compiler.units accessors
-locals.backend memoize macros.expander lexer classes
-stack-checker.known-words ;
+locals.backend memoize macros.expander lexer classes ;
IN: locals
! Inspired by
: <local> ( name -- word )
#! Create a local variable identifier
f <word>
- dup t "local?" set-word-prop
- dup { } { object } define-primitive ;
+ dup t "local?" set-word-prop ;
PREDICATE: local-word < word "local-word?" word-prop ;
: <local-reader> ( name -- word )
f <word>
- dup t "local-reader?" set-word-prop
- dup { } { object } define-primitive ;
+ dup t "local-reader?" set-word-prop ;
PREDICATE: local-writer < word "local-writer?" word-prop ;
: <local-writer> ( reader -- word )
dup name>> "!" append f <word> {
- [ nip { object } { } define-primitive ]
[ nip t "local-writer?" set-word-prop ]
[ swap "local-reader" set-word-prop ]
[ "local-writer" set-word-prop ]
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private namespaces make
quotations accessors words continuations vectors effects math
-generalizations stack-checker.transforms fry ;
+generalizations fry ;
IN: macros.expander
GENERIC: expand-macros ( quot -- quot' )
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser kernel sequences words effects
-stack-checker.transforms combinators assocs definitions
-quotations namespaces memoize accessors ;
+USING: parser kernel sequences words effects combinators assocs
+definitions quotations namespaces memoize accessors ;
IN: macros
: real-macro-effect ( word -- effect' )
"declared-effect" word-prop in>> 1 <effect> ;
: define-macro ( word definition -- )
- over "declared-effect" word-prop in>> length >r
- 2dup "macro" set-word-prop
- 2dup over real-macro-effect memoize-quot [ call ] append define
- r> define-transform ;
+ [ "macro" set-word-prop ]
+ [ over real-macro-effect memoize-quot [ call ] append define ]
+ 2bi ;
-: MACRO:
- (:) define-macro ; parsing
+: MACRO: (:) define-macro ; parsing
PREDICATE: macro < word "macro" word-prop >boolean ;
-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:"
{ $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"
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
\ foo must-infer
+
+[ 1 ] [ { 1 } flags ] unit-test
-! 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
! 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 ;
! flags
MACRO: flags ( values -- )
- [ 0 ] [ [ execute bitor ] curry compose ] reduce ;
+ [ 0 ] [ [ dup word? [ execute ] when bitor ] curry compose ] reduce ;
! bitfield
<PRIVATE
[ 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>
PRIVATE>
: bit-count ( x -- n )
- dup 0 >= [ (bit-count) ] [ bitnot (bit-count) ] if ; inline
+ dup 0 < [ bitnot ] when (bit-count) ; inline
[ -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
-! 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 )
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
: 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
: 0^ ( x -- z )
dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
+PRIVATE>
+
: ^ ( x y -- z )
{
{ [ over zero? ] [ nip 0^ ] }
[ 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
! 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 )
{
{ bitand interval-bitand }
{ bitor interval-bitor }
{ bitxor interval-bitxor }
- { shift interval-shift }
+ ! { shift interval-shift }
{ min interval-min }
{ max interval-max }
}
SYMBOL: empty-interval
+SYMBOL: full-interval
+
TUPLE: interval { from read-only } { to read-only } ;
: <interval> ( from to -- int )
: (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 [
: 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
: 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 ]
: 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 ;
: 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 -- ? )
: 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
: interval-length ( int -- n )
{
{ [ dup empty-interval eq? ] [ drop 0 ] }
+ { [ dup full-interval eq? ] [ drop 1/0. ] }
[ interval>points [ first ] bi@ swap - ]
} cond ;
[ [ 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 ;
: 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 ;
: 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 ] }
: 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 ]
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]
USING: help.markup help.syntax math math.private
-math.ratios.private ;
+math.ratios.private math.functions ;
IN: math.ratios
ARTICLE: "rationals" "Rational numbers"
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
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." } ;
{ $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 } }
{ $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 }
{ $subsection gl-line }
{ $subsection gl-fill-rect }
{ $subsection gl-rect }
-{ $subsection gl-fill-poly }
-{ $subsection gl-poly }
-{ $subsection gl-gradient }
;
ABOUT: "gl-utilities"
! 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@ ;
-
-: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
- [ first2 [ >fixnum ] bi@ ] bi@ ;
+: color>raw ( object -- r g b a )
+ >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline
-: gl-color ( color -- ) first4 glColor4d ; inline
+: gl-color ( color -- ) color>raw 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
: (all-enabled) ( seq quot -- )
over [ glEnable ] each dip [ glDisable ] each ; inline
+
: (all-enabled-client-state) ( seq quot -- )
[ dup [ glEnableClientState ] each ] dip
dip
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 ;
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 ;
: 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) ;
: gl-translate ( point -- ) first2 0.0 glTranslated ;
-<PRIVATE
-
-: 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
+MEMO: (rect-texture-coords) ( -- seq )
+ { 0 0 1 0 1 1 0 1 } >c-float-array ;
-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 [
: 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 ;
M: ebnf-foreign (transform) ( ast -- parser )\r
dup word>> search\r
[ "Foreign word '" swap word>> append "' not found" append throw ] unless*\r
- swap rule>> [ main ] unless* dupd swap rule [\r
+ swap rule>> [ main ] unless* over rule [\r
nip\r
] [\r
execute\r
M: persistent-hash pprint-delims drop \ PH{ \ } ;
M: persistent-hash >pprint-sequence >alist ;
M: persistent-hash pprint* pprint-object ;
+
+: passociate ( value key -- phash )
+ T{ persistent-hash } new-at ; inline
GENERIC: new-nth ( val i seq -- seq' )
M: sequence new-nth clone [ set-nth ] keep ;
+
+: changed-nth ( i seq quot -- seq' )
+ [ [ nth ] dip call ] [ drop new-nth ] 3bi ; inline
M: object pprint* pprint-object ;
M: vector pprint* pprint-object ;
+M: byte-vector pprint* pprint-object ;
M: hashtable pprint* pprint-object ;
M: curry pprint*
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"
{ $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" }
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 } }
{ $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." }
"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"
-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
! 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:
: expect=> ( -- ) scan "=>" assert= ;
-: partial-vocab ( words name -- assoc )
- dupd [
- lookup [ "No such word: " swap append throw ] unless*
- ] curry map zip ;
+: partial-vocab ( words vocab -- assoc )
+ '[ dup _ lookup [ no-word-error ] unless* ]
+ { } map>assoc ;
-: partial-vocab-ignoring ( words name -- 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-ignoring use get push ; parsing
-
-: FROM:
- #! Syntax: FROM: vocab => words... ;
- scan dup load-vocab drop expect=>
- ";" parse-tokens swap partial-vocab use get push ; parsing
+ ";" 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
: 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 )
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel math namespaces sequences
io.backend io.binary combinators system vocabs.loader
-summary math.bitwise ;
+summary math.bitwise byte-vectors fry byte-arrays ;
IN: random
SYMBOL: system-random-generator
GENERIC: random-bytes* ( n tuple -- byte-array )
M: object random-bytes* ( n tuple -- byte-array )
- [ random-32* ] curry replicate [ 4 >le ] map concat ;
+ [ [ <byte-vector> ] keep 4 /mod ] dip tuck
+ [ pick '[ _ random-32* 4 >le _ push-all ] times ]
+ [
+ over zero?
+ [ 2drop ] [ random-32* 4 >le swap head over push-all ] if
+ ] 2bi* ;
M: object random-32* ( tuple -- r ) 4 random-bytes* le> ;
M: f random-32* ( obj -- * ) no-random-number-generator ;
: random-bytes ( n -- byte-array )
- [
- dup 3 mask zero? [ 1+ ] unless
- random-generator get random-bytes*
- ] keep head ;
+ random-generator get random-bytes* ;
<PRIVATE
: random-integer ( n -- n' )
dup log2 7 + 8 /i 1+
- [ random-bytes byte-array>bignum ]
+ [ random-bytes >byte-array byte-array>bignum ]
[ 3 shift 2^ ] bi / * >integer ;
PRIVATE>
collections
text
+algorithms
--- /dev/null
+USING: stack-checker.backend tools.test kernel namespaces
+stack-checker.state sequences ;
+IN: stack-checker.backend.tests
+
+[ ] [
+ V{ } clone meta-d set
+ V{ } clone meta-r set
+ 0 d-in set
+] unit-test
+
+[ 0 ] [ 0 ensure-d length ] unit-test
+
+[ 2 ] [ 2 ensure-d length ] unit-test
+[ 2 ] [ meta-d get length ] unit-test
+
+[ 3 ] [ 3 ensure-d length ] unit-test
+[ 3 ] [ meta-d get length ] unit-test
+
+[ 1 ] [ 1 ensure-d length ] unit-test
+[ 3 ] [ meta-d get length ] unit-test
+
+[ ] [ 1 consume-d drop ] unit-test
quotations effects classes continuations debugger assocs
combinators compiler.errors accessors math.order definitions
sets generic.standard.engines.tuple stack-checker.state
-stack-checker.visitor stack-checker.errors ;
+stack-checker.visitor stack-checker.errors
+stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.backend
: push-d ( obj -- ) meta-d get push ;
: peek-d ( -- obj ) pop-d dup push-d ;
-: consume-d ( n -- seq ) [ pop-d ] replicate reverse ;
+: make-values ( n -- values )
+ [ <value> ] replicate ;
-: output-d ( values -- ) meta-d get push-all ;
+: ensure-d ( n -- values )
+ meta-d get 2dup length > [
+ 2dup
+ [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
+ [ length d-in +@ ] [ #introduce, ] [ meta-d get push-all ] tri
+ meta-d get push-all
+ ] when swap tail* ;
-: ensure-d ( n -- values ) consume-d dup output-d ;
+: shorten-by ( n seq -- )
+ [ length swap - ] keep shorten ; inline
-: make-values ( n -- values )
- [ <value> ] replicate ;
+: consume-d ( n -- seq )
+ [ ensure-d ] [ meta-d get shorten-by ] bi ;
+
+: output-d ( values -- ) meta-d get push-all ;
: produce-d ( n -- values )
make-values dup meta-d get push-all ;
meta-r get dup empty?
[ too-many-r> inference-error ] [ pop ] if ;
-: consume-r ( n -- seq ) [ pop-r ] replicate reverse ;
+: consume-r ( n -- seq )
+ meta-r get 2dup length >
+ [ too-many-r> inference-error ] when
+ [ swap tail* ] [ shorten-by ] 2bi ;
: output-r ( seq -- ) meta-r get push-all ;
infer-quot-here
] dip recursive-state set ;
-: infer-quot-recursive ( quot word label -- )
- 2array recursive-state get swap prefix infer-quot ;
-
: time-bomb ( error -- )
'[ _ throw ] infer-quot-here ;
] [
dup value>> callable? [
[ value>> ]
- [ [ recursion>> ] keep f 2array prefix ]
+ [ [ recursion>> ] keep add-local-quotation ]
bi infer-quot
] [
drop bad-call
terminated?>> [ terminate ] when
] 2bi ; inline
+: infer-word-def ( word -- )
+ [ def>> ] [ add-recursive-state ] bi infer-quot ;
+
: check->r ( -- )
meta-r get empty? terminated? get or
[ \ too-many->r inference-error ] unless ;
stack-visitor off
dependencies off
generic-dependencies off
- [ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ]
+ [ infer-word-def end-infer ]
[ finish-word current-effect ]
bi
] with-scope
USING: fry vectors sequences assocs math accessors kernel
combinators quotations namespaces stack-checker.state
stack-checker.backend stack-checker.errors stack-checker.visitor
-;
+stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.branches
: balanced? ( pairs -- ? )
! See http://factorcode.org/license.txt for BSD license.
USING: kernel generic sequences prettyprint io words arrays
summary effects debugger assocs accessors namespaces
-compiler.errors ;
+compiler.errors stack-checker.values
+stack-checker.recursive-state ;
IN: stack-checker.errors
-SYMBOL: recursive-state
-
-TUPLE: inference-error error type rstate ;
+TUPLE: inference-error error type word ;
M: inference-error compiler-error-type type>> ;
: (inference-error) ( ... class type -- * )
>r boa r>
- recursive-state get
+ recursive-state get word>>
\ inference-error boa throw ; inline
: inference-error ( ... class -- * )
+warning+ (inference-error) ; inline
M: inference-error error.
- [
- rstate>>
- [ "Nesting:" print stack. ] unless-empty
- ] [ error>> error. ] bi ;
+ [ "In word: " write word>> . ] [ error>> error. ] bi ;
TUPLE: literal-expected ;
M: literal-expected summary
drop "Literal value expected" ;
+M: object (literal) \ literal-expected inference-warning ;
+
TUPLE: unbalanced-branches-error branches quots ;
: unbalanced-branches-error ( branches quots -- * )
definitions math math.order effects classes arrays combinators
vectors arrays
stack-checker.state
+stack-checker.errors
+stack-checker.values
stack-checker.visitor
stack-checker.backend
stack-checker.branches
-stack-checker.errors
-stack-checker.known-words ;
+stack-checker.known-words
+stack-checker.recursive-state ;
IN: stack-checker.inlining
! Code to handle inline words. Much of the complexity stems from
! having to handle recursive inline words.
-: (inline-word) ( word label -- )
- [ [ def>> ] keep ] dip infer-quot-recursive ;
+: infer-inline-word-def ( word label -- )
+ [ drop def>> ] [ add-inline-word ] 2bi infer-quot ;
TUPLE: inline-recursive < identity-tuple
id
nest-visitor
dup <inline-recursive>
- [ dup emit-enter-recursive (inline-word) ]
+ [ dup emit-enter-recursive infer-inline-word-def ]
[ end-recursive-word ]
[ nip ]
2tri
object <repetition> '[ _ prepend ] bi@
<effect> ;
-: call-recursive-inline-word ( word -- )
- dup "recursive" word-prop [
- [ required-stack-effect adjust-stack-effect ] [ ] [ recursive-label ] tri
- [ 2nip check-call ] [ nip '[ _ #call-recursive, ] consume/produce ] 3bi
- ] [ undeclared-recursion-error inference-error ] if ;
+: call-recursive-inline-word ( word label -- )
+ over "recursive" word-prop [
+ [ required-stack-effect adjust-stack-effect ] dip
+ [ check-call ] [ '[ _ #call-recursive, ] consume/produce ] bi
+ ] [ drop undeclared-recursion-error inference-error ] if ;
: inline-word ( word -- )
[ inlined-dependency depends-on ]
[
- {
- { [ dup inline-recursive-label ] [ call-recursive-inline-word ] }
- { [ dup "recursive" word-prop ] [ inline-recursive-word ] }
- [ dup (inline-word) ]
- } cond
+ dup inline-recursive-label [
+ call-recursive-inline-word
+ ] [
+ dup "recursive" word-prop
+ [ inline-recursive-word ]
+ [ dup infer-inline-word-def ]
+ if
+ ] if*
] bi ;
M: word apply-object
strings.private system threads.private classes.tuple
classes.tuple.private vectors vectors.private words definitions
words.private assocs summary compiler.units system.private
-combinators locals.backend words.private quotations.private
+combinators locals locals.backend locals.private words.private
+quotations.private stack-checker.values
+stack-checker.alien
stack-checker.state
+stack-checker.errors
+stack-checker.visitor
stack-checker.backend
stack-checker.branches
-stack-checker.errors
stack-checker.transforms
-stack-checker.visitor
-stack-checker.alien ;
+stack-checker.recursive-state ;
IN: stack-checker.known-words
: infer-primitive ( word -- )
: infer-shuffle ( shuffle -- )
[ in>> length consume-d ] keep ! inputs shuffle
[ drop ] [ shuffle dup copy-values dup output-d ] 2bi ! inputs outputs copies
- [ nip ] [ swap zip ] 2bi ! inputs copies mapping
+ [ nip f f ] [ swap zip ] 2bi ! in-d out-d in-r out-r mapping
#shuffle, ;
: infer-shuffle-word ( word -- )
: infer-load-locals ( -- )
pop-literal nip
- [ dup reverse <effect> infer-shuffle ]
- [ infer->r ]
- bi ;
+ consume-d dup reverse copy-values dup output-r
+ [ [ f f ] dip ] [ reverse swap zip ] 2bi #shuffle, ;
: infer-get-local ( -- )
- pop-literal nip
- [ infer-r> ]
- [ dup 0 prefix <effect> infer-shuffle ]
- [ infer->r ]
- tri ;
+ [let* | n [ pop-literal nip ]
+ in-r [ n consume-r ]
+ out-d [ in-r first copy-value 1array ]
+ out-r [ in-r copy-values ] |
+ out-d output-d
+ out-r output-r
+ f out-d in-r out-r
+ out-r in-r zip out-d first in-r first 2array suffix
+ #shuffle,
+ ] ;
: infer-drop-locals ( -- )
- pop-literal nip
- [ infer-r> ]
- [ { } <effect> infer-shuffle ] bi ;
+ f f pop-literal nip consume-r f f #shuffle, ;
: infer-special ( word -- )
{
{ \ alien-callback [ infer-alien-callback ] }
} case ;
+: infer-local-reader ( word -- )
+ (( -- value )) apply-word/effect ;
+
+: infer-local-writer ( word -- )
+ (( value -- )) apply-word/effect ;
+
{
>r r> declare call (call) curry compose execute (execute) if
dispatch <tuple-boa> (throw) load-locals get-local drop-locals
{ [ dup "macro" word-prop ] [ apply-macro ] }
{ [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
- { [ dup recursive-label ] [ call-recursive-word ] }
+ { [ dup local? ] [ infer-local-reader ] }
+ { [ dup local-reader? ] [ infer-local-reader ] }
+ { [ dup local-writer? ] [ infer-local-writer ] }
+ { [ dup recursive-word? ] [ call-recursive-word ] }
[ dup infer-word apply-word/effect ]
} cond ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays sequences kernel sequences assocs
+namespaces stack-checker.recursive-state.tree ;
+IN: stack-checker.recursive-state
+
+TUPLE: recursive-state words word quotations inline-words ;
+
+C: <recursive-state> recursive-state
+
+: prepare-recursive-state ( word rstate -- rstate )
+ swap >>word
+ f >>quotations
+ f >>inline-words ; inline
+
+: initial-recursive-state ( word -- state )
+ recursive-state new
+ f >>words
+ prepare-recursive-state ; inline
+
+f initial-recursive-state recursive-state set-global
+
+: add-recursive-state ( word -- rstate )
+ recursive-state get clone
+ [ word>> dup ] keep [ store ] change-words
+ prepare-recursive-state ;
+
+: add-local-quotation ( recursive-state quot -- rstate )
+ swap clone [ dupd store ] change-quotations ;
+
+: add-inline-word ( word label -- rstate )
+ swap recursive-state get clone
+ [ store ] change-inline-words ;
+
+: recursive-word? ( word -- ? )
+ recursive-state get 2dup word>> eq?
+ [ 2drop t ] [ words>> lookup ] if ;
+
+: inline-recursive-label ( word -- label/f )
+ recursive-state get inline-words>> lookup ;
+
+: recursive-quotation? ( quot -- ? )
+ recursive-state get quotations>> lookup ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences math math.order ;
+IN: stack-checker.recursive-state.tree
+
+! Persistent unbalanced hash tree using eq? comparison.
+! We use this to speed up stack-checker.recursive-state.
+! Perhaps this should go somewhere else
+
+TUPLE: node value key hashcode left right ;
+
+GENERIC: lookup ( key node -- value/f )
+
+M: f lookup nip ;
+
+: decide ( key node -- key node ? )
+ over hashcode over hashcode>> <= ; inline
+
+M: node lookup
+ 2dup key>> eq?
+ [ nip value>> ]
+ [ decide [ left>> ] [ right>> ] if lookup ] if ;
+
+GENERIC: store ( value key node -- node' )
+
+M: f store drop dup hashcode f f node boa ;
+
+M: node store
+ clone decide
+ [ [ store ] change-left ]
+ [ [ store ] change-right ] if ;
"Consider a combinator such as " { $link keep } ". The combinator itself does not have a stack effect, because it applies " { $link call } " to a potentially arbitrary quotation. However, since the combinator is declared " { $link POSTPONE: inline } ", a given usage of it can have a stack effect:"
{ $example "[ [ 2 + ] keep ] infer." "( object -- object object )" }
"Another example is the " { $link compose } " combinator. Because it is decared " { $link POSTPONE: inline } ", we can infer the stack effect of applying " { $link call } " to the result of " { $link compose } ":"
-{ $example "[ 2 [ + ] curry [ sq ] compose ] infer." "( -- object object )" }
+{ $example "[ 2 [ + ] curry [ sq ] compose ] infer." "( -- object )" }
"Incidentally, this example demonstrates that the stack effect of nested currying and composition can also be inferred."
$nl
"A general rule of thumb is that any word which applies " { $link call } " or " { $link curry } " to one of its inputs must be declared " { $link POSTPONE: inline } "."
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs namespaces sequences kernel definitions math
-effects accessors words fry classes.algebra stack-checker.errors
+USING: assocs arrays namespaces sequences kernel definitions
+math effects accessors words fry classes.algebra
compiler.units ;
IN: stack-checker.state
-: <value> ( -- value ) \ <value> counter ;
-
-SYMBOL: known-values
-
-: known ( value -- known ) known-values get at ;
-
-: set-known ( known value -- )
- over [ known-values get set-at ] [ 2drop ] if ;
-
-: make-known ( known -- value )
- <value> [ set-known ] keep ;
-
-: copy-value ( value -- value' )
- known make-known ;
-
-: copy-values ( values -- values' )
- [ copy-value ] map ;
-
-! Literal value
-TUPLE: literal < identity-tuple value recursion ;
-
-: <literal> ( obj -- value )
- recursive-state get \ literal boa ;
-
-: literal ( value -- literal )
- known dup literal?
- [ \ literal-expected inference-warning ] unless ;
-
-! Result of curry
-TUPLE: curried obj quot ;
-
-C: <curried> curried
-
-! Result of compose
-TUPLE: composed quot1 quot2 ;
-
-C: <composed> composed
-
! Did the current control-flow path throw an error?
SYMBOL: terminated?
V{ } clone meta-r set
0 d-in set ;
-: init-known-values ( -- )
- H{ } clone known-values set ;
-
-: recursive-label ( word -- label/f )
- recursive-state get at ;
-
-: local-recursive-state ( -- assoc )
- recursive-state get dup
- [ first dup word? [ inline? ] when not ] find drop
- [ head-slice ] when* ;
-
-: inline-recursive-label ( word -- label/f )
- local-recursive-state at ;
-
-: recursive-quotation? ( quot -- ? )
- local-recursive-state [ first eq? ] with contains? ;
-
! Words that the current quotation depends on
SYMBOL: dependencies
! Generic words that the current quotation depends on
SYMBOL: generic-dependencies
+: ?class-or ( class/f class -- class' )
+ swap [ class-or ] when* ;
+
: depends-on-generic ( generic class -- )
generic-dependencies get dup
- [ swap '[ null or _ class-or ] change-at ] [ 3drop ] if ;
+ [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
! Words we've inferred the stack effect of, for rollback
SYMBOL: recorded
classes.tuple.private effects summary hashtables classes generic
sets definitions generic.standard slots.private continuations
stack-checker.backend stack-checker.state stack-checker.visitor
-stack-checker.errors ;
+stack-checker.errors stack-checker.values
+stack-checker.recursive-state ;
IN: stack-checker.transforms
: give-up-transform ( word -- )
- dup recursive-label
+ dup recursive-word?
[ call-recursive-word ]
[ dup infer-word apply-word/effect ]
if ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors namespaces kernel assocs sequences
+stack-checker.recursive-state ;
+IN: stack-checker.values
+
+! Values
+: <value> ( -- value ) \ <value> counter ;
+
+SYMBOL: known-values
+
+: init-known-values ( -- )
+ H{ } clone known-values set ;
+
+: known ( value -- known ) known-values get at ;
+
+: set-known ( known value -- )
+ over [ known-values get set-at ] [ 2drop ] if ;
+
+: make-known ( known -- value )
+ <value> [ set-known ] keep ;
+
+: copy-value ( value -- value' )
+ known make-known ;
+
+: copy-values ( values -- values' )
+ [ copy-value ] map ;
+
+! Literal value
+TUPLE: literal < identity-tuple value recursion hashcode ;
+
+M: literal hashcode* nip hashcode>> ;
+
+: <literal> ( obj -- value )
+ recursive-state get over hashcode \ literal boa ;
+
+GENERIC: (literal) ( value -- literal )
+
+M: literal (literal) ;
+
+: literal ( value -- literal )
+ known (literal) ;
+
+! Result of curry
+TUPLE: curried obj quot ;
+
+C: <curried> curried
+
+! Result of compose
+TUPLE: composed quot1 quot2 ;
+
+C: <composed> composed
M: f #call, 3drop ;
M: f #call-recursive, 3drop ;
M: f #push, 2drop ;
-M: f #shuffle, 3drop ;
+M: f #shuffle, 2drop 2drop drop ;
M: f #>r, 2drop ;
M: f #r>, 2drop ;
M: f #return, drop ;
HOOK: #call, stack-visitor ( inputs outputs word -- )
HOOK: #call-recursive, stack-visitor ( inputs outputs word -- )
HOOK: #push, stack-visitor ( literal value -- )
-HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- )
+HOOK: #shuffle, stack-visitor ( in-d out-d in-r out-r mapping -- )
HOOK: #drop, stack-visitor ( values -- )
HOOK: #>r, stack-visitor ( inputs outputs -- )
HOOK: #r>, stack-visitor ( inputs outputs -- )
--- /dev/null
+Marc Fauconneau
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays help.markup help.syntax io.streams.string
+sequences strings math suffix-arrays.private ;
+IN: suffix-arrays
+
+HELP: >suffix-array
+{ $values
+ { "seq" sequence }
+ { "array" array } }
+{ $description "Creates a suffix array from the input sequence. Suffix arrays are arrays of slices." } ;
+
+HELP: SA{
+{ $description "Creates a new literal suffix array at parse-time." } ;
+
+HELP: suffixes
+{ $values
+ { "string" string }
+ { "suffixes-seq" "a sequence of slices" } }
+{ $description "Returns a sequence of tail slices of the input string." } ;
+
+HELP: from-to
+{ $values
+ { "index" integer } { "begin" sequence } { "suffix-array" "a suffix-array" }
+ { "from/f" "an integer or f" } { "to/f" "an integer or f" } }
+{ $description "Finds the bounds of the suffix array that match the input sequence. A return value of " { $link f } " means that the endpoint is included." }
+{ $notes "Slices are [m,n) and we want (m,n) so we increment." } ;
+
+HELP: query
+{ $values
+ { "begin" sequence } { "suffix-array" "a suffix-array" }
+ { "matches" array } }
+{ $description "Returns a sequence of sequences from the suffix-array that contain the input sequence. An empty array is returned when there are no matches." } ;
+
+ARTICLE: "suffix-arrays" "Suffix arrays"
+"The " { $vocab-link "suffix-arrays" } " vocabulary implements the suffix array data structure for efficient lookup of subsequences. This suffix array implementation is a sorted array of suffixes. Querying it for matches uses binary search for efficiency." $nl
+
+"Creating new suffix arrays:"
+{ $subsection >suffix-array }
+"Literal suffix arrays:"
+{ $subsection POSTPONE: SA{ }
+"Querying suffix arrays:"
+{ $subsection query } ;
+
+ABOUT: "suffix-arrays"
--- /dev/null
+! Copyright (C) 2008 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test suffix-arrays kernel namespaces sequences ;
+IN: suffix-arrays.tests
+
+! built from [ all-words 10 head [ name>> ] map ]
+[ ] [
+ {
+ "run-tests"
+ "must-fail-with"
+ "test-all"
+ "short-effect"
+ "failure"
+ "test"
+ "<failure>"
+ "this-test"
+ "(unit-test)"
+ "unit-test"
+ } >suffix-array "suffix-array" set
+] unit-test
+
+[ t ]
+[ "suffix-array" get "" swap query empty? not ] unit-test
+
+[ { } ]
+[ SA{ } "something" swap query ] unit-test
+
+[ V{ "unit-test" "(unit-test)" } ]
+[ "suffix-array" get "unit-test" swap query ] unit-test
+
+[ t ]
+[ "suffix-array" get "something else" swap query empty? ] unit-test
+
+[ V{ "rofl" } ] [ SA{ "rofl" } "r" swap query ] unit-test
+[ V{ "rofl" } ] [ SA{ "rofl" } "o" swap query ] unit-test
+[ V{ "rofl" } ] [ SA{ "rofl" } "f" swap query ] unit-test
+[ V{ "rofl" } ] [ SA{ "rofl" } "l" swap query ] unit-test
+[ V{ } ] [ SA{ "rofl" } "t" swap query ] unit-test
--- /dev/null
+! Copyright (C) 2008 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser kernel arrays math accessors sequences
+math.vectors math.order sorting binary-search sets assocs fry ;
+IN: suffix-arrays
+
+<PRIVATE
+: suffixes ( string -- suffixes-seq )
+ dup length [ tail-slice ] with map ;
+
+: prefix<=> ( begin seq -- <=> )
+ [ <=> ] [ swap head? ] 2bi [ drop +eq+ ] when ;
+
+: find-index ( begin suffix-array -- index/f )
+ [ prefix<=> ] with search drop ;
+
+: from-to ( index begin suffix-array -- from/f to/f )
+ swap '[ _ head? not ]
+ [ find-last-from drop dup [ 1+ ] when ]
+ [ find-from drop ] 3bi ;
+
+: <funky-slice> ( from/f to/f seq -- slice )
+ [
+ tuck
+ [ drop 0 or ] [ length or ] 2bi*
+ [ min ] keep
+ ] keep <slice> ; inline
+
+PRIVATE>
+
+: >suffix-array ( seq -- array )
+ [ suffixes ] map concat natural-sort ;
+
+: SA{ \ } [ >suffix-array ] parse-literal ; parsing
+
+: query ( begin suffix-array -- matches )
+ 2dup find-index dup
+ [ -rot [ from-to ] keep <funky-slice> [ seq>> ] map prune ]
+ [ 3drop { } ] if ;
--- /dev/null
+Suffix arrays
--- /dev/null
+collections
--- /dev/null
+! Copyright (C) 2008 Marc Fauconneau.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel arrays math accessors sequences math.vectors\r
+math.order sorting binary-search sets assocs fry suffix-arrays ;\r
+IN: suffix-arrays.words\r
+\r
+! to search on word names\r
+\r
+: new-word-sa ( words -- sa )\r
+ [ name>> ] map >suffix-array ;\r
+\r
+: name>word-map ( words -- map )\r
+ dup [ name>> V{ } clone ] H{ } map>assoc\r
+ [ '[ dup name>> _ at push ] each ] keep ;\r
+\r
+: query-word-sa ( map begin sa -- matches ) query '[ _ at ] map concat ;\r
+\r
+! usage example :\r
+! clear all-words 100 head dup name>word-map "test" rot new-word-sa query .\r
-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"
"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
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 ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel sequences strings ;
+IN: tools.hexdump
+
+HELP: hexdump.
+{ $values { "seq" sequence } }
+{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time and writes it to standard out." } ;
+
+HELP: hexdump
+{ $values { "seq" sequence } { "str" string } }
+{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time. Lines are separated by a newline character." }
+{ $see-also hexdump. } ;
+
+ARTICLE: "tools.hexdump" "Hexdump"
+"The " { $vocab-link "tools.hexdump" } " vocabulary provides a traditional hexdump view of a sequence." $nl
+"Write hexdump to string:"
+{ $subsection hexdump }
+"Write the hexdump to the output stream:"
+{ $subsection hexdump. } ;
+
+ABOUT: "tools.hexdump"
--- /dev/null
+USING: tools.hexdump kernel sequences tools.test ;
+IN: tools.hexdump.tests
+
+[ t ] [ "" hexdump "Length: 0, 0h\n" = ] unit-test
+[ t ] [ "abcdefghijklmnopqrstuvwxyz" hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a qrstuvwxyz\n" = ] unit-test
+
+[ t ] [ 256 [ ] map hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test
+
+
+[
+ "Length: 3, 3h\n00000000h: 01 02 03 ...\n" ] [ B{ 1 2 3 } hexdump ] unit-test
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays io io.streams.string kernel math math.parser
+namespaces sequences splitting grouping strings ascii ;
+IN: tools.hexdump
+
+<PRIVATE
+
+: write-header ( len -- )
+ "Length: " write
+ [ number>string write ", " write ]
+ [ >hex write "h" write nl ] bi ;
+
+: write-offset ( lineno -- )
+ 16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
+
+: >hex-digit ( digit -- str )
+ >hex 2 CHAR: 0 pad-left " " append ;
+
+: >hex-digits ( bytes -- str )
+ [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-right ;
+
+: >ascii ( bytes -- str )
+ [ [ printable? ] keep CHAR: . ? ] "" map-as ;
+
+: write-hex-line ( bytes lineno -- )
+ write-offset [ >hex-digits write ] [ >ascii write ] bi nl ;
+
+PRIVATE>
+
+: hexdump. ( seq -- )
+ [ length write-header ]
+ [ 16 <sliced-groups> [ write-hex-line ] each-index ] bi ;
+
+: hexdump ( seq -- str )
+ [ hexdump. ] with-string-writer ;
--- /dev/null
+Prints formatted hex dump of an arbitrary sequence
IN: tools.profiler.tests
USING: accessors tools.profiler tools.test kernel memory math
-threads alien tools.profiler.private sequences compiler.units ;
+threads alien tools.profiler.private sequences compiler.units
+words ;
[ t ] [
\ length counter>>
] unit-test
[ 666 ] [ \ recompile-while-profiling-test counter>> ] unit-test
+
+[ ] [ [ [ ] compile-call ] profile ] unit-test
+
+[ [ gensym execute ] profile ] [ T{ undefined } = ] must-fail-with
"{ $values" print
[ " " write ($values.) ]
[ [ nl " " write ($values.) ] unless-empty ] bi*
- " }" write nl
+ nl "}" print
] if
] when* ;
[ example ] times
"}" print
] with-variable ;
+
+: scaffold-rc ( path -- )
+ [ touch-file ] [ "Click to edit: " write <pathname> . ] bi ;
+
+: scaffold-factor-boot-rc ( -- )
+ home ".factor-boot-rc" append-path scaffold-rc ;
+
+: scaffold-factor-rc ( -- )
+ home ".factor-rc" append-path scaffold-rc ;
{ $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
:: (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
! 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
} 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
#! 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
M: checkbox model-changed
swap value>> >>selected? relayout-1 ;
-TUPLE: radio-paint color ;
+TUPLE: radio-paint < caching-pen color interior-vertices boundary-vertices ;
+
+: <radio-paint> ( color -- paint ) radio-paint new swap >>color ;
+
+<PRIVATE
+
+: circle-steps 8 ;
-C: <radio-paint> radio-paint
+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 ;
: 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 )
: 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 ;
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 [
] 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 ;
: 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 ;
[ 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 % ;
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 ;
] if ;
: select-gadget ( gadget list -- )
- swap over children>> index
+ tuck children>> index
[ swap select-index ] [ drop ] if* ;
: clamp-loc ( point max -- point )
>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 [
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
] [
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 ;
dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add
dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
- swap over model>> <viewport> >>viewport
+ tuck model>> <viewport> >>viewport
dup viewport>> @center grid-add ;
: <scroller> ( gadget -- scroller ) scroller new-scroller ;
: 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 [
: 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 } ;
} ;
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>
-! 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
: 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 ;
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 -- )
: (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 )
[ [ (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 ;
+
+PRIVATE>
-M: solid draw-interior (solid) gl-fill-rect ;
+M: solid draw-interior
+ [ (solid) ] [ interior-vertices>> gl-vertex-pointer ] bi
+ (gl-fill-rect) ;
-M: solid draw-boundary (solid) gl-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 } } ;
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 ;
[ ] [ effective-group-name [ ] with-effective-group ] unit-test
[ ] [ effective-group-id [ ] with-effective-group ] unit-test
+
+[ ] [ [ ] with-group-cache ] unit-test
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
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
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types combinators kernel io.files unix.stat
+USING: alien.c-types combinators kernel unix.stat
math accessors system unix io.backend layouts vocabs.loader
sequences csv io.streams.string io.encodings.utf8 namespaces
unix.statfs io.files ;
] with-scope
[ mtab-csv>mtab-entry ] map ;
-M: linux mounted
+M: linux file-systems
parse-mtab [
[ mount-point>> file-system-info ] keep
{
block-size io-size blocks blocks-free blocks-available files
files-free file-system-id owner type-id flags filesystem-subtype ;
-M: macosx mounted ( -- array )
+M: macosx file-systems ( -- array )
f <void*> dup 0 getmntinfo64 dup io-error
[ *void* ] dip
"statfs64" heap-size [ * memory>byte-array ] keep group
kernel math.order sorting ;
IN: unix.statfs
-TUPLE: file-system-info root-directory total-free-size total-size ;
-
HOOK: >file-system-info os ( struct -- statfs )
-HOOK: mounted os ( -- array )
-
os {
{ linux [ "unix.statfs.linux" require ] }
{ macosx [ "unix.statfs.macosx" require ] }
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
{ "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
[ ] [ effective-username [ ] with-effective-user ] unit-test
[ ] [ effective-user-id [ ] with-effective-user ] unit-test
+
+[ ] [ [ ] with-user-cache ] unit-test
[ 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 )
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces make sets
-math.parser math.ranges assocs parser-combinators.regexp
-unicode.categories arrays hashtables words classes quotations
-xmode.catalog ;
+math.parser math.ranges assocs regexp unicode.categories arrays
+hashtables words classes quotations xmode.catalog ;
IN: validators
: v-default ( str def -- str/def )
--- /dev/null
+USING: vlists kernel persistent.sequences arrays tools.test
+namespaces accessors sequences assocs ;
+IN: vlists.tests
+
+[ { "hi" "there" } ]
+[ VL{ } "hi" swap ppush "there" swap ppush >array ] unit-test
+
+[ VL{ "hi" "there" "foo" } VL{ "hi" "there" "bar" } t ]
+[
+ VL{ } "hi" swap ppush "there" swap ppush "v" set
+ "foo" "v" get ppush
+ "bar" "v" get ppush
+ dup "baz" over ppush [ vector>> ] bi@ eq?
+] unit-test
+
+[ "foo" VL{ "hi" "there" } t ]
+[
+ VL{ "hi" "there" "foo" } dup "v" set
+ [ peek ] [ ppop ] bi
+ dup "v" get [ vector>> ] bi@ eq?
+] unit-test
+
+[ VL{ } 3 over push ] must-fail
+
+[ 4 VL{ "hi" } set-first ] must-fail
+
+[ 5 t ] [
+ "rice" VA{ { "rice" 5 } { "beans" 10 } } at*
+] unit-test
+
+[ 6 t ] [
+ "rice" VA{ { "rice" 5 } { "beans" 10 } { "rice" 6 } } at*
+] unit-test
+
+[ 3 ] [
+ VA{ { "rice" 5 } { "beans" 10 } { "rice" 6 } } assoc-size
+] unit-test
+
+[ f f ] [
+ "meat" VA{ { "rice" 5 } { "beans" 10 } { "rice" 6 } } at*
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors sequences sequences.private
+persistent.sequences assocs persistent.assocs kernel math
+vectors parser prettyprint.backend ;
+IN: vlists
+
+TUPLE: vlist
+{ length array-capacity read-only }
+{ vector vector read-only } ;
+
+: <vlist> ( -- vlist ) 0 V{ } clone vlist boa ; inline
+
+M: vlist length length>> ;
+
+M: vlist nth-unsafe vector>> nth-unsafe ;
+
+<PRIVATE
+
+: >vlist< [ length>> ] [ vector>> ] bi ; inline
+
+: unshare ( len vec -- len vec' )
+ clone [ set-length ] 2keep ; inline
+
+PRIVATE>
+
+M: vlist ppush
+ >vlist<
+ 2dup length = [ unshare ] unless
+ [ [ 1+ swap ] dip push ] keep vlist boa ;
+
+ERROR: empty-vlist-error ;
+
+M: vlist ppop
+ [ empty-vlist-error ]
+ [ [ length>> 1- ] [ vector>> ] bi vlist boa ] if-empty ;
+
+M: vlist clone
+ [ length>> ] [ vector>> >vector ] bi vlist boa ;
+
+M: vlist equal?
+ over vlist? [ sequence= ] [ 2drop f ] if ;
+
+: >vlist ( seq -- vlist )
+ [ length ] [ >vector ] bi vlist boa ; inline
+
+M: vlist like
+ drop dup vlist? [ >vlist ] unless ;
+
+INSTANCE: vlist immutable-sequence
+
+: VL{ \ } [ >vlist ] parse-literal ; parsing
+
+M: vlist pprint-delims drop \ VL{ \ } ;
+M: vlist >pprint-sequence ;
+M: vlist pprint* pprint-object ;
+
+TUPLE: valist { vlist vlist read-only } ;
+
+: <valist> ( -- valist ) <vlist> valist boa ; inline
+
+M: valist assoc-size vlist>> length 2/ ;
+
+: valist-at ( key i array -- value ? )
+ over 0 >= [
+ 3dup nth-unsafe = [
+ [ 1+ ] dip nth-unsafe nip t
+ ] [
+ [ 2 - ] dip valist-at
+ ] if
+ ] [ 3drop f f ] if ; inline recursive
+
+M: valist at*
+ vlist>> >vlist< [ 2 - ] [ underlying>> ] bi* valist-at ;
+
+M: valist new-at
+ vlist>> ppush ppush valist boa ;
+
+M: valist >alist vlist>> ;
+
+: >valist ( assoc -- valist )
+ >alist concat >vlist valist boa ; inline
+
+M: valist assoc-like
+ drop dup valist? [ >valist ] unless ;
+
+INSTANCE: valist assoc
+
+: VA{ \ } [ >valist ] parse-literal ; parsing
+
+M: valist pprint-delims drop \ VA{ \ } ;
+M: valist >pprint-sequence >alist ;
+M: valist pprint* pprint-object ;
! FUNCTION: GetDllDirectoryA
! FUNCTION: GetDllDirectoryW
! FUNCTION: GetDriveTypeA
-! FUNCTION: GetDriveTypeW
+FUNCTION: UINT GetDriveTypeW ( LPCTSTR lpRootPathName ) ;
+ALIAS: GetDriveType GetDriveTypeW
FUNCTION: void* GetEnvironmentStringsW ( ) ;
! FUNCTION: GetEnvironmentStringsA
ALIAS: GetEnvironmentStrings GetEnvironmentStringsW
! FUNCTION: GetLocaleInfoA
! FUNCTION: GetLocaleInfoW
! FUNCTION: GetLocalTime
-! FUNCTION: GetLogicalDrives
+FUNCTION: DWORD GetLogicalDrives ( ) ;
! FUNCTION: GetLogicalDriveStringsA
! FUNCTION: GetLogicalDriveStringsW
! FUNCTION: GetLongPathNameA
! FUNCTION: GetVolumeNameForVolumeMountPointW
! FUNCTION: GetVolumePathNameA
! FUNCTION: GetVolumePathNamesForVolumeNameA
-! FUNCTION: GetVolumePathNamesForVolumeNameW
+FUNCTION: BOOL GetVolumePathNamesForVolumeNameW ( LPCTSTR lpszVolumeName, LPTSTR lpszVolumePathNames, DWORD cchBufferLength, PDWORD lpcchReturnLength ) ;
+ALIAS: GetVolumePathNamesForVolumeName GetVolumePathNamesForVolumeNameW
+
! FUNCTION: GetVolumePathNameW
! FUNCTION: GetWindowsDirectoryA
FUNCTION: UINT GetWindowsDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
*FreeBSD*) OS=freebsd;;
*OpenBSD*) OS=openbsd;;
*DragonFly*) OS=dragonflybsd;;
- SunOS) OS=solaris;;
+ SunOS) OS=solaris;;
esac
}
$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
}
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() {
IN: byte-vectors.tests\r
-USING: tools.test byte-vectors vectors sequences kernel ;\r
+USING: tools.test byte-vectors vectors sequences kernel\r
+prettyprint ;\r
\r
[ 0 ] [ 123 <byte-vector> length ] unit-test\r
\r
] unit-test\r
\r
[ t ] [ BV{ } byte-vector? ] unit-test\r
+\r
+[ "BV{ }" ] [ BV{ } unparse ] unit-test\r
M: hashtable hashcode*
[
- dup assoc-size 1 number=
+ dup assoc-size 1 eq?
[ assoc-hashcode ] [ nip assoc-size ] if
] recursive-hashcode ;
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"
"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:"
PREDICATE: method-body < word
"method-generic" word-prop >boolean ;
-M: method-body inline?
- "method-generic" word-prop inline? ;
-
M: method-body stack-effect
"method-generic" word-prop stack-effect ;
USING: arrays generic hashtables kernel kernel.private math
namespaces make sequences words quotations layouts combinators
sequences.private classes classes.builtin classes.algebra
-definitions math.order ;
+definitions math.order math.private ;
IN: generic.math
PREDICATE: math-class < class
2drop object-method
] if ;
+SYMBOL: picker
+
: math-vtable ( picker quot -- quot )
[
- >r
- , \ tag ,
- num-tags get [ bootstrap-type>class ]
- r> compose map ,
- \ dispatch ,
+ swap picker set
+ picker get , [ tag 0 eq? ] %
+ num-tags get swap [ bootstrap-type>class ] prepose map
+ unclip ,
+ [
+ picker get , [ tag 1 fixnum-fast ] % , \ dispatch ,
+ ] [ ] make , \ if ,
] [ ] make ; inline
TUPLE: math-combination ;
] [
over object-method
] if nip
- ] math-vtable nip
- define ;
+ ] math-vtable nip define ;
PREDICATE: math-generic < generic ( word -- ? )
"combination" word-prop math-combination? ;
"type" word-prop
] if ;
+: sort-tags ( assoc -- alist ) >alist sort-keys reverse ;
+
M: lo-tag-dispatch-engine engine>quot
methods>> engines>quots*
[ >r lo-tag-number r> ] assoc-map
[
picker % [ tag ] % [
- >alist sort-keys reverse
- linear-dispatch-quot
+ sort-tags linear-dispatch-quot
] [
num-tags get direct-dispatch-quot
] if-small? %
\ hi-tag def>> ;
M: hi-tag-dispatch-engine engine>quot
- methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
+ methods>> engines>quots*
+ [ >r hi-tag-number r> ] assoc-map
[
picker % hi-tag-quot % [
- linear-dispatch-quot
+ sort-tags linear-dispatch-quot
] [
num-tags get , \ fixnum-fast ,
[ >r num-tags get - r> ] assoc-map
[ extra-values ] [ stack-effect ] bi
dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
-M: engine-word inline?
- "tuple-dispatch-generic" word-prop inline? ;
-
M: engine-word crossref? "forgotten" word-prop not ;
M: engine-word irrelevant? drop t ;
{ $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 ;"
}
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax sequences strings ;
-IN: grouping
-
-ARTICLE: "grouping" "Groups and clumps"
-"Splitting a sequence into disjoint, fixed-length subsequences:"
-{ $subsection group }
-"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
-{ $subsection groups }
-{ $subsection <groups> }
-{ $subsection <sliced-groups> }
-"Splitting a sequence into overlapping, fixed-length subsequences:"
-{ $subsection clump }
-"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
-{ $subsection clumps }
-{ $subsection <clumps> }
-{ $subsection <sliced-clumps> }
-"The difference can be summarized as the following:"
-{ $list
- { "With groups, the subsequences form the original sequence when concatenated:"
- { $unchecked-example "dup n groups concat sequence= ." "t" }
- }
- { "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
- { $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" }
- }
-} ;
-
-ABOUT: "grouping"
-
-HELP: groups
-{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
-$nl
-"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
-{ $see-also group } ;
-
-HELP: group
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
-{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." }
-{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." }
-{ $examples
- { $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
-} ;
-
-HELP: <groups>
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
-{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
-{ $examples
- { $example
- "USING: arrays kernel prettyprint sequences grouping ;"
- "9 >array 3 <groups> dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
- }
-} ;
-
-HELP: <sliced-groups>
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
-{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
-{ $examples
- { $example
- "USING: arrays kernel prettyprint sequences grouping ;"
- "9 >array 3 <sliced-groups>"
- "dup [ reverse-here ] each concat >array ."
- "{ 2 1 0 5 4 3 8 7 6 }"
- }
-} ;
-
-HELP: clumps
-{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
-$nl
-"New clumps are created by calling " { $link <clumps> } " and " { $link <sliced-clumps> } "." } ;
-
-HELP: clump
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
-{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." }
-{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
-{ $examples
- { $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
-} ;
-
-HELP: <clumps>
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
-{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
-{ $examples
- "Running averages:"
- { $example
- "USING: grouping sequences math prettyprint kernel ;"
- "IN: scratchpad"
- ": share-price"
- " { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;"
- ""
- "share-price 4 <clumps> [ [ sum ] [ length ] bi / ] map ."
- "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"
- }
-} ;
-
-HELP: <sliced-clumps>
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
-{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ;
-
-{ clumps groups } related-words
-
-{ clump group } related-words
-
-{ <clumps> <groups> } related-words
-
-{ <sliced-clumps> <sliced-groups> } related-words
+++ /dev/null
-USING: grouping tools.test kernel sequences arrays ;
-IN: grouping.tests
-
-[ { 1 2 3 } 0 group ] must-fail
-
-[ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test
-
-[ { V{ "a" "b" } V{ f f } } ] [
- V{ "a" "b" } clone 2 <groups>
- 2 over set-length
- >array
-] unit-test
-
-[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test
+++ /dev/null
-! 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 ;
-IN: grouping
-
-TUPLE: abstract-groups { seq read-only } { n read-only } ;
-
-: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
-
-: new-groups ( seq n class -- groups )
- >r check-groups r> boa ; inline
-
-GENERIC: group@ ( n groups -- from to seq )
-
-M: abstract-groups nth group@ subseq ;
-
-M: abstract-groups set-nth group@ <slice> 0 swap copy ;
-
-M: abstract-groups like drop { } like ;
-
-INSTANCE: abstract-groups sequence
-
-TUPLE: groups < abstract-groups ;
-
-: <groups> ( seq n -- groups )
- groups new-groups ; inline
-
-M: groups length
- [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
-
-M: groups set-length
- [ n>> * ] [ seq>> ] bi set-length ;
-
-M: groups group@
- [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
-
-TUPLE: sliced-groups < groups ;
-
-: <sliced-groups> ( seq n -- groups )
- sliced-groups new-groups ; inline
-
-M: sliced-groups nth group@ <slice> ;
-
-TUPLE: clumps < abstract-groups ;
-
-: <clumps> ( seq n -- clumps )
- clumps new-groups ; inline
-
-M: clumps length
- [ seq>> length ] [ n>> ] bi - 1+ ;
-
-M: clumps set-length
- [ n>> + 1- ] [ seq>> ] bi set-length ;
-
-M: clumps group@
- [ n>> over + ] [ seq>> ] bi ;
-
-TUPLE: sliced-clumps < clumps ;
-
-: <sliced-clumps> ( seq n -- clumps )
- sliced-clumps new-groups ; inline
-
-M: sliced-clumps nth group@ <slice> ;
-
-: group ( seq n -- array ) <groups> { } like ;
-
-: clump ( seq n -- array ) <clumps> { } like ;
+++ /dev/null
-Grouping sequence elements into subsequences
+++ /dev/null
-collections
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel kernel.private slots.private math
-assocs math.private sequences sequences.private vectors grouping ;
+assocs math.private sequences sequences.private vectors ;
IN: hashtables
TUPLE: hashtable
: associate ( value key -- hash )
2 <hashtable> [ set-at ] keep ;
+<PRIVATE
+
+: push-unsafe ( elt seq -- )
+ [ length ] keep
+ [ underlying>> set-array-nth ]
+ [ >r 1+ r> (>>length) ]
+ 2bi ; inline
+
+PRIVATE>
+
M: hashtable >alist
- array>> 2 <groups> [ first tombstone? not ] filter ;
+ [ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [
+ [
+ >r
+ >r 1 fixnum-shift-fast r>
+ [ array-nth ] [ >r 1 fixnum+fast r> array-nth ] 2bi r>
+ pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if
+ ] 2curry each
+ ] keep { } like ;
M: hashtable clone
(clone) [ clone ] change-array ;
M: hashtable equal?
over hashtable? [
- 2dup [ assoc-size ] bi@ number=
+ 2dup [ assoc-size ] bi@ eq?
[ assoc= ] [ 2drop f ] if
] [ 2drop f ] if ;
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"
-USING: help.markup help.syntax io strings
- io.backend io.files.private quotations ;
+USING: help.markup help.syntax io strings arrays io.backend
+io.files.private quotations ;
IN: io.files
ARTICLE: "file-streams" "Reading and writing files"
{ $values { "path" "a pathname string" } { "quot" quotation } }
{ $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ;
+HELP: file-systems
+{ $values { "array" array } }
+{ $description "Returns an array of " { $link file-system-info } " objects returned by iterating the mount points and calling " { $link file-system-info } " on each." } ;
+
HELP: file-system-info
{ $values
{ "path" "a pathname string" }
! File-system
+HOOK: file-systems os ( -- array )
+
TUPLE: file-system-info device-name mount-point type free-space ;
HOOK: file-system-info os ( path -- file-system-info )
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"
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 } }
{ $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:"
] 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+) ;
M: string like
drop dup string? [
dup sbuf? [
- dup length over underlying>> length number= [
+ dup length over underlying>> length eq? [
underlying>> dup reset-string-hashcode
] [
>string
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 } }
IN: slots.tests
USING: math accessors slots strings generic.standard kernel
-tools.test generic words parser eval ;
+tools.test generic words parser eval math.functions ;
TUPLE: r/w-test foo ;
[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
+
+! Test protocol slots
+SLOT: my-protocol-slot-test
+
+TUPLE: protocol-slot-test-tuple x ;
+
+M: protocol-slot-test-tuple my-protocol-slot-test>> x>> sq ;
+M: protocol-slot-test-tuple (>>my-protocol-slot-test) [ sqrt ] dip (>>x) ;
+
+[ 9 ] [ T{ protocol-slot-test-tuple { x 3 } } my-protocol-slot-test>> ] unit-test
+
+[ 4.0 ] [
+ T{ protocol-slot-test-tuple { x 3 } } clone
+ [ 7 + ] change-my-protocol-slot-test x>>
+] unit-test
: setter-word ( name -- word )
">>" prepend (( object value -- object )) create-accessor ;
-: define-setter ( slot-spec -- )
- name>> dup setter-word dup deferred? [
+: define-setter ( name -- )
+ dup setter-word dup deferred? [
[ \ over , swap writer-word , ] [ ] make define-inline
] [ 2drop ] if ;
: changer-word ( name -- word )
"change-" prepend (( object quot -- object )) create-accessor ;
-: define-changer ( slot-spec -- )
- name>> dup changer-word dup deferred? [
+: define-changer ( name -- )
+ dup changer-word dup deferred? [
[
[ over >r >r ] %
over reader-word ,
[ define-reader ]
[
dup read-only>> [ 2drop ] [
- [ define-setter drop ]
- [ define-changer drop ]
+ [ name>> define-setter drop ]
+ [ name>> define-changer drop ]
[ define-writer ]
2tri
] if
: define-protocol-slot ( name -- )
{
- [ reader-word drop ]
- [ writer-word drop ]
- [ setter-word drop ]
- [ changer-word drop ]
+ [ reader-word define-simple-generic ]
+ [ writer-word define-simple-generic ]
+ [ define-setter ]
+ [ define-changer ]
} cleave ;
ERROR: no-initial-value class ;
M: string equal?
over string? [
- over hashcode over hashcode number=
+ over hashcode over hashcode eq?
[ sequence= ] [ 2drop f ] if
] [
2drop f
[ compiled-generic-crossref get delete-at ]
tri ;
-GENERIC: inline? ( word -- ? )
-
-M: word inline? "inline" word-prop ;
+: inline? ( word -- ? ) "inline" word-prop ; inline
SYMBOL: visited
IN: advice
-USING: help.markup help.syntax tools.annotations words ;
+USING: help.markup help.syntax tools.annotations words coroutines ;
HELP: make-advised
{ $values { "word" "a word to annotate in preparation of advising" } }
{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
{ $description "Determines whether or not the given word has any advice on it." } ;
+HELP: ad-do-it
+{ $values { "input" "an object" } { "result" "an object" } }
+{ $description "Calls either the next applicable around advice or the main body, returning back to the point it was called from when finished. This word should only be called from inside advice." }
+{ $see-also coyield } ;
+
ARTICLE: "advice" "Advice"
"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences math tools.test advice parser namespaces ;
+USING: kernel sequences io io.streams.string math tools.test advice math.parser
+parser namespaces multiline eval words assocs ;
IN: advice.tests
[
-: foo "foo" ;
-\ foo make-advised
+ [ ad-do-it ] must-fail
+
+ : foo "foo" ;
+ \ foo make-advised
- { "bar" "foo" } [
- [ "bar" ] "barify" \ foo advise-before
- foo ] unit-test
+ { "bar" "foo" } [
+ [ "bar" ] "barify" \ foo advise-before
+ foo
+ ] unit-test
- { "bar" "foo" "baz" } [
- [ "baz" ] "bazify" \ foo advise-after
- foo ] unit-test
+ { "bar" "foo" "baz" } [
+ [ "baz" ] "bazify" \ foo advise-after
+ foo
+ ] unit-test
- { "foo" "baz" } [
- "barify" \ foo before remove-advice
- foo ] unit-test
+ { "foo" "baz" } [
+ "barify" \ foo before remove-advice
+ foo
+ ] unit-test
-: bar ( a -- b ) 1+ ;
-\ bar make-advised
-
- { 11 } [
- [ 2 * ] "double" \ bar advise-before
- 5 bar
- ] unit-test
-
- { 11/3 } [
- [ 3 / ] "third" \ bar advise-after
- 5 bar
- ] unit-test
-
- { -2 } [
- [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
- 5 bar
- ] unit-test
+ : bar ( a -- b ) 1+ ;
+ \ bar make-advised
+
+ { 11 } [
+ [ 2 * ] "double" \ bar advise-before
+ 5 bar
+ ] unit-test
+
+ { 11/3 } [
+ [ 3 / ] "third" \ bar advise-after
+ 5 bar
+ ] unit-test
+
+ { -2 } [
+ [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
+ 5 bar
+ ] unit-test
+
+ : add ( a b -- c ) + ;
+ \ add make-advised
+
+ { 10 } [
+ [ [ 2 * ] bi@ ] "double-args" \ add advise-before
+ 2 3 add
+ ] unit-test
+
+ { 21 } [
+ [ 3 * ad-do-it 1- ] "around1" \ add advise-around
+ 2 3 add
+ ] unit-test
+
+! { 9 } [
+! [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
+! 2 3 add
+! ] unit-test
+
+! { { "around1" "around2" } } [
+! \ add around word-prop keys
+! ] unit-test
+
+ { 5 f } [
+ \ add unadvise
+ 2 3 add \ add advised?
+ ] unit-test
+
+! : quux ( a b -- c ) * ;
+
+! { f t 3+3/4 } [
+! <" USING: advice kernel math ;
+! IN: advice.tests
+! \ quux advised?
+! ADVISE: quux halve before [ 2 / ] bi@ ;
+! \ quux advised?
+! 3 5 quux"> eval
+! ] unit-test
+
+! { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
+! <" USING: advice kernel math math.parser io io.streams.string ;
+! IN: advice.tests
+! ADVISE: quux log around
+! 2dup [ number>string write " " write ] bi@
+! ad-do-it
+! dup number>string write ;
+! [ 3 5 quux ] with-string-writer"> eval
+! ] unit-test
- ] with-scope
\ No newline at end of file
+] with-scope
\ No newline at end of file
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences symbols fry words assocs tools.annotations coroutines ;
+USING: kernel sequences symbols fry words assocs linked-assocs tools.annotations
+coroutines lexer parser quotations arrays namespaces continuations ;
IN: advice
-SYMBOLS: before after around advised ;
+SYMBOLS: before after around advised in-advice? ;
+
+: advised? ( word -- ? )
+ advised word-prop ;
+
+DEFER: make-advised
<PRIVATE
+: init-around-co ( quot -- coroutine )
+ \ coreset suffix cocreate ;
+PRIVATE>
+
: advise ( quot name word loc -- )
+ dup around eq? [ [ init-around-co ] 3dip ] when
+ over advised? [ over make-advised ] unless
word-prop set-at ;
-PRIVATE>
-: advise-before ( quot name word -- )
- before advise ;
+: advise-before ( quot name word -- ) before advise ;
-: advise-after ( quot name word -- )
- after advise ;
+: advise-after ( quot name word -- ) after advise ;
-: advise-around ( quot name word -- )
- [ \ coterminate suffix ] 2dip
- around advise ;
+: advise-around ( quot name word -- ) around advise ;
: get-advice ( word type -- seq )
word-prop values ;
after get-advice [ call ] each ;
: call-around ( main word -- )
- around get-advice [ cocreate ] map tuck
- [ [ coresume ] each ] [ call ] [ reverse [ coresume ] each ] tri* ;
+ t in-advice? [
+ around get-advice tuck
+ [ [ coresume ] each ] [ call ] [ <reversed> [ coresume ] each ] tri*
+ ] with-variable ;
: remove-advice ( name word loc -- )
word-prop delete-at ;
: ad-do-it ( input -- result )
- coyield ;
-
-: advised? ( word -- ? )
- advised word-prop ;
+ in-advice? get [ "ad-do-it should only be called inside 'around' advice" throw ] unless coyield ;
: make-advised ( word -- )
[ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
- [ { before after around } [ H{ } clone swap set-word-prop ] with each ]
+ [ { before after around } [ <linked-hash> swap set-word-prop ] with each ]
[ t advised set-word-prop ] tri ;
-
\ No newline at end of file
+
+: unadvise ( word -- )
+ [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
+
+: ADVISE: ! word adname location => word adname quot loc
+ scan-word scan scan-word parse-definition swap [ spin ] dip advise ; parsing
+
+: UNADVISE:
+ scan-word parsed \ unadvise parsed ; parsing
\ No newline at end of file
-advice
-aspect
-annotations
+extensions
: draw-bitmap ( bitmap -- ) GL_POINTS glBegin (draw-bitmap) glEnd ;
-: display ( -- ) black set-color bitmap> draw-bitmap ;
+: display ( -- ) black gl-color bitmap> draw-bitmap ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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 }
}
+++ /dev/null
-
-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
\ No newline at end of file
+++ /dev/null
-
-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
\ No newline at end of file
+++ /dev/null
-
-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 ;
\ No newline at end of file
+++ /dev/null
-
-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 ;
-
+++ /dev/null
-
-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 ;
+++ /dev/null
-
-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 ;
-
+++ /dev/null
-
-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 ;
\ No newline at end of file
+++ /dev/null
-
-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 ;
+++ /dev/null
-
-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 ;
\ No newline at end of file
+++ /dev/null
-
-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 ;
+++ /dev/null
-
-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 ;
+++ /dev/null
-
-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 ;
\ No newline at end of file
+++ /dev/null
-
-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
\ No newline at end of file
+++ /dev/null
-
-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 ;
\ No newline at end of file
+++ /dev/null
-
-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 ;
-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 )
USING: arrays bunny.model bunny.cel-shaded continuations
destructors kernel math multiline opengl opengl.shaders
-opengl.framebuffers opengl.gl opengl.capabilities sequences
-ui.gadgets combinators accessors ;
+opengl.framebuffers opengl.gl opengl.demo-support
+opengl.capabilities sequences ui.gadgets combinators accessors ;
IN: bunny.outlined
STRING: outlined-pass1-fragment-shader-main-source
--- /dev/null
+Sampo Vuori
--- /dev/null
+! Cairo "Hello World" demo
+! Copyright (c) 2007 Sampo Vuori
+! License: http://factorcode.org/license.txt
+!
+! This example is an adaptation of the following cairo sample code:
+! http://cairographics.org/samples/text/
+
+
+USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render
+ ui.gadgets opengl.gl accessors ;
+
+IN: cairo-demo
+
+
+: make-image-array ( -- array )
+ 384 256 4 * * <byte-array> ;
+
+: convert-array-to-surface ( array -- cairo_surface_t )
+ CAIRO_FORMAT_ARGB32 384 256 over 4 *
+ cairo_image_surface_create_for_data ;
+
+
+TUPLE: cairo-demo-gadget < gadget image-array cairo-t ;
+
+M: cairo-demo-gadget draw-gadget* ( gadget -- )
+ 0 0 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
+ image-array>> glDrawPixels ;
+
+: create-surface ( gadget -- cairo_surface_t )
+ make-image-array [ swap (>>image-array) ] keep
+ convert-array-to-surface ;
+
+: init-cairo ( gadget -- cairo_t )
+ create-surface cairo_create ;
+
+M: cairo-demo-gadget pref-dim* drop { 384 256 0 } ;
+
+: draw-hello-world ( gadget -- )
+ cairo-t>>
+ dup "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD cairo_select_font_face
+ dup 90.0 cairo_set_font_size
+ dup 10.0 135.0 cairo_move_to
+ dup "Hello" cairo_show_text
+ dup 70.0 165.0 cairo_move_to
+ dup "World" cairo_text_path
+ dup 0.5 0.5 1 cairo_set_source_rgb
+ dup cairo_fill_preserve
+ dup 0 0 0 cairo_set_source_rgb
+ dup 2.56 cairo_set_line_width
+ dup cairo_stroke
+ dup 1 0.2 0.2 0.6 cairo_set_source_rgba
+ dup 10.0 135.0 5.12 0 pi 2 * cairo_arc
+ dup cairo_close_path
+ dup 70.0 165.0 5.12 0 pi 2 * cairo_arc
+ cairo_fill ;
+
+M: cairo-demo-gadget graft* ( gadget -- )
+ dup dup init-cairo swap (>>cairo-t) draw-hello-world ;
+
+M: cairo-demo-gadget ungraft* ( gadget -- )
+ cairo-t>> cairo_destroy ;
+
+: <cairo-demo-gadget> ( -- gadget )
+ cairo-demo-gadget new-gadget ;
+
+: run ( -- )
+ [
+ <cairo-demo-gadget> "Hello World from Factor!" open-window
+ ] with-ui ;
+
+MAIN: run
--- /dev/null
+Sampo Vuori
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cairo.ffi kernel accessors sequences
+namespaces fry continuations destructors ;
+IN: cairo
+
+TUPLE: cairo-t alien ;
+C: <cairo-t> cairo-t
+M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
+
+TUPLE: cairo-surface-t alien ;
+C: <cairo-surface-t> cairo-surface-t
+M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
+
+: check-cairo ( cairo_status_t -- )
+ dup CAIRO_STATUS_SUCCESS = [ drop ]
+ [ cairo_status_to_string "Cairo error: " prepend throw ] if ;
+
+SYMBOL: cairo
+: cr ( -- cairo ) cairo get ;
+
+: (with-cairo) ( cairo-t quot -- )
+ >r alien>> cairo r> [ cr cairo_status check-cairo ]
+ compose with-variable ; inline
+
+: with-cairo ( cairo quot -- )
+ >r <cairo-t> r> [ (with-cairo) ] curry with-disposal ; inline
+
+: (with-surface) ( cairo-surface-t quot -- )
+ >r alien>> r> [ cairo_surface_status check-cairo ] bi ; inline
+
+: with-surface ( cairo_surface quot -- )
+ >r <cairo-surface-t> r> [ (with-surface) ] curry with-disposal ; inline
+
+: with-cairo-from-surface ( cairo_surface quot -- )
+ '[ cairo_create _ with-cairo ] with-surface ; inline
--- /dev/null
+! Copyright (c) 2007 Sampo Vuori
+! Copyright (c) 2008 Matthew Willis
+!
+! Adapted from cairo.h, version 1.5.14
+! License: http://factorcode.org/license.txt
+
+USING: system combinators alien alien.syntax kernel
+alien.c-types accessors sequences arrays ui.gadgets ;
+
+IN: cairo.ffi
+<< "cairo" {
+ { [ os winnt? ] [ "libcairo-2.dll" ] }
+ { [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
+ { [ os unix? ] [ "libcairo.so.2" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: cairo
+
+FUNCTION: int cairo_version ( ) ;
+FUNCTION: char* cairo_version_string ( ) ;
+
+TYPEDEF: int cairo_bool_t
+
+! I am leaving these and other void* types as opaque structures
+TYPEDEF: void* cairo_t
+TYPEDEF: void* cairo_surface_t
+
+C-STRUCT: cairo_matrix_t
+ { "double" "xx" }
+ { "double" "yx" }
+ { "double" "xy" }
+ { "double" "yy" }
+ { "double" "x0" }
+ { "double" "y0" } ;
+
+TYPEDEF: void* cairo_pattern_t
+
+TYPEDEF: void* cairo_destroy_func_t
+: cairo-destroy-func ( quot -- callback )
+ >r "void" { "void*" } "cdecl" r> alien-callback ; inline
+
+! See cairo.h for details
+C-STRUCT: cairo_user_data_key_t
+ { "int" "unused" } ;
+
+TYPEDEF: int cairo_status_t
+C-ENUM:
+ CAIRO_STATUS_SUCCESS
+ CAIRO_STATUS_NO_MEMORY
+ CAIRO_STATUS_INVALID_RESTORE
+ CAIRO_STATUS_INVALID_POP_GROUP
+ CAIRO_STATUS_NO_CURRENT_POINT
+ CAIRO_STATUS_INVALID_MATRIX
+ CAIRO_STATUS_INVALID_STATUS
+ CAIRO_STATUS_NULL_POINTER
+ CAIRO_STATUS_INVALID_STRING
+ CAIRO_STATUS_INVALID_PATH_DATA
+ CAIRO_STATUS_READ_ERROR
+ CAIRO_STATUS_WRITE_ERROR
+ CAIRO_STATUS_SURFACE_FINISHED
+ CAIRO_STATUS_SURFACE_TYPE_MISMATCH
+ CAIRO_STATUS_PATTERN_TYPE_MISMATCH
+ CAIRO_STATUS_INVALID_CONTENT
+ CAIRO_STATUS_INVALID_FORMAT
+ CAIRO_STATUS_INVALID_VISUAL
+ CAIRO_STATUS_FILE_NOT_FOUND
+ CAIRO_STATUS_INVALID_DASH
+ CAIRO_STATUS_INVALID_DSC_COMMENT
+ CAIRO_STATUS_INVALID_INDEX
+ CAIRO_STATUS_CLIP_NOT_REPRESENTABLE
+ CAIRO_STATUS_TEMP_FILE_ERROR
+ CAIRO_STATUS_INVALID_STRIDE ;
+
+TYPEDEF: int cairo_content_t
+: CAIRO_CONTENT_COLOR HEX: 1000 ;
+: CAIRO_CONTENT_ALPHA HEX: 2000 ;
+: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ;
+
+TYPEDEF: void* cairo_write_func_t
+: cairo-write-func ( quot -- callback )
+ >r "cairo_status_t" { "void*" "uchar*" "int" }
+ "cdecl" r> alien-callback ; inline
+
+TYPEDEF: void* cairo_read_func_t
+: cairo-read-func ( quot -- callback )
+ >r "cairo_status_t" { "void*" "uchar*" "int" }
+ "cdecl" r> alien-callback ; inline
+
+! Functions for manipulating state objects
+FUNCTION: cairo_t*
+cairo_create ( cairo_surface_t* target ) ;
+
+FUNCTION: cairo_t*
+cairo_reference ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_destroy ( cairo_t* cr ) ;
+
+FUNCTION: uint
+cairo_get_reference_count ( cairo_t* cr ) ;
+
+FUNCTION: void*
+cairo_get_user_data ( cairo_t* cr, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_set_user_data ( cairo_t* cr, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+FUNCTION: void
+cairo_save ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_restore ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_push_group ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_push_group_with_content ( cairo_t* cr, cairo_content_t content ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pop_group ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_pop_group_to_source ( cairo_t* cr ) ;
+
+! Modify state
+TYPEDEF: int cairo_operator_t
+C-ENUM:
+ CAIRO_OPERATOR_CLEAR
+
+ CAIRO_OPERATOR_SOURCE
+ CAIRO_OPERATOR_OVER
+ CAIRO_OPERATOR_IN
+ CAIRO_OPERATOR_OUT
+ CAIRO_OPERATOR_ATOP
+
+ CAIRO_OPERATOR_DEST
+ CAIRO_OPERATOR_DEST_OVER
+ CAIRO_OPERATOR_DEST_IN
+ CAIRO_OPERATOR_DEST_OUT
+ CAIRO_OPERATOR_DEST_ATOP
+
+ CAIRO_OPERATOR_XOR
+ CAIRO_OPERATOR_ADD
+ CAIRO_OPERATOR_SATURATE ;
+
+FUNCTION: void
+cairo_set_operator ( cairo_t* cr, cairo_operator_t op ) ;
+
+FUNCTION: void
+cairo_set_source ( cairo_t* cr, cairo_pattern_t* source ) ;
+
+FUNCTION: void
+cairo_set_source_rgb ( cairo_t* cr, double red, double green, double blue ) ;
+
+FUNCTION: void
+cairo_set_source_rgba ( cairo_t* cr, double red, double green, double blue, double alpha ) ;
+
+FUNCTION: void
+cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, double y ) ;
+
+FUNCTION: void
+cairo_set_tolerance ( cairo_t* cr, double tolerance ) ;
+
+TYPEDEF: int cairo_antialias_t
+C-ENUM:
+ CAIRO_ANTIALIAS_DEFAULT
+ CAIRO_ANTIALIAS_NONE
+ CAIRO_ANTIALIAS_GRAY
+ CAIRO_ANTIALIAS_SUBPIXEL ;
+
+FUNCTION: void
+cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ;
+
+TYPEDEF: int cairo_fill_rule_t
+C-ENUM:
+ CAIRO_FILL_RULE_WINDING
+ CAIRO_FILL_RULE_EVEN_ODD ;
+
+FUNCTION: void
+cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ;
+
+FUNCTION: void
+cairo_set_line_width ( cairo_t* cr, double width ) ;
+
+TYPEDEF: int cairo_line_cap_t
+C-ENUM:
+ CAIRO_LINE_CAP_BUTT
+ CAIRO_LINE_CAP_ROUND
+ CAIRO_LINE_CAP_SQUARE ;
+
+FUNCTION: void
+cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ;
+
+TYPEDEF: int cairo_line_join_t
+C-ENUM:
+ CAIRO_LINE_JOIN_MITER
+ CAIRO_LINE_JOIN_ROUND
+ CAIRO_LINE_JOIN_BEVEL ;
+
+FUNCTION: void
+cairo_set_line_join ( cairo_t* cr, cairo_line_join_t line_join ) ;
+
+FUNCTION: void
+cairo_set_dash ( cairo_t* cr, double* dashes, int num_dashes, double offset ) ;
+
+FUNCTION: void
+cairo_set_miter_limit ( cairo_t* cr, double limit ) ;
+
+FUNCTION: void
+cairo_translate ( cairo_t* cr, double tx, double ty ) ;
+
+FUNCTION: void
+cairo_scale ( cairo_t* cr, double sx, double sy ) ;
+
+FUNCTION: void
+cairo_rotate ( cairo_t* cr, double angle ) ;
+
+FUNCTION: void
+cairo_transform ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_set_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_identity_matrix ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_user_to_device ( cairo_t* cr, double* x, double* y ) ;
+
+FUNCTION: void
+cairo_user_to_device_distance ( cairo_t* cr, double* dx, double* dy ) ;
+
+FUNCTION: void
+cairo_device_to_user ( cairo_t* cr, double* x, double* y ) ;
+
+FUNCTION: void
+cairo_device_to_user_distance ( cairo_t* cr, double* dx, double* dy ) ;
+
+! Path creation functions
+FUNCTION: void
+cairo_new_path ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_move_to ( cairo_t* cr, double x, double y ) ;
+
+FUNCTION: void
+cairo_new_sub_path ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_line_to ( cairo_t* cr, double x, double y ) ;
+
+FUNCTION: void
+cairo_curve_to ( cairo_t* cr, double x1, double y1, double x2, double y2, double x3, double y3 ) ;
+
+FUNCTION: void
+cairo_arc ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
+
+FUNCTION: void
+cairo_arc_negative ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
+
+FUNCTION: void
+cairo_rel_move_to ( cairo_t* cr, double dx, double dy ) ;
+
+FUNCTION: void
+cairo_rel_line_to ( cairo_t* cr, double dx, double dy ) ;
+
+FUNCTION: void
+cairo_rel_curve_to ( cairo_t* cr, double dx1, double dy1, double dx2, double dy2, double dx3, double dy3 ) ;
+
+FUNCTION: void
+cairo_rectangle ( cairo_t* cr, double x, double y, double width, double height ) ;
+
+FUNCTION: void
+cairo_close_path ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_path_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+! Painting functions
+FUNCTION: void
+cairo_paint ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_paint_with_alpha ( cairo_t* cr, double alpha ) ;
+
+FUNCTION: void
+cairo_mask ( cairo_t* cr, cairo_pattern_t* pattern ) ;
+
+FUNCTION: void
+cairo_mask_surface ( cairo_t* cr, cairo_surface_t* surface, double surface_x, double surface_y ) ;
+
+FUNCTION: void
+cairo_stroke ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_stroke_preserve ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_fill ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_fill_preserve ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_copy_page ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_show_page ( cairo_t* cr ) ;
+
+! Insideness testing
+FUNCTION: cairo_bool_t
+cairo_in_stroke ( cairo_t* cr, double x, double y ) ;
+
+FUNCTION: cairo_bool_t
+cairo_in_fill ( cairo_t* cr, double x, double y ) ;
+
+! Rectangular extents
+FUNCTION: void
+cairo_stroke_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+FUNCTION: void
+cairo_fill_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+! Clipping
+FUNCTION: void
+cairo_reset_clip ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_clip ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_clip_preserve ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+C-STRUCT: cairo_rectangle_t
+ { "double" "x" }
+ { "double" "y" }
+ { "double" "width" }
+ { "double" "height" } ;
+
+C-STRUCT: cairo_rectangle_list_t
+ { "cairo_status_t" "status" }
+ { "cairo_rectangle_t*" "rectangles" }
+ { "int" "num_rectangles" } ;
+
+FUNCTION: cairo_rectangle_list_t*
+cairo_copy_clip_rectangle_list ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_rectangle_list_destroy ( cairo_rectangle_list_t* rectangle_list ) ;
+
+! Font/Text functions
+
+TYPEDEF: void* cairo_scaled_font_t
+
+TYPEDEF: void* cairo_font_face_t
+
+C-STRUCT: cairo_glyph_t
+ { "ulong" "index" }
+ { "double" "x" }
+ { "double" "y" } ;
+
+C-STRUCT: cairo_text_extents_t
+ { "double" "x_bearing" }
+ { "double" "y_bearing" }
+ { "double" "width" }
+ { "double" "height" }
+ { "double" "x_advance" }
+ { "double" "y_advance" } ;
+
+C-STRUCT: cairo_font_extents_t
+ { "double" "ascent" }
+ { "double" "descent" }
+ { "double" "height" }
+ { "double" "max_x_advance" }
+ { "double" "max_y_advance" } ;
+
+TYPEDEF: int cairo_font_slant_t
+C-ENUM:
+ CAIRO_FONT_SLANT_NORMAL
+ CAIRO_FONT_SLANT_ITALIC
+ CAIRO_FONT_SLANT_OBLIQUE ;
+
+TYPEDEF: int cairo_font_weight_t
+C-ENUM:
+ CAIRO_FONT_WEIGHT_NORMAL
+ CAIRO_FONT_WEIGHT_BOLD ;
+
+TYPEDEF: int cairo_subpixel_order_t
+C-ENUM:
+ CAIRO_SUBPIXEL_ORDER_DEFAULT
+ CAIRO_SUBPIXEL_ORDER_RGB
+ CAIRO_SUBPIXEL_ORDER_BGR
+ CAIRO_SUBPIXEL_ORDER_VRGB
+ CAIRO_SUBPIXEL_ORDER_VBGR ;
+
+TYPEDEF: int cairo_hint_style_t
+C-ENUM:
+ CAIRO_HINT_STYLE_DEFAULT
+ CAIRO_HINT_STYLE_NONE
+ CAIRO_HINT_STYLE_SLIGHT
+ CAIRO_HINT_STYLE_MEDIUM
+ CAIRO_HINT_STYLE_FULL ;
+
+TYPEDEF: int cairo_hint_metrics_t
+C-ENUM:
+ CAIRO_HINT_METRICS_DEFAULT
+ CAIRO_HINT_METRICS_OFF
+ CAIRO_HINT_METRICS_ON ;
+
+TYPEDEF: void* cairo_font_options_t
+
+FUNCTION: cairo_font_options_t*
+cairo_font_options_create ( ) ;
+
+FUNCTION: cairo_font_options_t*
+cairo_font_options_copy ( cairo_font_options_t* original ) ;
+
+FUNCTION: void
+cairo_font_options_destroy ( cairo_font_options_t* options ) ;
+
+FUNCTION: cairo_status_t
+cairo_font_options_status ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_merge ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
+
+FUNCTION: cairo_bool_t
+cairo_font_options_equal ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
+
+FUNCTION: ulong
+cairo_font_options_hash ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_antialias ( cairo_font_options_t* options, cairo_antialias_t antialias ) ;
+
+FUNCTION: cairo_antialias_t
+cairo_font_options_get_antialias ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_subpixel_order ( cairo_font_options_t* options, cairo_subpixel_order_t subpixel_order ) ;
+
+FUNCTION: cairo_subpixel_order_t
+cairo_font_options_get_subpixel_order ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_hint_style ( cairo_font_options_t* options, cairo_hint_style_t hint_style ) ;
+
+FUNCTION: cairo_hint_style_t
+cairo_font_options_get_hint_style ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_hint_metrics ( cairo_font_options_t* options, cairo_hint_metrics_t hint_metrics ) ;
+
+FUNCTION: cairo_hint_metrics_t
+cairo_font_options_get_hint_metrics ( cairo_font_options_t* options ) ;
+
+! This interface is for dealing with text as text, not caring about the
+! font object inside the the cairo_t.
+
+FUNCTION: void
+cairo_select_font_face ( cairo_t* cr, char* family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
+
+FUNCTION: void
+cairo_set_font_size ( cairo_t* cr, double size ) ;
+
+FUNCTION: void
+cairo_set_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_get_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_set_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_get_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_set_font_face ( cairo_t* cr, cairo_font_face_t* font_face ) ;
+
+FUNCTION: cairo_font_face_t*
+cairo_get_font_face ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_set_scaled_font ( cairo_t* cr, cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: cairo_scaled_font_t*
+cairo_get_scaled_font ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_show_text ( cairo_t* cr, char* utf8 ) ;
+
+FUNCTION: void
+cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
+
+FUNCTION: void
+cairo_text_path ( cairo_t* cr, char* utf8 ) ;
+
+FUNCTION: void
+cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
+
+FUNCTION: void
+cairo_text_extents ( cairo_t* cr, char* utf8, cairo_text_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_font_extents ( cairo_t* cr, cairo_font_extents_t* extents ) ;
+
+! Generic identifier for a font style
+
+FUNCTION: cairo_font_face_t*
+cairo_font_face_reference ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: void
+cairo_font_face_destroy ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: uint
+cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: cairo_status_t
+cairo_font_face_status ( cairo_font_face_t* font_face ) ;
+
+TYPEDEF: int cairo_font_type_t
+C-ENUM:
+ CAIRO_FONT_TYPE_TOY
+ CAIRO_FONT_TYPE_FT
+ CAIRO_FONT_TYPE_WIN32
+ CAIRO_FONT_TYPE_QUARTZ ;
+
+FUNCTION: cairo_font_type_t
+cairo_font_face_get_type ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: void*
+cairo_font_face_get_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_font_face_set_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+! Portable interface to general font features.
+
+FUNCTION: cairo_scaled_font_t*
+cairo_scaled_font_create ( cairo_font_face_t* font_face, cairo_matrix_t* font_matrix, cairo_matrix_t* ctm, cairo_font_options_t* options ) ;
+
+FUNCTION: cairo_scaled_font_t*
+cairo_scaled_font_reference ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: void
+cairo_scaled_font_destroy ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: uint
+cairo_scaled_font_get_reference_count ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: cairo_status_t
+cairo_scaled_font_status ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: cairo_font_type_t
+cairo_scaled_font_get_type ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: void*
+cairo_scaled_font_get_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_scaled_font_set_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+FUNCTION: void
+cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, char* utf8, cairo_text_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
+
+FUNCTION: cairo_font_face_t*
+cairo_scaled_font_get_font_face ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: void
+cairo_scaled_font_get_font_matrix ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* font_matrix ) ;
+
+FUNCTION: void
+cairo_scaled_font_get_ctm ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* ctm ) ;
+
+FUNCTION: void
+cairo_scaled_font_get_font_options ( cairo_scaled_font_t* scaled_font, cairo_font_options_t* options ) ;
+
+! Query functions
+
+FUNCTION: cairo_operator_t
+cairo_get_operator ( cairo_t* cr ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_get_source ( cairo_t* cr ) ;
+
+FUNCTION: double
+cairo_get_tolerance ( cairo_t* cr ) ;
+
+FUNCTION: cairo_antialias_t
+cairo_get_antialias ( cairo_t* cr ) ;
+
+FUNCTION: cairo_bool_t
+cairo_has_current_point ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_get_current_point ( cairo_t* cr, double* x, double* y ) ;
+
+FUNCTION: cairo_fill_rule_t
+cairo_get_fill_rule ( cairo_t* cr ) ;
+
+FUNCTION: double
+cairo_get_line_width ( cairo_t* cr ) ;
+
+FUNCTION: cairo_line_cap_t
+cairo_get_line_cap ( cairo_t* cr ) ;
+
+FUNCTION: cairo_line_join_t
+cairo_get_line_join ( cairo_t* cr ) ;
+
+FUNCTION: double
+cairo_get_miter_limit ( cairo_t* cr ) ;
+
+FUNCTION: int
+cairo_get_dash_count ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_get_dash ( cairo_t* cr, double* dashes, double* offset ) ;
+
+FUNCTION: void
+cairo_get_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_get_target ( cairo_t* cr ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_get_group_target ( cairo_t* cr ) ;
+
+TYPEDEF: int cairo_path_data_type_t
+C-ENUM:
+ CAIRO_PATH_MOVE_TO
+ CAIRO_PATH_LINE_TO
+ CAIRO_PATH_CURVE_TO
+ CAIRO_PATH_CLOSE_PATH ;
+
+! NEED TO DO UNION HERE
+C-STRUCT: cairo_path_data_t-point
+ { "double" "x" }
+ { "double" "y" } ;
+
+C-STRUCT: cairo_path_data_t-header
+ { "cairo_path_data_type_t" "type" }
+ { "int" "length" } ;
+
+C-UNION: cairo_path_data_t "cairo_path_data_t-point" "cairo_path_data_t-header" ;
+
+C-STRUCT: cairo_path_t
+ { "cairo_status_t" "status" }
+ { "cairo_path_data_t*" "data" }
+ { "int" "num_data" } ;
+
+FUNCTION: cairo_path_t*
+cairo_copy_path ( cairo_t* cr ) ;
+
+FUNCTION: cairo_path_t*
+cairo_copy_path_flat ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_append_path ( cairo_t* cr, cairo_path_t* path ) ;
+
+FUNCTION: void
+cairo_path_destroy ( cairo_path_t* path ) ;
+
+! Error status queries
+
+FUNCTION: cairo_status_t
+cairo_status ( cairo_t* cr ) ;
+
+FUNCTION: char*
+cairo_status_to_string ( cairo_status_t status ) ;
+
+! Surface manipulation
+
+FUNCTION: cairo_surface_t*
+cairo_surface_create_similar ( cairo_surface_t* other, cairo_content_t content, int width, int height ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_surface_reference ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_finish ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_destroy ( cairo_surface_t* surface ) ;
+
+FUNCTION: uint
+cairo_surface_get_reference_count ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_status ( cairo_surface_t* surface ) ;
+
+TYPEDEF: int cairo_surface_type_t
+C-ENUM:
+ CAIRO_SURFACE_TYPE_IMAGE
+ CAIRO_SURFACE_TYPE_PDF
+ CAIRO_SURFACE_TYPE_PS
+ CAIRO_SURFACE_TYPE_XLIB
+ CAIRO_SURFACE_TYPE_XCB
+ CAIRO_SURFACE_TYPE_GLITZ
+ CAIRO_SURFACE_TYPE_QUARTZ
+ CAIRO_SURFACE_TYPE_WIN32
+ CAIRO_SURFACE_TYPE_BEOS
+ CAIRO_SURFACE_TYPE_DIRECTFB
+ CAIRO_SURFACE_TYPE_SVG
+ CAIRO_SURFACE_TYPE_OS2
+ CAIRO_SURFACE_TYPE_WIN32_PRINTING
+ CAIRO_SURFACE_TYPE_QUARTZ_IMAGE ;
+
+FUNCTION: cairo_surface_type_t
+cairo_surface_get_type ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_content_t
+cairo_surface_get_content ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
+
+FUNCTION: void*
+cairo_surface_get_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_set_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+FUNCTION: void
+cairo_surface_get_font_options ( cairo_surface_t* surface, cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_surface_flush ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_mark_dirty ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_mark_dirty_rectangle ( cairo_surface_t* surface, int x, int y, int width, int height ) ;
+
+FUNCTION: void
+cairo_surface_set_device_offset ( cairo_surface_t* surface, double x_offset, double y_offset ) ;
+
+FUNCTION: void
+cairo_surface_get_device_offset ( cairo_surface_t* surface, double* x_offset, double* y_offset ) ;
+
+FUNCTION: void
+cairo_surface_set_fallback_resolution ( cairo_surface_t* surface, double x_pixels_per_inch, double y_pixels_per_inch ) ;
+
+FUNCTION: void
+cairo_surface_copy_page ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_show_page ( cairo_surface_t* surface ) ;
+
+! Image-surface functions
+
+TYPEDEF: int cairo_format_t
+C-ENUM:
+ CAIRO_FORMAT_ARGB32
+ CAIRO_FORMAT_RGB24
+ CAIRO_FORMAT_A8
+ CAIRO_FORMAT_A1
+ CAIRO_FORMAT_RGB16_565 ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create ( cairo_format_t format, int width, int height ) ;
+
+FUNCTION: int
+cairo_format_stride_for_width ( cairo_format_t format, int width ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create_for_data ( uchar* data, cairo_format_t format, int width, int height, int stride ) ;
+
+FUNCTION: uchar*
+cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_format_t
+cairo_image_surface_get_format ( cairo_surface_t* surface ) ;
+
+FUNCTION: int
+cairo_image_surface_get_width ( cairo_surface_t* surface ) ;
+
+FUNCTION: int
+cairo_image_surface_get_height ( cairo_surface_t* surface ) ;
+
+FUNCTION: int
+cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create_from_png ( char* filename ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;
+
+! Pattern creation functions
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_rgb ( double red, double green, double blue ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_rgba ( double red, double green, double blue, double alpha ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_for_surface ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_linear ( double x0, double y0, double x1, double y1 ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_radial ( double cx0, double cy0, double radius0, double cx1, double cy1, double radius1 ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_reference ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: void
+cairo_pattern_destroy ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: uint
+cairo_pattern_get_reference_count ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_status ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: void*
+cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+TYPEDEF: int cairo_pattern_type_t
+C-ENUM:
+ CAIRO_PATTERN_TYPE_SOLID
+ CAIRO_PATTERN_TYPE_SURFACE
+ CAIRO_PATTERN_TYPE_LINEAR
+ CAIRO_PATTERN_TYPE_RADIA ;
+
+FUNCTION: cairo_pattern_type_t
+cairo_pattern_get_type ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: void
+cairo_pattern_add_color_stop_rgb ( cairo_pattern_t* pattern, double offset, double red, double green, double blue ) ;
+
+FUNCTION: void
+cairo_pattern_add_color_stop_rgba ( cairo_pattern_t* pattern, double offset, double red, double green, double blue, double alpha ) ;
+
+FUNCTION: void
+cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
+
+TYPEDEF: int cairo_extend_t
+C-ENUM:
+ CAIRO_EXTEND_NONE
+ CAIRO_EXTEND_REPEAT
+ CAIRO_EXTEND_REFLECT
+ CAIRO_EXTEND_PAD ;
+
+FUNCTION: void
+cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ;
+
+FUNCTION: cairo_extend_t
+cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ;
+
+TYPEDEF: int cairo_filter_t
+C-ENUM:
+ CAIRO_FILTER_FAST
+ CAIRO_FILTER_GOOD
+ CAIRO_FILTER_BEST
+ CAIRO_FILTER_NEAREST
+ CAIRO_FILTER_BILINEAR
+ CAIRO_FILTER_GAUSSIAN ;
+
+FUNCTION: void
+cairo_pattern_set_filter ( cairo_pattern_t* pattern, cairo_filter_t filter ) ;
+
+FUNCTION: cairo_filter_t
+cairo_pattern_get_filter ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_color_stop_count ( cairo_pattern_t* pattern, int* count ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_linear_points ( cairo_pattern_t* pattern, double* x0, double* y0, double* x1, double* y1 ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_radial_circles ( cairo_pattern_t* pattern, double* x0, double* y0, double* r0, double* x1, double* y1, double* r1 ) ;
+
+! Matrix functions
+
+FUNCTION: void
+cairo_matrix_init ( cairo_matrix_t* matrix, double xx, double yx, double xy, double yy, double x0, double y0 ) ;
+
+FUNCTION: void
+cairo_matrix_init_identity ( cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_matrix_init_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
+
+FUNCTION: void
+cairo_matrix_init_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
+
+FUNCTION: void
+cairo_matrix_init_rotate ( cairo_matrix_t* matrix, double radians ) ;
+
+FUNCTION: void
+cairo_matrix_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
+
+FUNCTION: void
+cairo_matrix_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
+
+FUNCTION: void
+cairo_matrix_rotate ( cairo_matrix_t* matrix, double radians ) ;
+
+FUNCTION: cairo_status_t
+cairo_matrix_invert ( cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_matrix_multiply ( cairo_matrix_t* result, cairo_matrix_t* a, cairo_matrix_t* b ) ;
+
+FUNCTION: void
+cairo_matrix_transform_distance ( cairo_matrix_t* matrix, double* dx, double* dy ) ;
+
+FUNCTION: void
+cairo_matrix_transform_point ( cairo_matrix_t* matrix, double* x, double* y ) ;
+
+! Functions to be used while debugging (not intended for use in production code)
+FUNCTION: void
+cairo_debug_reset_static_data ( ) ;
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences math opengl.gadgets kernel
+byte-arrays cairo.ffi cairo io.backend
+ui.gadgets accessors opengl.gl
+arrays fry classes ;
+
+IN: cairo.gadgets
+
+: width>stride ( width -- stride ) 4 * ;
+
+: copy-cairo ( dim quot -- byte-array )
+ >r first2 over width>stride
+ [ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
+ [ cairo_image_surface_create_for_data ] 3bi
+ r> with-cairo-from-surface ; inline
+
+TUPLE: cairo-gadget < texture-gadget ;
+
+: <cairo-gadget> ( dim -- gadget )
+ cairo-gadget new-gadget
+ swap >>dim ;
+
+M: cairo-gadget cache-key* [ dim>> ] [ class ] bi 2array ;
+
+: render-cairo ( dim quot -- bytes format )
+ >r 2^-bounds r> copy-cairo GL_BGRA ; inline
+
+GENERIC: render-cairo* ( gadget -- )
+
+M: cairo-gadget render*
+ [ dim>> dup ] [ '[ _ render-cairo* ] ] bi
+ render-cairo render-bytes* ;
+
+! maybe also texture>png
+! : cairo>png ( gadget path -- )
+! >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
+! [ height>> ] tri over width>stride
+! cairo_image_surface_create_for_data
+! r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
+
+: copy-surface ( surface -- )
+ cr swap 0 0 cairo_set_source_surface
+ cr cairo_paint ;
+
+TUPLE: png-gadget < texture-gadget path ;
+: <png> ( path -- gadget )
+ png-gadget new-gadget
+ swap >>path ;
+
+M: png-gadget render*
+ path>> normalize-path cairo_image_surface_create_from_png
+ [ cairo_image_surface_get_width ]
+ [ cairo_image_surface_get_height 2array dup 2^-bounds ]
+ [ [ copy-surface ] curry copy-cairo ] tri
+ GL_BGRA render-bytes* ;
+
+M: png-gadget cache-key* path>> ;
--- /dev/null
+! Copyright (C) 2008 Matthew Willis
+! See http://factorcode.org/license.txt for BSD license.
+!
+! these samples are a subset of the samples on
+! http://cairographics.org/samples/
+USING: cairo cairo.ffi locals math.constants math
+io.backend kernel alien.c-types libc namespaces
+cairo.gadgets ui.gadgets accessors ;
+
+IN: cairo.samples
+
+TUPLE: arc-gadget < cairo-gadget ;
+M:: arc-gadget render-cairo* ( gadget -- )
+ [let | xc [ 128.0 ]
+ yc [ 128.0 ]
+ radius [ 100.0 ]
+ angle1 [ pi 1/4 * ]
+ angle2 [ pi ] |
+ cr 10.0 cairo_set_line_width
+ cr xc yc radius angle1 angle2 cairo_arc
+ cr cairo_stroke
+
+ ! draw helping lines
+ cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+ cr 6.0 cairo_set_line_width
+
+ cr xc yc 10.0 0 2 pi * cairo_arc
+ cr cairo_fill
+
+ cr xc yc radius angle1 angle1 cairo_arc
+ cr xc yc cairo_line_to
+ cr xc yc radius angle2 angle2 cairo_arc
+ cr xc yc cairo_line_to
+ cr cairo_stroke
+ ] ;
+
+TUPLE: clip-gadget < cairo-gadget ;
+M: clip-gadget render-cairo* ( gadget -- )
+ drop
+ cr 128 128 76.8 0 2 pi * cairo_arc
+ cr cairo_clip
+ cr cairo_new_path
+
+ cr 0 0 256 256 cairo_rectangle
+ cr cairo_fill
+ cr 0 1 0 cairo_set_source_rgb
+ cr 0 0 cairo_move_to
+ cr 256 256 cairo_line_to
+ cr 256 0 cairo_move_to
+ cr 0 256 cairo_line_to
+ cr 10 cairo_set_line_width
+ cr cairo_stroke ;
+
+TUPLE: clip-image-gadget < cairo-gadget ;
+M:: clip-image-gadget render-cairo* ( gadget -- )
+ [let* | png [ "resource:misc/icons/Factor_128x128.png"
+ normalize-path cairo_image_surface_create_from_png ]
+ w [ png cairo_image_surface_get_width ]
+ h [ png cairo_image_surface_get_height ] |
+ cr 128 128 76.8 0 2 pi * cairo_arc
+ cr cairo_clip
+ cr cairo_new_path
+
+ cr 192.0 w / 192.0 h / cairo_scale
+ cr png 32 32 cairo_set_source_surface
+ cr cairo_paint
+ png cairo_surface_destroy
+ ] ;
+
+TUPLE: dash-gadget < cairo-gadget ;
+M:: dash-gadget render-cairo* ( gadget -- )
+ [let | dashes [ { 50 10 10 10 } >c-double-array ]
+ ndash [ 4 ] |
+ cr dashes ndash -50 cairo_set_dash
+ cr 10 cairo_set_line_width
+ cr 128.0 25.6 cairo_move_to
+ cr 230.4 230.4 cairo_line_to
+ cr -102.4 0 cairo_rel_line_to
+ cr 51.2 230.4 51.2 128.0 128.0 128.0 cairo_curve_to
+ cr cairo_stroke
+ ] ;
+
+TUPLE: gradient-gadget < cairo-gadget ;
+M:: gradient-gadget render-cairo* ( gadget -- )
+ [let | pat [ 0 0 0 256 cairo_pattern_create_linear ]
+ radial [ 115.2 102.4 25.6 102.4 102.4 128.0
+ cairo_pattern_create_radial ] |
+ pat 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
+ pat 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
+ cr 0 0 256 256 cairo_rectangle
+ cr pat cairo_set_source
+ cr cairo_fill
+ pat cairo_pattern_destroy
+
+ radial 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
+ radial 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
+ cr radial cairo_set_source
+ cr 128.0 128.0 76.8 0 2 pi * cairo_arc
+ cr cairo_fill
+ radial cairo_pattern_destroy
+ ] ;
+
+TUPLE: text-gadget < cairo-gadget ;
+M: text-gadget render-cairo* ( gadget -- )
+ drop
+ cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
+ cairo_select_font_face
+ cr 50 cairo_set_font_size
+ cr 10 135 cairo_move_to
+ cr "Hello" cairo_show_text
+
+ cr 70 165 cairo_move_to
+ cr "factor" cairo_text_path
+ cr 0.5 0.5 1 cairo_set_source_rgb
+ cr cairo_fill_preserve
+ cr 0 0 0 cairo_set_source_rgb
+ cr 2.56 cairo_set_line_width
+ cr cairo_stroke
+
+ ! draw helping lines
+ cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+ cr 10 135 5.12 0 2 pi * cairo_arc
+ cr cairo_close_path
+ cr 70 165 5.12 0 2 pi * cairo_arc
+ cr cairo_fill ;
+
+TUPLE: utf8-gadget < cairo-gadget ;
+M: utf8-gadget render-cairo* ( gadget -- )
+ drop
+ cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
+ cairo_select_font_face
+ cr 50 cairo_set_font_size
+ "cairo_text_extents_t" malloc-object
+ cr "日本語" pick cairo_text_extents
+ cr over
+ [ cairo_text_extents_t-width 2 / ]
+ [ cairo_text_extents_t-x_bearing ] bi +
+ 128 swap - pick
+ [ cairo_text_extents_t-height 2 / ]
+ [ cairo_text_extents_t-y_bearing ] bi +
+ 128 swap - cairo_move_to
+ free
+ cr "日本語" cairo_show_text
+
+ cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+ cr 6 cairo_set_line_width
+ cr 128 0 cairo_move_to
+ cr 0 256 cairo_rel_line_to
+ cr 0 128 cairo_move_to
+ cr 256 0 cairo_rel_line_to
+ cr cairo_stroke ;
+
+ USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
+ : samples ( -- )
+ {
+ arc-gadget clip-gadget clip-image-gadget dash-gadget
+ gradient-gadget text-gadget utf8-gadget
+ }
+ [ new-gadget { 256 256 } >>dim gadget. ] each ;
+
+ MAIN: samples
--- /dev/null
+Cairo graphics library binding
SELF-SLOTS: hsva
-: clear-color ( color -- ) set-clear-color GL_COLOR_BUFFER_BIT glClear ;
+: clear-color ( color -- ) gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: push-color ( -- ) self> color-stack> push self> clone >self ;
-: pop-color ( -- ) color-stack> pop dup >self set-color ;
+: pop-color ( -- ) color-stack> pop dup >self gl-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: circle ( -- )
- self> set-color
+ self> gl-color
gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;
: triangle ( -- )
- self> set-color
+ self> gl-color
GL_POLYGON glBegin
0 0.577 glVertex2d
0.5 -0.289 glVertex2d
glEnd ;
: square ( -- )
- self> set-color
+ self> gl-color
GL_POLYGON glBegin
-0.5 0.5 glVertex2d
0.5 0.5 glVertex2d
set-initial-color
- self> set-color
+ self> gl-color
start-shape> call
Chris Double
Clemens F. Hofreither
+James Cash
-! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
+! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither, 2008 James Cash.
USING: help.markup help.syntax ;
IN: coroutines
HELP: coterminate
{ $values { "v" "an object" } }
{ $description "Terminate the current coroutine, leaving the value v on the stack when control is passed to the " { $link coresume } " caller. Resuming a terminated coroutine is a no-op." }
-{ $see-also coyield }
+{ $see-also coyield coreset }
+;
+
+HELP: coreset
+{ $values { "v" "an object" } }
+{ $description "Reset the current coroutine, leaving the value v on the stack when control is passed to the " { $link coresume } " caller. When the coroutine is resumed, it will continue at the beginning of the coroutine." }
+{ $see-also coyield coterminate }
;
HELP: current-coro
-! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
+! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither, 2008 James Cash.
! See http://factorcode.org/license.txt for BSD license.
IN: coroutines.tests
USING: coroutines kernel sequences prettyprint tools.test math ;
[ [ coyield* ] each ] cocreate ;
{ "c" "b" "a" } [ test3 { "a" "b" "c" } over coresume >r dup *coresume >r *coresume r> r> ] unit-test
+
+{ 4+2/3 } [ [ 1+ coyield 2 * coyield 3 / coreset ] cocreate 1 5 [ over coresume ] times nip ] unit-test
\ No newline at end of file
-! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
+! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither, 2008 James Cash.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel hashtables namespaces make continuations quotations
accessors ;
SYMBOL: current-coro
-TUPLE: coroutine resumecc exitcc ;
+TUPLE: coroutine resumecc exitcc originalcc ;
: cocreate ( quot -- co )
coroutine new
[ swapd , , \ bind ,
"Coroutine has terminated illegally." , \ throw ,
] [ ] make
- >>resumecc ;
+ [ >>resumecc ] [ >>originalcc ] bi ;
: coresume ( v co -- result )
[
>>exitcc
resumecc>> call
#! At this point, the coroutine quotation must have terminated
- #! normally (without calling coyield or coterminate). This shouldn't happen.
+ #! normally (without calling coyield, coreset, or coterminate). This shouldn't happen.
f over
] callcc1 2nip ;
current-coro get
[ ] >>resumecc
exitcc>> continue-with ;
+
+: coreset ( v -- )
+ current-coro get dup
+ originalcc>> >>resumecc
+ exitcc>> continue-with ;
\ No newline at end of file
USING: accessors arrays classes.singleton combinators
continuations io io.encodings.binary io.encodings.utf8
io.files io.sockets kernel io.streams.duplex math
-math.parser sequences splitting namespaces strings fry ftp ;
+math.parser sequences splitting namespaces strings fry ftp
+ftp.client.listing-parser urls ;
IN: ftp.client
: (ftp-response-code) ( str -- n )
[ fourth CHAR: - = ] tri
[ read-response-loop ] when ;
+ERROR: ftp-error got expected ;
+
+: ftp-assert ( ftp-response n -- )
+ 2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ;
+
: ftp-command ( string -- ftp-response )
ftp-send read-response ;
-: ftp-user ( ftp-client -- ftp-response )
- user>> "USER " prepend ftp-command ;
+: ftp-user ( url -- ftp-response )
+ username>> "USER " prepend ftp-command ;
-: ftp-password ( ftp-client -- ftp-response )
+: ftp-password ( url -- ftp-response )
password>> "PASS " prepend ftp-command ;
-: ftp-set-binary ( -- ftp-response )
- "TYPE I" ftp-command ;
-
-: ftp-pwd ( -- ftp-response )
- "PWD" ftp-command ;
-
-: ftp-list ( -- ftp-response )
- "LIST" ftp-command ;
-
-: ftp-quit ( -- ftp-response )
- "QUIT" ftp-command ;
-
: ftp-cwd ( directory -- ftp-response )
"CWD " prepend ftp-command ;
: ftp-retr ( filename -- ftp-response )
"RETR " prepend ftp-command ;
-: parse-epsv ( ftp-response -- port )
- strings>> first
- "|" split 2 tail* first string>number ;
-
-TUPLE: remote-file
-type permissions links owner group size month day time year
-name target ;
-
-: <remote-file> ( -- remote-file ) remote-file new ;
-
-: parse-permissions ( remote-file str -- remote-file )
- [ first ch>type >>type ] [ rest >>permissions ] bi ;
-
-: parse-list-11 ( lines -- seq )
- [
- 11 f pad-right
- <remote-file> swap {
- [ 0 swap nth parse-permissions ]
- [ 1 swap nth string>number >>links ]
- [ 2 swap nth >>owner ]
- [ 3 swap nth >>group ]
- [ 4 swap nth string>number >>size ]
- [ 5 swap nth >>month ]
- [ 6 swap nth >>day ]
- [ 7 swap nth >>time ]
- [ 8 swap nth >>name ]
- [ 10 swap nth >>target ]
- } cleave
- ] map ;
-
-: parse-list-8 ( lines -- seq )
- [
- <remote-file> swap {
- [ 0 swap nth parse-permissions ]
- [ 1 swap nth string>number >>links ]
- [ 2 swap nth >>owner ]
- [ 3 swap nth >>size ]
- [ 4 swap nth >>month ]
- [ 5 swap nth >>day ]
- [ 6 swap nth >>time ]
- [ 7 swap nth >>name ]
- } cleave
- ] map ;
-
-: parse-list-3 ( lines -- seq )
- [
- <remote-file> swap {
- [ 0 swap nth parse-permissions ]
- [ 1 swap nth string>number >>links ]
- [ 2 swap nth >>name ]
- } cleave
- ] map ;
-
-: parse-list ( ftp-response -- ftp-response )
- dup strings>>
- [ " " split harvest ] map
- dup length {
- { 11 [ parse-list-11 ] }
- { 9 [ parse-list-11 ] }
- { 8 [ parse-list-8 ] }
- { 3 [ parse-list-3 ] }
- [ drop ]
- } case >>parsed ;
+: ftp-set-binary ( -- ftp-response ) "TYPE I" ftp-command ;
-: ftp-epsv ( -- ftp-response )
- "EPSV" ftp-command ;
+: ftp-pwd ( -- ftp-response ) "PWD" ftp-command ;
-ERROR: ftp-error got expected ;
-: ftp-assert ( ftp-response n -- )
- 2dup >r n>> r> = [ 2drop ] [ ftp-error ] if ;
+: ftp-list ( -- )
+ "LIST" ftp-command 150 ftp-assert ;
-: ftp-login ( ftp-client -- )
- read-response 220 ftp-assert
- [ ftp-user 331 ftp-assert ]
- [ ftp-password 230 ftp-assert ] bi
- ftp-set-binary 200 ftp-assert ;
+: ftp-quit ( -- ftp-response ) "QUIT" ftp-command ;
+
+: ftp-epsv ( -- ftp-response )
+ "EPSV" ftp-command dup 229 ftp-assert ;
-: open-remote-port ( -- port )
- ftp-epsv
- [ 229 ftp-assert ] [ parse-epsv ] bi ;
+: parse-epsv ( ftp-response -- port )
+ strings>> first "|" split 2 tail* first string>number ;
-: list ( ftp-client -- ftp-response )
- host>> open-remote-port <inet> utf8 <client> drop
- ftp-list 150 ftp-assert
+: open-passive-client ( url protocol -- stream )
+ [ host>> ftp-epsv parse-epsv <inet> ] dip <client> drop ;
+
+: list ( url -- ftp-response )
+ utf8 open-passive-client
+ ftp-list
lines
<ftp-response> swap >>strings
read-response 226 ftp-assert
parse-list ;
-: ftp-get ( filename ftp-client -- ftp-response )
- host>> open-remote-port <inet> binary <client> drop
- swap
+: (ftp-get) ( url path -- )
+ [ binary open-passive-client ] dip
[ ftp-retr 150 ftp-assert drop ]
[ binary <file-writer> stream-copy ] 2bi
- read-response dup 226 ftp-assert ;
+ read-response 226 ftp-assert ;
+
+: ftp-login ( url -- )
+ read-response 220 ftp-assert
+ [ ftp-user 331 ftp-assert ]
+ [ ftp-password 230 ftp-assert ] bi
+ ftp-set-binary 200 ftp-assert ;
-: ftp-connect ( ftp-client -- stream )
+: ftp-connect ( url -- stream )
[ host>> ] [ port>> ] bi <inet> utf8 <client> drop ;
-GENERIC: ftp-download ( path obj -- )
+: with-ftp-client ( url quot -- )
+ [ [ ftp-connect ] keep ] dip
+ '[ _ [ ftp-login ] _ bi ftp-quit drop ] with-stream ; inline
+
+: ensure-login ( url -- url )
+ dup username>> [
+ "anonymous" >>username
+ "ftp-client" >>password
+ ] unless ;
-: with-ftp-client ( ftp-client quot -- )
- dupd '[
- _ [ ftp-login ] [ @ ] bi
- ftp-quit drop
- ] >r ftp-connect r> with-stream ; inline
+: >ftp-url ( url -- url' ) >url ensure-port ensure-login ;
-M: ftp-client ftp-download ( path ftp-client -- )
- [
- [ drop parent-directory ftp-cwd drop ]
- [ >r file-name r> ftp-get drop ] 2bi
+: ftp-get ( url -- )
+ >ftp-url [
+ dup path>>
+ [ nip parent-directory ftp-cwd drop ]
+ [ file-name (ftp-get) ] 2bi
] with-ftp-client ;
-M: string ftp-download ( path string -- )
- <ftp-client> ftp-download ;
+
+
+
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators io.files kernel math.parser
+sequences splitting ;
+IN: ftp.client.listing-parser
+
+: ch>file-type ( ch -- type )
+ {
+ { CHAR: b [ +block-device+ ] }
+ { CHAR: c [ +character-device+ ] }
+ { CHAR: d [ +directory+ ] }
+ { CHAR: l [ +symbolic-link+ ] }
+ { CHAR: s [ +socket+ ] }
+ { CHAR: p [ +fifo+ ] }
+ { CHAR: - [ +regular-file+ ] }
+ [ drop +unknown+ ]
+ } case ;
+
+: file-type>ch ( type -- string )
+ {
+ { +block-device+ [ CHAR: b ] }
+ { +character-device+ [ CHAR: c ] }
+ { +directory+ [ CHAR: d ] }
+ { +symbolic-link+ [ CHAR: l ] }
+ { +socket+ [ CHAR: s ] }
+ { +fifo+ [ CHAR: p ] }
+ { +regular-file+ [ CHAR: - ] }
+ [ drop CHAR: - ]
+ } case ;
+
+: parse-permissions ( remote-file str -- remote-file )
+ [ first ch>file-type >>type ] [ rest >>permissions ] bi ;
+
+TUPLE: remote-file
+type permissions links owner group size month day time year
+name target ;
+
+: <remote-file> ( -- remote-file ) remote-file new ;
+
+: parse-list-11 ( lines -- seq )
+ [
+ 11 f pad-right
+ <remote-file> swap {
+ [ 0 swap nth parse-permissions ]
+ [ 1 swap nth string>number >>links ]
+ [ 2 swap nth >>owner ]
+ [ 3 swap nth >>group ]
+ [ 4 swap nth string>number >>size ]
+ [ 5 swap nth >>month ]
+ [ 6 swap nth >>day ]
+ [ 7 swap nth >>time ]
+ [ 8 swap nth >>name ]
+ [ 10 swap nth >>target ]
+ } cleave
+ ] map ;
+
+: parse-list-8 ( lines -- seq )
+ [
+ <remote-file> swap {
+ [ 0 swap nth parse-permissions ]
+ [ 1 swap nth string>number >>links ]
+ [ 2 swap nth >>owner ]
+ [ 3 swap nth >>size ]
+ [ 4 swap nth >>month ]
+ [ 5 swap nth >>day ]
+ [ 6 swap nth >>time ]
+ [ 7 swap nth >>name ]
+ } cleave
+ ] map ;
+
+: parse-list-3 ( lines -- seq )
+ [
+ <remote-file> swap {
+ [ 0 swap nth parse-permissions ]
+ [ 1 swap nth string>number >>links ]
+ [ 2 swap nth >>name ]
+ } cleave
+ ] map ;
+
+: parse-list ( ftp-response -- ftp-response )
+ dup strings>>
+ [ " " split harvest ] map
+ dup length {
+ { 11 [ parse-list-11 ] }
+ { 9 [ parse-list-11 ] }
+ { 8 [ parse-list-8 ] }
+ { 3 [ parse-list-3 ] }
+ [ drop ]
+ } case >>parsed ;
SINGLETON: active
SINGLETON: passive
-TUPLE: ftp-client host port user password mode state
-command-promise ;
-
-: <ftp-client> ( host -- ftp-client )
- ftp-client new
- swap >>host
- 21 >>port
- "anonymous" >>user
- "ftp@my.org" >>password ;
-
-: reset-ftp-client ( ftp-client -- )
- f >>user
- f >>password
- drop ;
-
TUPLE: ftp-response n strings parsed ;
: <ftp-response> ( -- ftp-response )
over strings>> push ;
: ftp-send ( string -- ) write "\r\n" write flush ;
-
: ftp-ipv4 1 ; inline
: ftp-ipv6 2 ; inline
-
-
-: ch>type ( ch -- type )
- {
- { CHAR: d [ +directory+ ] }
- { CHAR: l [ +symbolic-link+ ] }
- { CHAR: - [ +regular-file+ ] }
- [ drop +unknown+ ]
- } case ;
-
-: type>ch ( type -- string )
- {
- { +directory+ [ CHAR: d ] }
- { +symbolic-link+ [ CHAR: l ] }
- { +regular-file+ [ CHAR: - ] }
- [ drop CHAR: - ]
- } case ;
-
-: file-info>string ( file-info name -- string )
- >r [ [ type>> type>ch 1string ] [ drop "rwx------" append ] bi ]
- [ size>> number>string 15 CHAR: \s pad-left ] bi r>
- 3array " " join ;
-
-: directory-list ( -- seq )
- "" directory-files
- [ [ link-info ] keep file-info>string ] map ;
namespaces make sequences ftp io.unix.launcher.parser
unicode.case splitting assocs classes io.servers.connection
destructors calendar io.timeouts io.streams.duplex threads
-continuations math concurrency.promises byte-arrays ;
+continuations math concurrency.promises byte-arrays
+io.backend sequences.lib tools.hexdump io.files.listing ;
IN: ftp.server
+TUPLE: ftp-client url mode state command-promise ;
+
+: <ftp-client> ( url -- ftp-client )
+ ftp-client new
+ swap >>url ;
+
SYMBOL: client
+: ftp-server-directory ( -- str )
+ \ ftp-server-directory get-global "resource:temp" or
+ normalize-path ;
+
TUPLE: ftp-command raw tokenized ;
: <ftp-command> ( -- obj )
TUPLE: ftp-get path ;
: <ftp-get> ( path -- obj )
- ftp-get new swap >>path ;
+ ftp-get new
+ swap >>path ;
TUPLE: ftp-put path ;
: <ftp-put> ( path -- obj )
- ftp-put new swap >>path ;
+ ftp-put new
+ swap >>path ;
TUPLE: ftp-list ;
: handle-USER ( ftp-command -- )
[
- tokenized>> second client get swap >>user drop
+ tokenized>> second client get (>>user)
331 "Please specify the password." server-response
] [
2drop "bad USER" ftp-error
: handle-PASS ( ftp-command -- )
[
- tokenized>> second client get swap >>password drop
+ tokenized>> second client get (>>password)
230 "Login successful" server-response
] [
2drop "PASS error" ftp-error
: handle-PWD ( obj -- )
drop
- 257 current-directory get "\"" swap "\"" 3append server-response ;
+ 257 current-directory get "\"" "\"" surround server-response ;
: handle-SYST ( obj -- )
drop
215 "UNIX Type: L8" server-response ;
: if-command-promise ( quot -- )
- >r client get command-promise>> r>
+ [ client get command-promise>> ] dip
[ "Establish an active or passive connection first" ftp-error ] if* ;
: handle-STOR ( obj -- )
[
tokenized>> second
- [ >r <ftp-put> r> fulfill ] if-command-promise
+ [ [ <ftp-put> ] dip fulfill ] if-command-promise
] [
2drop
] recover ;
start-directory
[
utf8 encode-output
- directory-list [ ftp-send ] each
+ directory. [ ftp-send ] each
] with-output-stream
finish-directory ;
rot
[ file-name ] [
" " swap file-info size>> number>string
- "(" " bytes)." swapd 3append append
+ "(" " bytes)." surround append
] bi 3append server-response ;
: transfer-incoming-file ( path -- )
: handle-LIST ( obj -- )
drop
- [ >r <ftp-list> r> fulfill ] if-command-promise ;
+ [ [ <ftp-list> ] dip fulfill ] if-command-promise ;
: handle-SIZE ( obj -- )
[
expect-connection
[
"Entering Passive Mode (127,0,0,1," %
- port>bytes [ number>string ] bi@ "," swap 3append %
+ port>bytes [ number>string ] bi@ "," splice %
")" %
] "" make 227 swap server-response ;
! : handle-LPRT ( obj -- ) tokenized>> "," split ;
ERROR: not-a-directory ;
+ERROR: no-permissions ;
: handle-CWD ( obj -- )
[
- tokenized>> second dup directory? [
+ tokenized>> second dup normalize-path
+ dup ftp-server-directory head? [
+ no-permissions
+ ] unless
+
+ file-info directory? [
set-current-directory
250 "Directory successully changed." server-response
] [
- not-a-directory throw
+ not-a-directory
] if
] [
2drop
: handle-client-loop ( -- )
<ftp-command> readln
+ USE: prettyprint global [ dup . flush ] bind
[ >>raw ]
[ tokenize-command >>tokenized ] bi
dup tokenized>> first >upper {
M: ftp-server handle-client* ( server -- )
drop
[
- "" [
+ ftp-server-directory [
host-name <ftp-client> client set
send-banner handle-client-loop
] with-directory
ftp-server new-threaded-server
swap >>insecure
"ftp.server" >>name
+ 5 minutes >>timeout
latin1 >>encoding ;
: ftpd ( port -- )
io.backend graphics.viewer io io.binary io.files kernel libc
math math.functions namespaces opengl opengl.gl prettyprint
sequences strings ui ui.gadgets.panes io.encodings.binary
-accessors ;
+accessors grouping ;
IN: graphics.bitmap
! Currently can only handle 24bit bitmaps.
swap [ >>array ] [ >>color-index ] bi
24 >>bit-count ;
-: raw-bitmap>string ( str n -- str )
+: 8bit>array ( bitmap -- array )
+ [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
+ [ color-index>> >array ] bi [ swap nth ] with map concat ;
+
+: 4bit>array ( bitmap -- array )
+ [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
+ [ color-index>> >array ] bi [ swap nth ] with map concat ;
+
+: raw-bitmap>array ( bitmap -- array )
+ dup bit-count>>
{
{ 32 [ "32bit" throw ] }
- { 24 [ ] }
+ { 24 [ color-index>> ] }
{ 16 [ "16bit" throw ] }
- { 8 [ "8bit" throw ] }
- { 4 [ "4bit" throw ] }
+ { 8 [ 8bit>array ] }
+ { 4 [ 4bit>array ] }
{ 2 [ "2bit" throw ] }
{ 1 [ "1bit" throw ] }
- } case ;
+ } case >byte-array ;
ERROR: bitmap-magic ;
: load-bitmap ( path -- bitmap )
normalize-path binary [
- T{ bitmap } clone
- dup parse-file-header
- dup parse-bitmap-header
- dup parse-bitmap
+ bitmap new
+ dup parse-file-header
+ dup parse-bitmap-header
+ dup parse-bitmap
] with-file-reader
- dup color-index>> over bit-count>>
- raw-bitmap>string >byte-array >>array ;
+ dup raw-bitmap>array >>array ;
: save-bitmap ( bitmap path -- )
binary [
bit-count>> {
! { 32 [ GL_BGRA GL_UNSIGNED_INT_8_8_8_8 ] } ! broken
{ 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
+ { 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
+ { 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
} case
] keep array>> glDrawPixels ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel sequences strings ;
-IN: hexdump
-
-HELP: hexdump.
-{ $values { "seq" sequence } }
-{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time and writes it to standard out." } ;
-
-HELP: hexdump
-{ $values { "seq" sequence } { "str" string } }
-{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time. Lines are separated by a newline character." }
-{ $see-also hexdump. } ;
-
-ARTICLE: "hexdump" "Hexdump"
-"The " { $vocab-link "hexdump" } " vocabulary provides a traditional hexdump view of a sequence." $nl
-"Write hexdump to string:"
-{ $subsection hexdump }
-"Write the hexdump to the output stream:"
-{ $subsection hexdump. } ;
-
-ABOUT: "hexdump"
+++ /dev/null
-IN: hexdump.tests
-USING: hexdump kernel sequences tools.test ;
-
-[ t ] [ "" hexdump "Length: 0, 0h\n" = ] unit-test
-[ t ] [ "abcdefghijklmnopqrstuvwxyz" hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a qrstuvwxyz\n" = ] unit-test
-
-[ t ] [ 256 [ ] map hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test
-
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io io.streams.string kernel math math.parser
-namespaces sequences splitting grouping strings ascii ;
-IN: hexdump
-
-<PRIVATE
-
-: write-header ( len -- )
- "Length: " write
- [ number>string write ", " write ]
- [ >hex write "h" write nl ] bi ;
-
-: write-offset ( lineno -- )
- 16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
-
-: >hex-digit ( digit -- str )
- >hex 2 CHAR: 0 pad-left " " append ;
-
-: >hex-digits ( bytes -- str )
- [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-right ;
-
-: >ascii ( bytes -- str )
- [ [ printable? ] keep CHAR: . ? ] map ;
-
-: write-hex-line ( str lineno -- )
- write-offset [ >hex-digits write ] [ >ascii write ] bi nl ;
-
-PRIVATE>
-
-: hexdump. ( seq -- )
- [ length write-header ]
- [ 16 <sliced-groups> [ write-hex-line ] each-index ] bi ;
-
-: hexdump ( seq -- str )
- [ hexdump. ] with-string-writer ;
+++ /dev/null
-Prints formatted hex dump of an arbitrary sequence
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu sequences float-arrays ;
+USING: accessors alien.c-types jamshred.game jamshred.oint
+jamshred.player jamshred.tunnel kernel math math.constants
+math.functions math.vectors opengl opengl.gl opengl.glu
+opengl.demo-support sequences float-arrays ;
IN: jamshred.gl
: min-vertices 6 ; inline
dup [ / pi 2 * * ] curry map ;
: draw-segment-vertex ( segment theta -- )
- over color>> set-color segment-vertex-and-normal
+ over color>> gl-color segment-vertex-and-normal
gl-normal gl-vertex ;
: draw-vertex-pair ( theta next-segment segment -- )
] with-scope
] unit-test
-[ { "scp" "boot.x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [
+[ { "scp" "boot.unix-x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [
[
"joe" image-username set
"blah.com" image-host set
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces continuations debugger sequences fry
-io.files io.launcher mason.common mason.platform
+io.files io.launcher bootstrap.image qualified mason.common
mason.config ;
+FROM: mason.config => target-os ;
IN: mason.release.tidy
: common-files ( -- seq )
+ images [ boot-image-name ] map
{
- "boot.x86.32.image"
- "boot.x86.64.image"
- "boot.macosx-ppc.image"
- "boot.linux-ppc.image"
"vm"
"temp"
"logs"
"unmaintained"
"unfinished"
"build-support"
- } ;
+ }
+ append ;
: remove-common-files ( -- )
common-files [ delete-tree ] each ;
-! Copyright (c) 2007 Samuel Tardieu
+! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions sequences fry ;
IN: math.algebra
: chinese-remainder ( aseq nseq -- x )
- dup product
- [
+ dup product [
'[ _ over / [ swap gcd drop ] keep * * ] 2map sum
] keep rem ; foldable
--- /dev/null
+USING: help.markup help.syntax math ;
+IN: math.analysis
+
+HELP: gamma
+{ $values { "x" number } { "y" number } }
+{ $description "Gamma function; an extension of factorial to real and complex numbers." } ;
+
+HELP: gammaln
+{ $values { "x" number } { "gamma[x]" number } }
+{ $description "An alternative to " { $link gamma } " when gamma(x)'s range varies too widely." } ;
+
+HELP: nth-root
+{ $values { "n" integer } { "x" number } { "y" number } }
+{ $description "Calculates the nth root of a number, such that " { $snippet "y^n=x" } "." } ;
+
+HELP: exp-int
+{ $values { "x" number } { "y" number } }
+{ $description "Exponential integral function." }
+{ $notes "Works only for real values of " { $snippet "x" } " and is accurate to 7 decimal places." } ;
+
+HELP: stirling-fact
+{ $values { "n" integer } { "fact" integer } }
+{ $description "James Stirling's factorial approximation." } ;
+
0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] produce reverse 2nip ;
: (>permutation) ( seq n -- seq )
- [ [ dupd >= [ 1+ ] when ] curry map ] keep prefix ;
+ [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ;
: >permutation ( factoradic -- permutation )
reverse 1 cut [ (>permutation) ] each ;
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: help.markup help.syntax ;
-
+USING: help.markup help.syntax math ;
IN: math.compare
HELP: absmin
-{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description
- "Returns the smaller absolute number with the original sign."
-} ;
+{ $values { "a" number } { "b" number } { "x" number } }
+{ $description "Returns the smaller absolute number with the original sign." } ;
HELP: absmax
-{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description
- "Returns the larger absolute number with the original sign."
-} ;
+{ $values { "a" number } { "b" number } { "x" number } }
+{ $description "Returns the larger absolute number with the original sign." } ;
HELP: posmax
-{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description
- "Returns the most-positive value, or zero if both are negative."
-} ;
+{ $values { "a" number } { "b" number } { "x" number } }
+{ $description "Returns the most-positive value, or zero if both are negative." } ;
HELP: negmin
-{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description
- "Returns the most-negative value, or zero if both are positive."
-} ;
+{ $values { "a" number } { "b" number } { "x" number } }
+{ $description "Returns the most-negative value, or zero if both are positive." } ;
HELP: clamp
-{ $values { "a" "a number" } { "value" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description
- "Returns the value when between 'a' and 'b', 'a' if <= 'a', or 'b' if >= 'b'."
-} ;
+{ $values { "a" number } { "value" number } { "b" number } { "x" number } }
+{ $description "Returns the value when between " { $snippet "a" } " and " { $snippet "b" } ", " { $snippet "a" } " if <= " { $snippet "a" } ", or " { $snippet "b" } " if >= " { $snippet "b" } "." } ;
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: kernel math math.functions math.compare tools.test ;
-
+USING: kernel math math.compare math.functions tools.test ;
IN: math.compare.tests
[ -1 ] [ -1 5 absmin ] unit-test
[ 1 ] [ 0 1 2 clamp ] unit-test
[ 2 ] [ 0 3 2 clamp ] unit-test
-
-
-
-! Copyright (C) 2008 John Benediktsson
+! Copyright (C) 2008 John Benediktsson.
! See http://factorcode.org/license.txt for BSD license
-
USING: math math.order kernel ;
+IN: math.compare
-IN: math.compare
-
-: absmin ( a b -- x )
- [ [ abs ] bi@ < ] 2keep ? ;
+: absmin ( a b -- x )
+ [ [ abs ] bi@ < ] 2keep ? ;
-: absmax ( a b -- x )
- [ [ abs ] bi@ > ] 2keep ? ;
+: absmax ( a b -- x )
+ [ [ abs ] bi@ > ] 2keep ? ;
-: posmax ( a b -- x )
- 0 max max ;
+: posmax ( a b -- x )
+ 0 max max ;
-: negmin ( a b -- x )
- 0 min min ;
+: negmin ( a b -- x )
+ 0 min min ;
: clamp ( a value b -- x )
- min max ;
+ min max ;
--- /dev/null
+USING: math math.derivatives tools.test ;
+IN: math.derivatives.test
+
+[ 8 ] [ 4 [ sq ] derivative >integer ] unit-test
+
-USING: kernel continuations combinators sequences math
- math.order math.ranges accessors float-arrays ;
-
+! Copyright (c) 2008 Reginald Keith Ford II, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel continuations combinators sequences math math.order math.ranges
+ accessors float-arrays ;
IN: math.derivatives
TUPLE: state x func h err i j errt fac hh ans a done ;
: a[i-1][i-1] ( state -- elt ) [ i>> 1 - ] [ i>> 1 - ] [ a>> ] tri nth nth ;
: check-h ( state -- state )
- dup h>> 0 = [ "h must be nonzero in dfridr" throw ] when ;
+ dup h>> 0 = [ "h must be nonzero in dfridr" throw ] when ;
+
: init-a ( state -- state ) ntab [ ntab <float-array> ] replicate >>a ;
: init-hh ( state -- state ) dup h>> >>hh ;
: init-err ( state -- state ) big >>err ;
! If error is decreased, save the improved answer
: error-decreased? ( state -- state ? ) [ ] [ errt>> ] [ err>> ] tri <= ;
+
: save-improved-answer ( state -- state )
- dup err>> >>errt
- dup a[j][i] >>ans ;
+ dup err>> >>errt
+ dup a[j][i] >>ans ;
! If higher order is worse by a significant factor SAFE, then quit early.
: check-safe ( state -- state )
- dup
- [ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ] [ err>> safe * ] bi >=
- [ t >>done ]
- when ;
+ dup [ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ]
+ [ err>> safe * ] bi >= [ t >>done ] when ;
+
: x+hh ( state -- val ) [ x>> ] [ hh>> ] bi + ;
: x-hh ( state -- val ) [ x>> ] [ hh>> ] bi - ;
+
: limit-approx ( state -- val )
- [
- [ [ x+hh ] [ func>> ] bi call ]
- [ [ x-hh ] [ func>> ] bi call ]
- bi -
- ]
- [ hh>> 2.0 * ]
- bi / ;
+ [
+ [ [ x+hh ] [ func>> ] bi call ]
+ [ [ x-hh ] [ func>> ] bi call ] bi -
+ ] [ hh>> 2.0 * ] bi / ;
+
: a[0][0]! ( state -- state )
- { [ ] [ limit-approx ] [ drop 0 ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+ { [ ] [ limit-approx ] [ drop 0 ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+
: a[0][i]! ( state -- state )
- { [ ] [ limit-approx ] [ i>> ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+ { [ ] [ limit-approx ] [ i>> ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+
: a[j-1][i]*fac ( state -- val ) [ a[j-1][i] ] [ fac>> ] bi * ;
+
: new-a[j][i] ( state -- val )
- [ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ]
- [ fac>> 1.0 - ]
- bi / ;
+ [ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ]
+ [ fac>> 1.0 - ] bi / ;
+
: a[j][i]! ( state -- state )
- { [ ] [ new-a[j][i] ] [ i>> ] [ j>> ] [ a>> ] } cleave nth set-nth ;
+ { [ ] [ new-a[j][i] ] [ i>> ] [ j>> ] [ a>> ] } cleave nth set-nth ;
: update-errt ( state -- state )
- dup
- [ [ a[j][i] ] [ a[j-1][i] ] bi - abs ]
- [ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ]
- bi max
- >>errt ;
+ dup [ [ a[j][i] ] [ a[j-1][i] ] bi - abs ]
+ [ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ] bi max >>errt ;
: not-done? ( state -- state ? ) dup done>> not ;
: derive ( state -- state )
- init-a
- check-h
- init-hh
- a[0][0]!
- init-err
- 1 ntab [a,b)
- [
- >>i
- not-done?
- [
- update-hh
- a[0][i]!
- reset-fac
- 1 over i>> [a,b]
- [
- >>j
- a[j][i]!
- update-fac
- update-errt
- error-decreased? [ save-improved-answer ] when
- ]
- each
- check-safe
- ]
- when
- ]
- each ;
+ init-a
+ check-h
+ init-hh
+ a[0][0]!
+ init-err
+ 1 ntab [a,b) [
+ >>i not-done? [
+ update-hh
+ a[0][i]!
+ reset-fac
+ 1 over i>> [a,b] [
+ >>j
+ a[j][i]!
+ update-fac
+ update-errt
+ error-decreased? [ save-improved-answer ] when
+ ] each check-safe
+ ] when
+ ] each ;
: derivative-state ( x func h err -- state )
state new
! h should be small enough to give the correct sgn(f'(x))
! err is the max tolerance of gain in error for a single iteration-
: (derivative) ( x func h err -- ans error )
- derivative-state
- derive
- [ ans>> ]
- [ errt>> ]
- bi ;
+ derivative-state derive [ ans>> ] [ errt>> ] bi ;
-: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ;
+: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ;
: derivative-func ( func -- der ) [ derivative ] curry ;
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: bit-arrays kernel lists.lazy math math.functions math.primes.list
- math.ranges sequences accessors ;
+USING: accessors bit-arrays fry kernel lists.lazy math math.functions
+ math.primes.list math.ranges sequences ;
IN: math.erato
<PRIVATE
TUPLE: erato limit bits latest ;
: ind ( n -- i )
- 2/ 1- ; inline
+ 2/ 1- ; inline
: is-prime ( n limit -- bool )
- [ ind ] [ bits>> ] bi* nth ; inline
+ [ ind ] [ bits>> ] bi* nth ; inline
: indices ( n erato -- range )
- limit>> ind over 3 * ind swap rot <range> ;
+ limit>> ind over 3 * ind spin <range> ;
: mark-multiples ( n erato -- )
- over sq over limit>> <=
- [ [ indices ] keep bits>> [ f -rot set-nth ] curry each ] [ 2drop ] if ;
+ 2dup [ sq ] [ limit>> ] bi* <= [
+ [ indices ] keep bits>> '[ _ f -rot set-nth ] each
+ ] [ 2drop ] if ;
: <erato> ( n -- erato )
- dup ind 1+ <bit-array> 1 over set-bits erato boa ;
+ dup ind 1+ <bit-array> dup set-bits 1 erato boa ;
: next-prime ( erato -- prime/f )
- [ 2 + ] change-latest [ latest>> ] keep
- 2dup limit>> <=
- [
- 2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if
- ] [
- 2drop f
- ] if ;
+ [ 2 + ] change-latest [ latest>> ] keep
+ 2dup limit>> <= [
+ 2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if
+ ] [
+ 2drop f
+ ] if ;
PRIVATE>
: lerato ( n -- lazy-list )
- dup 1000003 < [
- 0 primes-under-million seq>list swap [ <= ] curry lwhile
- ] [
- <erato> 2 [ drop next-prime ] with lfrom-by [ ] lwhile
- ] if ;
+ dup 1000003 < [
+ 0 primes-under-million seq>list swap '[ _ <= ] lwhile
+ ] [
+ <erato> 2 [ drop next-prime ] with lfrom-by [ ] lwhile
+ ] if ;
-Sieve of Eratosthene
+Sieve of Eratosthenes
+++ /dev/null
-Hans Schmid
+++ /dev/null
-! Fast Fourier Transform, copyright (C) 2007 Hans Schmid
-! http://dressguardmeister.blogspot.com/2007/01/fft.html
-USING: arrays sequences math math.vectors math.constants
-math.functions kernel splitting grouping columns ;
-IN: math.fft
-
-: n^v ( n v -- w ) [ ^ ] with map ;
-: even ( seq -- seq ) 2 group 0 <column> ;
-: odd ( seq -- seq ) 2 group 1 <column> ;
-DEFER: fft
-: two ( seq -- seq ) fft 2 v/n dup append ;
-: omega ( n -- n' ) recip -2 pi i* * * exp ;
-: twiddle ( seq -- seq ) dup length dup omega swap n^v v* ;
-: (fft) ( seq -- seq ) dup odd two twiddle swap even two v+ ;
-: fft ( seq -- seq ) dup length 1 = [ (fft) ] unless ;
+++ /dev/null
-Fast fourier transform
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
+! Copyright (C) 2008 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel grouping sequences shuffle
math math.functions math.statistics math.vectors ;
-
IN: math.finance
<PRIVATE
-: weighted ( x y a -- z )
- tuck [ * ] [ 1 swap - * ] 2bi* + ;
+: weighted ( x y a -- z )
+ tuck [ * ] [ 1- neg * ] 2bi* + ;
-: a ( n -- a )
- 1 + 2 swap / ;
+: a ( n -- a )
+ 1+ 2 swap / ;
PRIVATE>
: ema ( seq n -- newseq )
- a swap unclip [ [ dup ] 2dip swap rot weighted ] accumulate 2nip ;
+ a swap unclip [ [ dup ] 2dip spin weighted ] accumulate 2nip ;
: sma ( seq n -- newseq )
clump [ mean ] map ;
rot dup ema [ swap ema ] dip v- ;
: momentum ( seq n -- newseq )
- 2dup tail-slice -rot swap [ length ] keep
- [ - neg ] dip swap head-slice v- ;
+ [ tail-slice ] 2keep [ dup length ] dip - head-slice v- ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences ;
+USING: kernel math sequences prettyprint math.parser io
+math.functions ;
IN: math.floating-point
-: float-sign ( float -- ? )
- float>bits -31 shift { 1 -1 } nth ;
+: (double-sign) ( bits -- n ) -63 shift ; inline
+: double-sign ( double -- n ) double>bits (double-sign) ;
-: double-sign ( float -- ? )
- double>bits -63 shift { 1 -1 } nth ;
-
-: float-exponent-bits ( float -- n )
- float>bits -23 shift 8 2^ 1- bitand ;
+: (double-exponent-bits) ( bits -- n )
+ -52 shift 11 2^ 1- bitand ; inline
: double-exponent-bits ( double -- n )
- double>bits -52 shift 11 2^ 1- bitand ;
+ double>bits (double-exponent-bits) ;
-: float-mantissa-bits ( float -- n )
- float>bits 23 2^ 1- bitand ;
+: (double-mantissa-bits) ( double -- n )
+ 52 2^ 1- bitand ;
: double-mantissa-bits ( double -- n )
- double>bits 52 2^ 1- bitand ;
-
-: float-e ( -- float ) 127 ; inline
-: double-e ( -- float ) 1023 ; inline
-
-! : calculate-float ( S M E -- float )
- ! float-e - 2^ * * ; ! bits>float ;
-
-! : calculate-double ( S M E -- frac )
- ! double-e - 2^ swap 52 2^ /f 1+ * * ;
+ double>bits (double-mantissa-bits) ;
+
+: >double ( S E M -- frac )
+ [ 52 shift ] dip
+ [ 63 shift ] 2dip bitor bitor bits>double ;
+
+: >double< ( double -- S E M )
+ double>bits
+ [ (double-sign) ]
+ [ (double-exponent-bits) ]
+ [ (double-mantissa-bits) ] tri ;
+
+: double. ( double -- )
+ double>bits
+ [ (double-sign) .b ]
+ [ (double-exponent-bits) >bin 11 CHAR: 0 pad-left bl print ]
+ [
+ (double-mantissa-bits) >bin 52 CHAR: 0 pad-left
+ 11 [ bl ] times print
+ ] tri ;
-! Copyright © 2008 Reginald Keith Ford II
-! Tools for quickly comparing, transforming, and evaluating mathematical Factor functions
-
+! Copyright (c) 2008 Reginald Keith Ford II.
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel math arrays sequences sequences.lib ;
-IN: math.function-tools
-: difference-func ( func func -- func ) [ bi - ] 2curry ; inline
-: eval ( x func -- pt ) dupd call 2array ; inline
-: eval-inverse ( y func -- pt ) dupd call swap 2array ; inline
-: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ; inline
+IN: math.function-tools
+
+! Tools for quickly comparing, transforming, and evaluating mathematical functions
+
+: difference-func ( func func -- func )
+ [ bi - ] 2curry ; inline
+
+: eval ( x func -- pt )
+ dupd call 2array ; inline
+
+: eval-inverse ( y func -- pt )
+ dupd call swap 2array ; inline
+
+: eval3d ( x y func -- pt )
+ [ 2dup ] dip call 3array ; inline
+++ /dev/null
-! Haar wavelet transform -- http://dmr.ath.cx/gfx/haar/
-USING: sequences math kernel splitting grouping columns ;
-IN: math.haar
-
-: averages ( seq -- seq )
- [ first2 + 2 / ] map ;
-
-: differences ( seq averages -- differences )
- >r 0 <column> r> [ - ] 2map ;
-
-: haar-step ( seq -- differences averages )
- 2 group dup averages [ differences ] keep ;
-
-: haar ( seq -- seq )
- dup length 1 <= [ haar-step haar prepend ] unless ;
+++ /dev/null
-Haar wavelet transform
: cols ( -- n ) 0 nth-row length ;
: skip ( i seq quot -- n )
- over >r find-from drop r> length or ; inline
+ over [ find-from drop ] dip length or ; inline
: first-col ( row# -- n )
#! First non-zero column
0 swap nth-row [ zero? not ] skip ;
: clear-scale ( col# pivot-row i-row -- n )
- >r over r> nth dup zero? [
+ [ over ] dip nth dup zero? [
3drop 0
] [
- >r nth dup zero? r> swap [
+ [ nth dup zero? ] dip swap [
2drop 0
] [
swap / neg
] if ;
: (clear-col) ( col# pivot-row i -- )
- [ [ clear-scale ] 2keep >r n*v r> v+ ] change-row ;
+ [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;
: rows-from ( row# -- slice )
rows dup <slice> ;
: clear-col ( col# row# rows -- )
- >r nth-row r> [ >r 2dup r> (clear-col) ] each 2drop ;
+ [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;
: do-row ( exchange-with row# -- )
[ exchange-rows ] keep
dup 1+ rows-from clear-col ;
: find-row ( row# quot -- i elt )
- >r rows-from r> find ; inline
+ [ rows-from ] dip find ; inline
: pivot-row ( col# row# -- n )
[ dupd nth-row nth zero? not ] find-row 2nip ;
: (echelon) ( col# row# -- )
over cols < over rows < and [
2dup pivot-row [ over do-row 1+ ] when*
- >r 1+ r> (echelon)
+ [ 1+ ] dip (echelon)
] [
2drop
] if ;
] with-matrix ;
: basis-vector ( row col# -- )
- >r clone r>
+ [ clone ] dip
[ swap nth neg recip ] 2keep
[ 0 spin set-nth ] 2keep
- >r n*v r>
+ [ n*v ] dip
matrix get set-nth ;
: nullspace ( matrix -- seq )
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences math math.functions
-math.vectors math.order ;
+USING: arrays kernel math math.order math.vectors sequences ;
IN: math.matrices
! Matrices
: m.v ( m v -- v ) [ v. ] curry map ;
: m. ( m m -- m ) flip [ swap m.v ] curry map ;
-: mmin ( m -- n ) >r 1/0. r> [ [ min ] each ] each ;
-: mmax ( m -- n ) >r -1/0. r> [ [ max ] each ] each ;
+: mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ;
+: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
: mnorm ( m -- n ) dup mmax abs m/n ;
<PRIVATE
TUPLE: positive-even-expected n ;
-: (factor-2s) ( r s -- r s )
- dup even? [ -1 shift >r 1+ r> (factor-2s) ] when ;
-
-: factor-2s ( n -- r s )
- #! factor an integer into s * 2^r
- 0 swap (factor-2s) ;
-
:: (miller-rabin) ( n trials -- ? )
[let | r [ n 1- factor-2s drop ]
s [ n 1- factor-2s nip ]
-! Copyright © 2008 Reginald Keith Ford II
+! Copyright (c) 2008 Reginald Keith Ford II.
! See http://factorcode.org/license.txt for BSD license.
-! Newton's Method of approximating roots
USING: kernel math math.derivatives ;
IN: math.newtons-method
+! Newton's method of approximating roots
+
<PRIVATE
: newton-step ( x function -- x2 )
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences vectors math math.vectors
-namespaces make shuffle splitting sequences.lib math.order ;
+USING: arrays kernel make math math.order math.vectors sequences shuffle
+ splitting vectors ;
IN: math.polynomials
! Polynomials are vectors with the highest powers on the right:
<array> 1 [ * ] accumulate nip ;
<PRIVATE
-: 2pad-left ( p p n -- p p ) 0 [ pad-left swap ] 2keep pad-left swap ;
-: 2pad-right ( p p n -- p p ) 0 [ pad-right swap ] 2keep pad-right swap ;
+
+: 2pad-left ( p p n -- p p ) [ 0 pad-left ] curry bi@ ;
+: 2pad-right ( p p n -- p p ) [ 0 pad-right ] curry bi@ ;
: pextend ( p p -- p p ) 2dup [ length ] bi@ max 2pad-right ;
: pextend-left ( p p -- p p ) 2dup [ length ] bi@ max 2pad-left ;
: unempty ( seq -- seq ) [ { 0 } ] when-empty ;
: 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ;
PRIVATE>
+
: p= ( p p -- ? ) pextend = ;
: ptrim ( p -- p )
! convolution
: pextend-conv ( p p -- p p )
- #! extend to: p_m + p_n - 1
+ #! extend to: p_m + p_n - 1
2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ;
: p* ( p p -- p )
#! Multiply two polynomials.
2unempty pextend-conv <reversed> dup length
[ over length pick <slice> pick [ * ] 2map sum ] map 2nip reverse ;
-
+
: p-sq ( p -- p-sq )
dup p* ;
dup V{ 0 } clone p= [
drop nip
] [
- tuck p/mod >r pick p* swap >r swapd p- r> r> (pgcd)
+ tuck p/mod [ pick p* swap [ swapd p- ] dip ] dip (pgcd)
] if ;
: pgcd ( p p -- p q )
! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel lists math math.primes namespaces make
-sequences ;
+USING: arrays kernel lists make math math.primes sequences ;
IN: math.primes.factors
<PRIVATE
: (count) ( n d -- n' )
[ (factor) ] { } make
- [ [ first ] keep length 2array , ] unless-empty ;
+ [ [ first ] [ length ] bi 2array , ] unless-empty ;
: (unique) ( n d -- n' )
[ (factor) ] { } make
[ first , ] unless-empty ;
: (factors) ( quot list n -- )
- dup 1 > [ swap uncons swap >r pick call r> swap (factors) ] [ 3drop ] if ;
+ dup 1 > [
+ swap uncons swap [ pick call ] dip swap (factors)
+ ] [ 3drop ] if ;
: (decompose) ( n quot -- seq )
[ lprimes rot (factors) ] { } make ;
dup 2 < [
drop 0
] [
- dup unique-factors dup 1 [ 1- * ] reduce swap product / *
+ dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / *
] if ; foldable
! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel lists.lazy math math.functions math.miller-rabin
- math.order math.primes.list math.ranges sequences sorting
- binary-search ;
+USING: binary-search combinators kernel lists.lazy math math.functions
+ math.miller-rabin math.primes.list sequences ;
IN: math.primes
<PRIVATE
} cond ; foldable
: primes-between ( low high -- seq )
- primes-upto
- [ 1- next-prime ] dip
- [ natural-search drop ] keep [ length ] keep <slice> ; foldable
+ primes-upto [ 1- next-prime ] dip
+ [ natural-search drop ] [ length ] [ ] tri <slice> ; foldable
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
: 2q ( u v -- u' u'' v' v'' ) [ first2 ] bi@ ; inline
-: q*a ( u v -- a ) 2q swapd ** >r * r> - ; inline
+: q*a ( u v -- a ) 2q swapd ** [ * ] dip - ; inline
-: q*b ( u v -- b ) 2q >r ** swap r> * + ; inline
+: q*b ( u v -- b ) 2q [ ** swap ] dip * + ; inline
PRIVATE>
: v>q ( v -- q )
#! Turn a 3-vector into a quaternion with real part 0.
- first3 rect> >r 0 swap rect> r> 2array ;
+ first3 rect> [ 0 swap rect> ] dip 2array ;
: q>v ( q -- v )
#! Get the vector part of a quaternion, discarding the real
#! part.
- first2 >r imaginary-part r> >rect 3array ;
+ first2 [ imaginary-part ] dip >rect 3array ;
! Zero
: q0 { 0 0 } ;
! http://www.mathworks.com/access/helpdesk/help/toolbox/aeroblks/euleranglestoquaternions.html
: (euler) ( theta unit -- q )
- >r -0.5 * dup cos c>q swap sin r> n*v v- ;
+ [ -0.5 * dup cos c>q swap sin ] dip n*v v- ;
: euler ( phi theta psi -- q )
[ qi (euler) ] [ qj (euler) ] [ qk (euler) ] tri* q* q* ;
-! Copyright © 2008 Reginald Keith Ford II
+! Copyright (c) 2008 Reginald Keith Ford II.
! See http://factorcode.org/license.txt for BSD license.
-! Secant Method of approximating roots
USING: kernel math math.function-tools math.points math.vectors ;
IN: math.secant-method
+! Secant method of approximating roots
+
<PRIVATE
: secant-solution ( x1 x2 function -- solution )
! Copyright (C) 2008 Doug Coleman, Michael Judge.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.analysis math.functions math.vectors sequences
-sequences.lib sorting ;
+USING: arrays kernel math math.analysis math.functions sequences sequences.lib
+ sorting ;
IN: math.statistics
: mean ( seq -- n )
: median ( seq -- n )
#! middle number if odd, avg of two middle numbers if even
- natural-sort dup length dup even? [
- 1- 2 / swap [ nth ] [ [ 1+ ] dip nth ] 2bi + 2 /
+ natural-sort dup length even? [
+ [ midpoint@ dup 1- 2array ] keep nths mean
] [
- 2 / swap nth
+ [ midpoint@ ] keep nth
] if ;
: range ( seq -- n )
: ste ( seq -- x )
#! standard error, standard deviation / sqrt ( length of sequence )
- dup std swap length sqrt / ;
+ [ std ] [ length ] bi sqrt / ;
: ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
! finds sigma((xi-mean(x))(yi-mean(y))
- 0 [ [ >r pick r> swap - ] bi@ * + ] 2reduce 2nip ;
+ 0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ;
: (r) ( mean(x) mean(y) {x} {y} sx sy -- r )
- * recip >r [ ((r)) ] keep length 1- / r> * ;
+ * recip [ [ ((r)) ] keep length 1- / ] dip * ;
: [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy )
first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ;
SYMBOL: and-needed?
: set-conjunction ( seq -- )
- first { [ dup 100 < ] [ dup 0 > ] } 0&& and-needed? set drop ;
+ first { [ 100 < ] [ 0 > ] } 1&& and-needed? set ;
: negative-text ( n -- str )
0 < "Negative " "" ? ;
--- /dev/null
+Hans Schmid
--- /dev/null
+USING: help.markup help.syntax sequences ;
+IN: math.transforms.fft
+
+HELP: fft
+{ $values { "seq" sequence } { "seq" sequence } }
+{ $description "Fast Fourier transform function." } ;
+
--- /dev/null
+! Copyright (c) 2007 Hans Schmid.
+! See http://factorcode.org/license.txt for BSD license.
+USING: columns grouping kernel math math.constants math.functions math.vectors
+ sequences ;
+IN: math.transforms.fft
+
+! Fast Fourier Transform
+
+<PRIVATE
+
+: n^v ( n v -- w ) [ ^ ] with map ;
+
+: omega ( n -- n' )
+ recip -2 pi i* * * exp ;
+
+: twiddle ( seq -- seq )
+ dup length [ omega ] [ n^v ] bi v* ;
+
+PRIVATE>
+
+DEFER: fft
+
+: two ( seq -- seq )
+ fft 2 v/n dup append ;
+
+<PRIVATE
+
+: even ( seq -- seq ) 2 group 0 <column> ;
+: odd ( seq -- seq ) 2 group 1 <column> ;
+
+: (fft) ( seq -- seq )
+ [ odd two twiddle ] [ even two ] bi v+ ;
+
+PRIVATE>
+
+: fft ( seq -- seq )
+ dup length 1 = [ (fft) ] unless ;
+
--- /dev/null
+Fast fourier transform
--- /dev/null
+Slava Pestov
+Aaron Schaefer
--- /dev/null
+USING: help.markup help.syntax sequences ;
+IN: math.transforms.haar
+
+HELP: haar
+{ $values { "seq" sequence } { "seq" sequence } }
+{ $description "Haar wavelet transform function." }
+{ $notes "The sequence length should be a power of two." }
+{ $examples { $example "USING: math.transforms.haar prettyprint ;" "{ 7 1 6 6 3 -5 4 2 } haar ." "{ 3 2 -1 -2 3 0 4 1 }" } } ;
+
+HELP: rev-haar
+{ $values { "seq" sequence } { "seq" sequence } }
+{ $description "Reverse Haar wavelet transform function." }
+{ $notes "The sequence length should be a power of two." }
+{ $examples { $example "USING: math.transforms.haar prettyprint ;" "{ 3 2 -1 -2 3 0 4 1 } rev-haar ." "{ 7 1 6 6 3 -5 4 2 }" } } ;
+
--- /dev/null
+USING: math.transforms.haar tools.test ;
+IN: math.transforms.haar.tests
+
+[ { 3 2 -1 -2 3 0 4 1 } ] [ { 7 1 6 6 3 -5 4 2 } haar ] unit-test
+[ { 7 1 6 6 3 -5 4 2 } ] [ { 3 2 -1 -2 3 0 4 1 } rev-haar ] unit-test
+
--- /dev/null
+! Copyright (c) 2008 Slava Pestov, Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs columns grouping kernel math math.statistics math.vectors
+ sequences ;
+IN: math.transforms.haar
+
+! Haar Wavelet Transform -- http://dmr.ath.cx/gfx/haar/
+
+<PRIVATE
+
+: averages ( seq -- seq )
+ [ mean ] map ;
+
+: differences ( seq averages -- differences )
+ [ 0 <column> ] dip v- ;
+
+: haar-step ( seq -- differences averages )
+ 2 group dup averages [ differences ] keep ;
+
+: rev-haar-step ( seq -- seq )
+ halves [ v+ ] [ v- ] 2bi zip concat ;
+
+PRIVATE>
+
+: haar ( seq -- seq )
+ dup length 1 <= [ haar-step haar prepend ] unless ;
+
+: rev-haar ( seq -- seq )
+ dup length 2 > [ halves swap rev-haar prepend ] when rev-haar-step ;
+
--- /dev/null
+Haar wavelet transform
--- /dev/null
+Collection of mathematical transforms
! From http://www.ffconsultancy.com/ocaml/maze/index.html
USING: sequences namespaces math math.vectors opengl opengl.gl
-arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render
-math.order math.geometry.rect ;
+opengl.demo-support arrays kernel random ui ui.gadgets
+ui.gadgets.canvas ui.render math.order math.geometry.rect ;
IN: maze
: line-width 8 ;
] if ;
: draw-maze ( n -- )
+ -0.5 0.5 0 glTranslated
line-width 2 - glLineWidth
line-width 2 - glPointSize
1.0 1.0 1.0 1.0 glColor4d
-USING: arrays kernel math opengl opengl.gl opengl.glu ui
-ui.gadgets ui.render ;
+USING: arrays kernel math opengl opengl.gl opengl.glu
+opengl.demo-support ui ui.gadgets ui.render ;
IN: nehe.2
TUPLE: nehe2-gadget < gadget ;
-USING: arrays kernel math opengl opengl.gl opengl.glu ui
-ui.gadgets ui.render ;
+USING: arrays kernel math opengl opengl.gl opengl.glu
+opengl.demo-support ui ui.gadgets ui.render ;
IN: nehe.3
TUPLE: nehe3-gadget < gadget ;
-USING: arrays kernel math opengl opengl.gl opengl.glu ui
-ui.gadgets ui.render threads accessors ;
+USING: arrays kernel math opengl opengl.gl opengl.glu
+opengl.demo-support ui ui.gadgets ui.render threads accessors ;
IN: nehe.4
TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
-USING: arrays kernel math opengl opengl.gl opengl.glu ui\r
-ui.gadgets ui.render threads accessors ;\r
+USING: arrays kernel math opengl opengl.gl opengl.glu\r
+opengl.demo-support ui ui.gadgets ui.render threads accessors ;\r
IN: nehe.5\r
\r
TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;\r
-USING: arrays kernel math math.functions
-math.order math.vectors namespaces opengl opengl.gl sequences ui
-ui.gadgets ui.gestures ui.render accessors ;
+USING: arrays kernel math math.functions math.order math.vectors
+namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures
+ui.render accessors combinators ;
IN: opengl.demo-support
: FOV 2.0 sqrt 1+ ; inline
: drag-yaw-pitch ( -- yaw pitch )
last-drag-rel MOUSE-MOTION-SCALE v*n first2 ;
+: gl-vertex ( point -- )
+ dup length {
+ { 2 [ first2 glVertex2d ] }
+ { 3 [ first3 glVertex3d ] }
+ { 4 [ first4 glVertex4d ] }
+ } case ;
+
+: gl-normal ( normal -- ) first3 glNormal3d ;
+
+: do-state ( mode quot -- )
+ swap glBegin call glEnd ; inline
+
+: 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 ;
+
demo-gadget H{
{ T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-gadget ] }
{ T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-gadget ] }
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
USING: locals math.functions math namespaces
-opengl.gl accessors kernel opengl ui.gadgets
+opengl.gl opengl.demo-support accessors kernel opengl ui.gadgets
fry assocs
destructors sequences ui.render colors ;
IN: opengl.gadgets
-TUPLE: texture-gadget ;
+TUPLE: texture-gadget < gadget ;
GENERIC: render* ( gadget -- texture dims )
GENERIC: cache-key* ( gadget -- key )
: (read-128-ber) ( n -- n )
read1
- [ >r 7 shift r> 7 clear-bit bitor ] keep
+ [ [ 7 shift ] [ 7 clear-bit ] bi* bitor ] keep
7 bit? [ (read-128-ber) ] when ;
: read-128-ber ( -- n )
USING: kernel namespaces arrays sequences grouping
alien.c-types
math math.vectors math.geometry.rect
- opengl.gl opengl.glu opengl generalizations vars
+ opengl.gl opengl.glu opengl.demo-support opengl generalizations vars
combinators.cleave colors ;
IN: processing.shapes
: fill-mode ( -- )
GL_FRONT_AND_BACK GL_FILL glPolygonMode
- fill-color> set-color ;
+ fill-color> gl-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: stroke-mode ( -- )
GL_FRONT_AND_BACK GL_LINE glPolygonMode
- stroke-color> set-color ;
+ stroke-color> gl-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ellipse ( center dim -- )
GL_FRONT_AND_BACK GL_FILL glPolygonMode
- [ stroke-color> set-color gl-ellipse ]
- [ fill-color> set-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
+ [ stroke-color> gl-color gl-ellipse ]
+ [ fill-color> gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: euler001b ( -- answer )
- 1000 [ dup 5 mod swap 3 mod [ zero? ] either? ] filter sum ;
+ 1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
! [ euler001b ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
<PRIVATE
: source-004 ( -- seq )
- 100 999 [a,b] [ 10 mod zero? not ] filter ;
+ 100 999 [a,b] [ 10 mod 0 = not ] filter ;
: max-palindrome ( seq -- palindrome )
natural-sort [ palindrome? ] find-last nip ;
<PRIVATE
: worth-calculating? ( n -- ? )
- 1- 3 { [ mod zero? ] [ / even? ] } 2&& ;
+ 1- 3 { [ mod 0 = ] [ / even? ] } 2&& ;
PRIVATE>
: euler019 ( -- answer )
1901 2000 [a,b] [
12 [1,b] [ 1 zeller-congruence ] with map
- ] map concat [ zero? ] count ;
+ ] map concat [ 0 = ] count ;
! [ euler019 ] 100 ave-time
! 1 ms ave run time - 0.51 SD (100 trials)
PRIVATE>
: euler019a ( -- answer )
- end-date start-date first-days [ zero? ] count ;
+ end-date start-date first-days [ 0 = ] count ;
! [ euler019a ] 100 ave-time
! 17 ms ave run time - 2.13 SD (100 trials)
] reduce-permutations ;
! [ euler043 ] time
-! 104526 ms run / 42735 ms GC time
+! 60280 ms run / 59 ms GC time
! ALTERNATE SOLUTIONS
0 <repetition> >array sieve set ;
: is-prime? ( index -- ? )
- sieve get nth zero? ;
+ sieve get nth 0 = ;
: multiples ( n -- seq )
sieve get length 1- over <range> ;
[ number>digits natural-sort ] map all-equal? ;
: candidate? ( n -- ? )
- { [ odd? ] [ 3 mod zero? ] } 1&& ;
+ { [ odd? ] [ 3 mod 0 = ] } 1&& ;
: next-all-same ( x n -- n )
dup candidate? [
--- /dev/null
+USING: project-euler.071 tools.test ;
+IN: project-euler.071.tests
+
+[ 428570 ] [ euler071 ] unit-test
--- /dev/null
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math project-euler.common sequences ;
+IN: project-euler.071
+
+! http://projecteuler.net/index.php?section=problems&id=71
+
+! DESCRIPTION
+! -----------
+
+! Consider the fraction, n/d, where n and d are positive integers. If n<d and
+! HCF(n,d) = 1, it is called a reduced proper fraction.
+
+! If we list the set of reduced proper fractions for d <= 8 in ascending order of
+! size, we get:
+
+! 1/8, 1/7, 1/6, 1/5, 1/4, 2/7, 1/3, 3/8, 2/5, 3/7, 1/2, 4/7, 3/5, 5/8,
+! 2/3, 5/7, 3/4, 4/5, 5/6, 6/7, 7/8
+
+! It can be seen that 2/5 is the fraction immediately to the left of 3/7.
+
+! By listing the set of reduced proper fractions for d <= 1,000,000 in
+! ascending order of size, find the numerator of the fraction immediately to the
+! left of 3/7.
+
+
+! SOLUTION
+! --------
+
+! Use the properties of a Farey sequence by setting an upper bound of 3/7 and
+! then taking the mediant of that fraction and the one to its immediate left
+! repeatedly until the denominator is as close to 1000000 as possible without
+! going over.
+
+<PRIVATE
+
+: penultimate ( seq -- elt )
+ dup length 2 - swap nth ;
+
+PRIVATE>
+
+: euler071 ( -- answer )
+ 2/5 [ dup denominator 1000000 <= ] [ 3/7 mediant dup ] [ ] produce
+ nip penultimate numerator ;
+
+! [ euler071 ] 100 ave-time
+! 155 ms ave run time - 6.95 SD (100 trials)
+
+MAIN: euler071
--- /dev/null
+USING: project-euler.073 tools.test ;
+IN: project-euler.073.tests
+
+[ 5066251 ] [ euler073 ] unit-test
--- /dev/null
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel locals make math project-euler.common sequences ;
+IN: project-euler.073
+
+! http://projecteuler.net/index.php?section=problems&id=73
+
+! DESCRIPTION
+! -----------
+
+! Consider the fraction, n/d, where n and d are positive integers. If n<d and
+! HCF(n,d) = 1, it is called a reduced proper fraction.
+
+! If we list the set of reduced proper fractions for d <= 8 in ascending order of
+! size, we get:
+
+! 1/8, 1/7, 1/6, 1/5, 1/4, 2/7, 1/3, 3/8, 2/5, 3/7, 1/2, 4/7, 3/5, 5/8,
+! 2/3, 5/7, 3/4, 4/5, 5/6, 6/7, 7/8
+
+! It can be seen that there are 3 fractions between 1/3 and 1/2.
+
+! How many fractions lie between 1/3 and 1/2 in the sorted set of reduced
+! proper fractions for d <= 10,000?
+
+
+! SOLUTION
+! --------
+
+! Use the properties of a Farey sequence and mediants to recursively generate
+! the next fraction until the denominator is as close to 1000000 as possible
+! without going over.
+
+<PRIVATE
+
+:: (euler073) ( limit lo hi -- )
+ [let | m [ lo hi mediant ] |
+ m denominator limit <= [
+ m ,
+ limit lo m (euler073)
+ limit m hi (euler073)
+ ] when
+ ] ;
+
+PRIVATE>
+
+: euler073 ( -- answer )
+ [ 10000 1/3 1/2 (euler073) ] { } make length ;
+
+! [ euler073 ] 10 ave-time
+! 20506 ms ave run time - 937.07 SD (10 trials)
+
+MAIN: euler073
--- /dev/null
+USING: project-euler.203 tools.test ;
+IN: project-euler.203.tests
+
+[ 105 ] [ 8 solve ] unit-test
+[ 34029210557338 ] [ 51 solve ] unit-test
--- /dev/null
+USING: fry kernel math math.primes.factors sequences sets ;
+IN: project-euler.203
+
+: iterate ( n initial quot -- results ) swapd '[ @ dup ] replicate nip ; inline
+: (generate) ( seq -- seq ) [ 0 prefix ] [ 0 suffix ] bi [ + ] 2map ;
+: generate ( n -- seq ) 1- { 1 } [ (generate) ] iterate concat prune ;
+: squarefree ( n -- ? ) factors duplicates empty? ;
+: solve ( n -- n ) generate [ squarefree ] filter sum ;
+: euler203 ( -- n ) 51 solve ;
--- /dev/null
+USING: project-euler.215 project-euler.215.private tools.test ;
+IN: project-euler.215.tests
+
+[ 8 ] [ 9 3 solve ] unit-test
+[ 806844323190414 ] [ euler215 ] unit-test
--- /dev/null
+! Copyright (c) 2008 Eric Mertens.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel locals math ;
+IN: project-euler.215
+
+! http://projecteuler.net/index.php?section=problems&id=215
+
+! DESCRIPTION
+! -----------
+
+! Consider the problem of building a wall out of 2x1 and 3x1 bricks
+! (horizontalvertical dimensions) such that, for extra strength, the gaps
+! between horizontally-adjacent bricks never line up in consecutive layers,
+! i.e. never form a "running crack".
+
+! For example, the following 93 wall is not acceptable due to the running crack
+! shown in red:
+
+! See problem site for image...
+
+! There are eight ways of forming a crack-free 9x3 wall, written W(9,3) = 8.
+
+! Calculate W(32,10).
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+TUPLE: block two three ;
+TUPLE: end { ways integer } ;
+
+C: <block> block
+C: <end> end
+: <failure> 0 <end> ; inline
+: <success> 1 <end> ; inline
+
+: failure? ( t -- ? ) ways>> 0 = ; inline
+
+: choice ( t p q -- t t )
+ [ [ two>> ] [ three>> ] bi ] 2dip bi* ; inline
+
+GENERIC: merge ( t t -- t )
+GENERIC# block-merge 1 ( t t -- t )
+GENERIC# end-merge 1 ( t t -- t )
+M: block merge block-merge ;
+M: end merge end-merge ;
+M: block block-merge [ [ two>> ] bi@ merge ]
+ [ [ three>> ] bi@ merge ] 2bi <block> ;
+M: end block-merge nip ;
+M: block end-merge drop ;
+M: end end-merge [ ways>> ] bi@ + <end> ;
+
+GENERIC: h-1 ( t -- t )
+GENERIC: h0 ( t -- t )
+GENERIC: h1 ( t -- t )
+GENERIC: h2 ( t -- t )
+
+M: block h-1 [ h1 ] [ h2 ] choice merge ;
+M: block h0 drop <failure> ;
+M: block h1 [ [ h1 ] [ h2 ] choice merge ]
+ [ [ h0 ] [ h1 ] choice merge ] bi <block> ;
+M: block h2 [ h1 ] [ h2 ] choice merge <failure> swap <block> ;
+
+M: end h-1 drop <failure> ;
+M: end h0 ;
+M: end h1 drop <failure> ;
+M: end h2 dup failure? [ <failure> <block> ] unless ;
+
+: next-row ( t -- t ) [ h-1 ] [ h1 ] choice swap <block> ;
+
+: first-row ( n -- t )
+ [ <failure> <success> <failure> ] dip
+ 1- [| a b c | b c <block> a b ] times 2drop ;
+
+GENERIC: total ( t -- n )
+M: block total [ total ] dup choice + ;
+M: end total ways>> ;
+
+: solve ( width height -- ways )
+ [ first-row ] dip 1- [ next-row ] times total ;
+
+PRIVATE>
+
+: euler215 ( -- answer )
+ 32 10 solve ;
+
+! [ euler215 ] 100 ave-time
+! 208 ms ave run time - 9.06 SD (100 trials)
+
+MAIN: euler215
! Copyright (c) 2007-2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel make math math.functions math.matrices math.miller-rabin
- math.order math.parser math.primes.factors math.ranges sequences
- sequences.lib sorting strings unicode.case ;
+ math.order math.parser math.primes.factors math.ranges math.ratios
+ sequences sequences.lib sorting strings unicode.case ;
IN: project-euler.common
! A collection of words used by more than one Project Euler solution
! cartesian-product - #4, #27, #29, #32, #33, #43, #44, #56
! log10 - #25, #134
! max-path - #18, #67
+! mediant - #71, #73
! nth-triangle - #12, #42
! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92
! palindrome? - #4, #36, #55
: (sum-divisors) ( n -- sum )
dup sqrt >fixnum [1,b] [
- [ 2dup mod zero? [ 2dup / + , ] [ drop ] if ] each
+ [ 2dup mod 0 = [ 2dup / + , ] [ drop ] if ] each
dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
] { } make sum ;
: log10 ( m -- n )
log 10 log / ;
+: mediant ( a/c b/d -- (a+b)/(c+d) )
+ 2>fraction [ + ] 2bi@ / ;
+
: max-path ( triangle -- n )
dup length 1 > [
2 cut* first2 max-children [ + ] 2map suffix max-path
] if ;
: number>digits ( n -- seq )
- [ dup zero? not ] [ 10 /mod ] [ ] produce reverse nip ;
+ [ dup 0 = not ] [ 10 /mod ] [ ] produce reverse nip ;
: nth-triangle ( n -- n )
dup 1+ * 2 / ;
factor-2s dup [ 1+ ]
[ perfect-square? -1 0 ? ]
[ dup sqrt >fixnum [1,b] ] tri* [
- dupd mod zero? [ [ 2 + ] dip ] when
+ dupd mod 0 = [ [ 2 + ] dip ] when
] each drop * ;
! These transforms are for generating primitive Pythagorean triples
! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: definitions io io.files kernel math math.parser project-euler.ave-time
- sequences vocabs vocabs.loader prettyprint
+USING: definitions io io.files kernel math math.parser
+ prettyprint project-euler.ave-time sequences vocabs vocabs.loader
project-euler.001 project-euler.002 project-euler.003 project-euler.004
project-euler.005 project-euler.006 project-euler.007 project-euler.008
project-euler.009 project-euler.010 project-euler.011 project-euler.012
project-euler.041 project-euler.042 project-euler.043 project-euler.044
project-euler.045 project-euler.046 project-euler.047 project-euler.048
project-euler.052 project-euler.053 project-euler.055 project-euler.056
- project-euler.059 project-euler.067 project-euler.075 project-euler.076
- project-euler.079 project-euler.092 project-euler.097 project-euler.100
- project-euler.116 project-euler.117 project-euler.134 project-euler.148
- project-euler.150 project-euler.151 project-euler.164 project-euler.169
- project-euler.173 project-euler.175 project-euler.186 project-euler.190 ;
+ project-euler.059 project-euler.067 project-euler.071 project-euler.073
+ project-euler.075 project-euler.076 project-euler.079 project-euler.092
+ project-euler.097 project-euler.100 project-euler.116 project-euler.117
+ project-euler.134 project-euler.148 project-euler.150 project-euler.151
+ project-euler.164 project-euler.169 project-euler.173 project-euler.175
+ project-euler.186 project-euler.190 project-euler.215 ;
IN: project-euler
<PRIVATE
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel math ;
IN: roman
{ $values { "n" "an integer" } { "str" "a string" } }
{ $description "Converts a number to its lower-case Roman Numeral equivalent." }
{ $notes "The range for this word is 1-3999, inclusive." }
-{ $see-also >ROMAN roman> } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "56 >roman print"
+ "lvi"
+ }
+} ;
HELP: >ROMAN
{ $values { "n" "an integer" } { "str" "a string" } }
{ $description "Converts a number to its upper-case Roman numeral equivalent." }
{ $notes "The range for this word is 1-3999, inclusive." }
-{ $see-also >roman roman> } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "56 >ROMAN print"
+ "LVI"
+ }
+} ;
HELP: roman>
{ $values { "str" "a string" } { "n" "an integer" } }
{ $description "Converts a Roman numeral to an integer." }
{ $notes "The range for this word is i-mmmcmxcix, inclusive." }
-{ $see-also >roman } ;
+{ $examples
+ { $example "USING: prettyprint roman ;"
+ "\"lvi\" roman> ."
+ "56"
+ }
+} ;
+
+{ >roman >ROMAN roman> } related-words
HELP: roman+
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $description "Adds two Roman numerals." }
-{ $see-also roman- } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "\"v\" \"v\" roman+ print"
+ "x"
+ }
+} ;
HELP: roman-
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $description "Subtracts two Roman numerals." }
-{ $see-also roman+ } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "\"x\" \"v\" roman- print"
+ "v"
+ }
+} ;
+
+{ roman+ roman- } related-words
HELP: roman*
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $description "Multiplies two Roman numerals." }
-{ $see-also roman/i roman/mod } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "\"ii\" \"iii\" roman* print"
+ "vi"
+ }
+} ;
HELP: roman/i
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $description "Computes the integer division of two Roman numerals." }
-{ $see-also roman* roman/mod /i } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "\"v\" \"iv\" roman/i print"
+ "i"
+ }
+} ;
HELP: roman/mod
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } }
{ $description "Computes the quotient and remainder of two Roman numerals." }
-{ $see-also roman* roman/i /mod } ;
+{ $examples
+ { $example "USING: kernel io roman ;"
+ "\"v\" \"iv\" roman/mod [ print ] bi@"
+ "i\ni"
+ }
+} ;
+
+{ roman* roman/i roman/mod } related-words
HELP: ROMAN:
-{ $description "A parsing word that reads the next token and converts it to an integer." } ;
+{ $description "A parsing word that reads the next token and converts it to an integer." }
+{ $examples
+ { $example "USING: prettyprint roman ;"
+ "ROMAN: v ."
+ "5"
+ }
+} ;
+
+ARTICLE: "roman" "Roman numerals"
+"The " { $vocab-link "roman" } " vocabulary can convert numbers to and from the Roman numeral system and can perform arithmetic given Roman numerals as input." $nl
+"A parsing word for literal Roman numerals:"
+{ $subsection POSTPONE: ROMAN: }
+"Converting to Roman numerals:"
+{ $subsection >roman }
+{ $subsection >ROMAN }
+"Converting Roman numerals to integers:"
+{ $subsection roman> }
+"Roman numeral arithmetic:"
+{ $subsection roman+ }
+{ $subsection roman- }
+{ $subsection roman* }
+{ $subsection roman/i }
+{ $subsection roman/mod } ;
+
+ABOUT: "roman"
: enumerate ( seq -- seq' ) <enum> >alist ;
+: splice ( left-seq right-seq seq -- newseq ) swap 3append ;
+
+: surround ( seq left-seq right-seq -- newseq ) swapd 3append ;
+++ /dev/null
-
-USING: kernel namespaces sequences
- io io.files io.launcher io.encodings.ascii
- bake builder.util
- accessors vars
- math.parser ;
-
-IN: size-of
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: headers
-
-: include-headers ( -- seq )
- headers> [ `{ "#include <" , ">" } to-string ] map ;
-
-: size-of-c-program ( type -- lines )
- `{
- "#include <stdio.h>"
- include-headers
- { "main() { printf( \"%i\" , sizeof( " , " ) ) ; }" }
- }
- to-strings ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: c-file ( -- path ) "size-of.c" temp-file ;
-
-: exe ( -- path ) "size-of" temp-file ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: size-of ( type -- n )
- size-of-c-program c-file ascii set-file-lines
-
- { "gcc" c-file "-o" exe } to-strings
- [ "Error compiling generated C program" print ] run-or-bail
-
- exe ascii <process-reader> contents string>number ;
\ No newline at end of file
-USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers
-opengl multiline ui.gadgets accessors sequences ui.render ui math locals
-arrays generalizations combinators opengl.capabilities ui.gadgets.worlds ;
+USING: kernel opengl opengl.demo-support opengl.gl
+opengl.shaders opengl.framebuffers opengl.capabilities multiline
+ui.gadgets accessors sequences ui.render ui math locals arrays
+generalizations combinators ui.gadgets.worlds ;
IN: spheres
STRING: plane-vertex-shader
! : display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
-: display ( -- ) set-projection black set-color draw-nodes draw-springs ;
+: display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+++ /dev/null
-Marc Fauconneau
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Marc Fauconneau.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays help.markup help.syntax io.streams.string
-sequences strings math suffix-arrays.private ;
-IN: suffix-arrays
-
-HELP: >suffix-array
-{ $values
- { "seq" sequence }
- { "array" array } }
-{ $description "Creates a suffix array from the input sequence. Suffix arrays are arrays of slices." } ;
-
-HELP: SA{
-{ $description "Creates a new literal suffix array at parse-time." } ;
-
-HELP: suffixes
-{ $values
- { "string" string }
- { "suffixes-seq" "a sequence of slices" } }
-{ $description "Returns a sequence of tail slices of the input string." } ;
-
-HELP: from-to
-{ $values
- { "index" integer } { "begin" sequence } { "suffix-array" "a suffix-array" }
- { "from/f" "an integer or f" } { "to/f" "an integer or f" } }
-{ $description "Finds the bounds of the suffix array that match the input sequence. A return value of " { $link f } " means that the endpoint is included." }
-{ $notes "Slices are [m,n) and we want (m,n) so we increment." } ;
-
-HELP: query
-{ $values
- { "begin" sequence } { "suffix-array" "a suffix-array" }
- { "matches" array } }
-{ $description "Returns a sequence of sequences from the suffix-array that contain the input sequence. An empty array is returned when there are no matches." } ;
-
-ARTICLE: "suffix-arrays" "Suffix arrays"
-"The " { $vocab-link "suffix-arrays" } " vocabulary implements the suffix array data structure for efficient lookup of subsequences. This suffix array implementation is a sorted array of suffixes. Querying it for matches uses binary search for efficiency." $nl
-
-"Creating new suffix arrays:"
-{ $subsection >suffix-array }
-"Literal suffix arrays:"
-{ $subsection POSTPONE: SA{ }
-"Querying suffix arrays:"
-{ $subsection query } ;
-
-ABOUT: "suffix-arrays"
+++ /dev/null
-! Copyright (C) 2008 Marc Fauconneau.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test suffix-arrays kernel namespaces sequences ;
-IN: suffix-arrays.tests
-
-! built from [ all-words 10 head [ name>> ] map ]
-[ ] [
- {
- "run-tests"
- "must-fail-with"
- "test-all"
- "short-effect"
- "failure"
- "test"
- "<failure>"
- "this-test"
- "(unit-test)"
- "unit-test"
- } >suffix-array "suffix-array" set
-] unit-test
-
-[ t ]
-[ "suffix-array" get "" swap query empty? not ] unit-test
-
-[ { } ]
-[ SA{ } "something" swap query ] unit-test
-
-[ V{ "unit-test" "(unit-test)" } ]
-[ "suffix-array" get "unit-test" swap query ] unit-test
-
-[ t ]
-[ "suffix-array" get "something else" swap query empty? ] unit-test
-
-[ V{ "rofl" } ] [ SA{ "rofl" } "r" swap query ] unit-test
-[ V{ "rofl" } ] [ SA{ "rofl" } "o" swap query ] unit-test
-[ V{ "rofl" } ] [ SA{ "rofl" } "f" swap query ] unit-test
-[ V{ "rofl" } ] [ SA{ "rofl" } "l" swap query ] unit-test
-[ V{ } ] [ SA{ "rofl" } "t" swap query ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Marc Fauconneau.
-! See http://factorcode.org/license.txt for BSD license.
-USING: parser kernel arrays math accessors sequences
-math.vectors math.order sorting binary-search sets assocs fry ;
-IN: suffix-arrays
-
-<PRIVATE
-: suffixes ( string -- suffixes-seq )
- dup length [ tail-slice ] with map ;
-
-: prefix<=> ( begin seq -- <=> )
- [ <=> ] [ swap head? ] 2bi [ drop +eq+ ] when ;
-
-: find-index ( begin suffix-array -- index/f )
- [ prefix<=> ] with search drop ;
-
-: from-to ( index begin suffix-array -- from/f to/f )
- swap '[ _ head? not ]
- [ find-last-from drop dup [ 1+ ] when ]
- [ find-from drop ] 3bi ;
-
-: <funky-slice> ( from/f to/f seq -- slice )
- [
- tuck
- [ drop 0 or ] [ length or ] 2bi*
- [ min ] keep
- ] keep <slice> ; inline
-
-PRIVATE>
-
-: >suffix-array ( seq -- array )
- [ suffixes ] map concat natural-sort ;
-
-: SA{ \ } [ >suffix-array ] parse-literal ; parsing
-
-: query ( begin suffix-array -- matches )
- 2dup find-index dup
- [ -rot [ from-to ] keep <funky-slice> [ seq>> ] map prune ]
- [ 3drop { } ] if ;
+++ /dev/null
-Suffix arrays
+++ /dev/null
-collections
+++ /dev/null
-! Copyright (C) 2008 Marc Fauconneau.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel arrays math accessors sequences math.vectors\r
-math.order sorting binary-search sets assocs fry suffix-arrays ;\r
-IN: suffix-arrays.words\r
-\r
-! to search on word names\r
-\r
-: new-word-sa ( words -- sa )\r
- [ name>> ] map >suffix-array ;\r
-\r
-: name>word-map ( words -- map )\r
- dup [ name>> V{ } clone ] H{ } map>assoc\r
- [ '[ dup name>> _ at push ] each ] keep ;\r
-\r
-: query-word-sa ( map begin sa -- matches ) query '[ _ at ] map concat ;\r
-\r
-! usage example :\r
-! clear all-words 100 head dup name>word-map "test" rot new-word-sa query .\r
USING: combinators io io.files io.streams.string kernel math
math.parser continuations namespaces pack prettyprint sequences
-strings system hexdump io.encodings.binary summary accessors
+strings system tools.hexdump io.encodings.binary summary accessors
io.backend symbols byte-arrays ;
IN: tar
#! OpenGL rendering for tetris
: draw-block ( block -- )
- dup { 1 1 } v+ gl-fill-rect ;
+ [ { 1 1 } gl-fill-rect ] with-translation ;
: draw-piece-blocks ( piece -- )
piece-blocks [ draw-block ] each ;
: draw-piece ( piece -- )
- dup tetromino>> colour>> set-color draw-piece-blocks ;
+ dup tetromino>> colour>> gl-color draw-piece-blocks ;
: draw-next-piece ( piece -- )
dup tetromino>> colour>>
- clone 0.2 >>alpha set-color draw-piece-blocks ;
+ clone 0.2 >>alpha gl-color draw-piece-blocks ;
! TODO: move implementation specific stuff into tetris-board
: (draw-row) ( x y row -- )
>r over r> nth dup
- [ set-color 2array draw-block ] [ 3drop ] if ;
+ [ gl-color 2array draw-block ] [ 3drop ] if ;
: draw-row ( y row -- )
dup length -rot [ (draw-row) ] 2curry each ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test time-server ;
+IN: time-server.tests
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.servers.connection accessors threads
+calendar calendar.format ;
+IN: time-server
+
+: handle-time-client ( -- )
+ now timestamp>rfc822 print ;
+
+: <time-server> ( -- threaded-server )
+ <threaded-server>
+ "time-server" >>name
+ 1234 >>insecure
+ [ handle-time-client ] >>handler ;
+
+: start-time-server ( -- threaded-server )
+ <time-server> [ start-server ] in-thread ;
+
+MAIN: start-time-server
-USING: namespaces debugger io.files bootstrap.image builder.util ;
+USING: namespaces debugger io.files bootstrap.image update.util ;
IN: update.backup
USING: kernel namespaces system io.files bootstrap.image http.client
- builder.util update update.backup ;
+ update update.backup update.util ;
IN: update.latest
USING: kernel system sequences io.files io.launcher bootstrap.image
http.client
- builder.util builder.release.branch ;
+ update.util ;
+
+ ! builder.util builder.release.branch ;
IN: update
--- /dev/null
+
+USING: kernel classes strings quotations words math math.parser arrays
+ combinators.cleave
+ accessors
+ system prettyprint splitting
+ sequences combinators sequences.deep
+ io
+ io.launcher
+ io.encodings.utf8
+ calendar
+ calendar.format ;
+
+IN: update.util
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+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 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cpu- ( -- cpu ) cpu unparse "." split "-" join ;
+
+: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: branch-name ( -- string ) "clean-" platform append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 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 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: datestamp ( -- string )
+ now
+ { year>> month>> day>> hour>> minute>> } <arr>
+ [ pad-00 ] map "-" join ;
</t:form>
</div>
- <t:validation-messages />
+ <t:validation-errors />
</t:chloe>
<p>
<button type="submit" >Update</button>
- <t:validation-messages />
+ <t:validation-errors />
</p>
</t:form>
<p>
<button type="submit" class="link-button link">Create</button>
- <t:validation-messages />
+ <t:validation-errors />
</p>
</t:form>
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; BUG: A double quote character on a commented line will break the
-;; syntax highlighting for that line.
-
(defgroup factor nil
"Factor mode"
:group 'languages)
:type 'hook
:group 'factor)
+(defconst factor--parsing-words
+ '("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
+ "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
+ "DEFER:" "ERROR:" "FORGET:"
+ "GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{"
+ "IN:" "INSTANCE:" "INTERSECTION:"
+ "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:"
+ "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
+ "REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
+ "TUPLE:" "T{" "t\\??" "TYPEDEF:"
+ "UNION:" "USE:" "USING:" "V{" "VAR:" "VARS:" "W{"))
+
+(defconst factor--regex--parsing-words-ext
+ (regexp-opt '("B" "call-next-method" "delimiter" "f" "flushable" "foldable"
+ "initial:" "inline" "parsing" "read-only" "recursive")
+ 'words))
+
(defconst factor-font-lock-keywords
- '(("#!.*$" . font-lock-comment-face)
+ `(("#!.*$" . font-lock-comment-face)
("!( .* )" . font-lock-comment-face)
("^!.*$" . font-lock-comment-face)
(" !.*$" . font-lock-comment-face)
("( .* )" . font-lock-comment-face)
- "BIN:"
- "MAIN:"
- "IN:" "USING:" "TUPLE:" "^C:" "^M:"
- "METHOD:"
- "USE:" "REQUIRE:" "PROVIDE:"
- "REQUIRES:"
- "GENERIC:" "GENERIC#" "SYMBOL:" "PREDICATE:" "VAR:" "VARS:"
- "C-STRUCT:"
- "C-UNION:" "<PRIVATE" "PRIVATE>" "MACRO:" "MACRO::" "DEFER:" "TYPEDEF:"
- "SYMBOLS:"
-))
+ ("\"[^ ][^\"]*\"" . font-lock-string-face)
+ ("\\(P\\|SBUF\\)\"" 1 font-lock-keyword-face)
+ ,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)")
+ '(2 font-lock-keyword-face)))
+ factor--parsing-words)
+ (,factor--regex--parsing-words-ext . font-lock-keyword-face)))
(defun factor-indent-line ()
"Indent current line as Factor code"
(setq comment-start "! ")
(make-local-variable 'font-lock-defaults)
(setq font-lock-defaults
- '(factor-font-lock-keywords nil nil nil nil))
+ '(factor-font-lock-keywords t nil nil nil))
(set-syntax-table factor-mode-syntax-table)
(make-local-variable 'indent-line-function)
(setq indent-line-function 'factor-indent-line)
+++ /dev/null
-Sampo Vuori
+++ /dev/null
-! Cairo "Hello World" demo
-! Copyright (c) 2007 Sampo Vuori
-! License: http://factorcode.org/license.txt
-!
-! This example is an adaptation of the following cairo sample code:
-! http://cairographics.org/samples/text/
-
-
-USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render
- ui.gadgets opengl.gl ;
-
-IN: cairo-demo
-
-
-: make-image-array ( -- array )
- 384 256 4 * * <byte-array> ;
-
-: convert-array-to-surface ( array -- cairo_surface_t )
- CAIRO_FORMAT_ARGB32 384 256 over 4 *
- cairo_image_surface_create_for_data ;
-
-
-TUPLE: cairo-gadget image-array cairo-t ;
-
-M: cairo-gadget draw-gadget* ( gadget -- )
- 0 0 glRasterPos2i
- 1.0 -1.0 glPixelZoom
- >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
- cairo-gadget-image-array glDrawPixels ;
-
-: create-surface ( gadget -- cairo_surface_t )
- make-image-array
- [ swap set-cairo-gadget-image-array ] keep
- convert-array-to-surface ;
-
-: init-cairo ( gadget -- cairo_t )
- create-surface cairo_create ;
-
-M: cairo-gadget pref-dim* drop { 384 256 0 } ;
-
-: draw-hello-world ( gadget -- )
- cairo-gadget-cairo-t
- dup "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD cairo_select_font_face
- dup 90.0 cairo_set_font_size
- dup 10.0 135.0 cairo_move_to
- dup "Hello" cairo_show_text
- dup 70.0 165.0 cairo_move_to
- dup "World" cairo_text_path
- dup 0.5 0.5 1 cairo_set_source_rgb
- dup cairo_fill_preserve
- dup 0 0 0 cairo_set_source_rgb
- dup 2.56 cairo_set_line_width
- dup cairo_stroke
- dup 1 0.2 0.2 0.6 cairo_set_source_rgba
- dup 10.0 135.0 5.12 0 pi 2 * cairo_arc
- dup cairo_close_path
- dup 70.0 165.0 5.12 0 pi 2 * cairo_arc
- cairo_fill ;
-
-M: cairo-gadget graft* ( gadget -- )
- dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
-
-M: cairo-gadget ungraft* ( gadget -- )
- cairo-gadget-cairo-t cairo_destroy ;
-
-: <cairo-gadget> ( -- gadget )
- cairo-gadget construct-gadget ;
-
-: run ( -- )
- [
- <cairo-gadget> "Hello World from Factor!" open-window
- ] with-ui ;
-
-MAIN: run
+++ /dev/null
-Sampo Vuori
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: cairo.ffi kernel accessors sequences
-namespaces fry continuations destructors ;
-IN: cairo
-
-TUPLE: cairo-t alien ;
-C: <cairo-t> cairo-t
-M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
-
-TUPLE: cairo-surface-t alien ;
-C: <cairo-surface-t> cairo-surface-t
-M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
-
-: check-cairo ( cairo_status_t -- )
- dup CAIRO_STATUS_SUCCESS = [ drop ]
- [ cairo_status_to_string "Cairo error: " prepend throw ] if ;
-
-SYMBOL: cairo
-: cr ( -- cairo ) cairo get ;
-
-: (with-cairo) ( cairo-t quot -- )
- >r alien>> cairo r> [ cr cairo_status check-cairo ]
- compose with-variable ; inline
-
-: with-cairo ( cairo quot -- )
- >r <cairo-t> r> [ (with-cairo) ] curry with-disposal ; inline
-
-: (with-surface) ( cairo-surface-t quot -- )
- >r alien>> r> [ cairo_surface_status check-cairo ] bi ; inline
-
-: with-surface ( cairo_surface quot -- )
- >r <cairo-surface-t> r> [ (with-surface) ] curry with-disposal ; inline
-
-: with-cairo-from-surface ( cairo_surface quot -- )
- '[ cairo_create , with-cairo ] with-surface ; inline
+++ /dev/null
-! Copyright (c) 2007 Sampo Vuori
-! Copyright (c) 2008 Matthew Willis
-!
-! Adapted from cairo.h, version 1.5.14
-! License: http://factorcode.org/license.txt
-
-USING: system combinators alien alien.syntax kernel
-alien.c-types accessors sequences arrays ui.gadgets ;
-
-IN: cairo.ffi
-<< "cairo" {
- { [ os winnt? ] [ "libcairo-2.dll" ] }
- { [ os macosx? ] [ "libcairo.dylib" ] }
- { [ os unix? ] [ "libcairo.so.2" ] }
-} cond "cdecl" add-library >>
-
-LIBRARY: cairo
-
-FUNCTION: int cairo_version ( ) ;
-FUNCTION: char* cairo_version_string ( ) ;
-
-TYPEDEF: int cairo_bool_t
-
-! I am leaving these and other void* types as opaque structures
-TYPEDEF: void* cairo_t
-TYPEDEF: void* cairo_surface_t
-
-C-STRUCT: cairo_matrix_t
- { "double" "xx" }
- { "double" "yx" }
- { "double" "xy" }
- { "double" "yy" }
- { "double" "x0" }
- { "double" "y0" } ;
-
-TYPEDEF: void* cairo_pattern_t
-
-TYPEDEF: void* cairo_destroy_func_t
-: cairo-destroy-func ( quot -- callback )
- >r "void" { "void*" } "cdecl" r> alien-callback ; inline
-
-! See cairo.h for details
-C-STRUCT: cairo_user_data_key_t
- { "int" "unused" } ;
-
-TYPEDEF: int cairo_status_t
-C-ENUM:
- CAIRO_STATUS_SUCCESS
- CAIRO_STATUS_NO_MEMORY
- CAIRO_STATUS_INVALID_RESTORE
- CAIRO_STATUS_INVALID_POP_GROUP
- CAIRO_STATUS_NO_CURRENT_POINT
- CAIRO_STATUS_INVALID_MATRIX
- CAIRO_STATUS_INVALID_STATUS
- CAIRO_STATUS_NULL_POINTER
- CAIRO_STATUS_INVALID_STRING
- CAIRO_STATUS_INVALID_PATH_DATA
- CAIRO_STATUS_READ_ERROR
- CAIRO_STATUS_WRITE_ERROR
- CAIRO_STATUS_SURFACE_FINISHED
- CAIRO_STATUS_SURFACE_TYPE_MISMATCH
- CAIRO_STATUS_PATTERN_TYPE_MISMATCH
- CAIRO_STATUS_INVALID_CONTENT
- CAIRO_STATUS_INVALID_FORMAT
- CAIRO_STATUS_INVALID_VISUAL
- CAIRO_STATUS_FILE_NOT_FOUND
- CAIRO_STATUS_INVALID_DASH
- CAIRO_STATUS_INVALID_DSC_COMMENT
- CAIRO_STATUS_INVALID_INDEX
- CAIRO_STATUS_CLIP_NOT_REPRESENTABLE
- CAIRO_STATUS_TEMP_FILE_ERROR
- CAIRO_STATUS_INVALID_STRIDE ;
-
-TYPEDEF: int cairo_content_t
-: CAIRO_CONTENT_COLOR HEX: 1000 ;
-: CAIRO_CONTENT_ALPHA HEX: 2000 ;
-: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ;
-
-TYPEDEF: void* cairo_write_func_t
-: cairo-write-func ( quot -- callback )
- >r "cairo_status_t" { "void*" "uchar*" "int" }
- "cdecl" r> alien-callback ; inline
-
-TYPEDEF: void* cairo_read_func_t
-: cairo-read-func ( quot -- callback )
- >r "cairo_status_t" { "void*" "uchar*" "int" }
- "cdecl" r> alien-callback ; inline
-
-! Functions for manipulating state objects
-FUNCTION: cairo_t*
-cairo_create ( cairo_surface_t* target ) ;
-
-FUNCTION: cairo_t*
-cairo_reference ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_destroy ( cairo_t* cr ) ;
-
-FUNCTION: uint
-cairo_get_reference_count ( cairo_t* cr ) ;
-
-FUNCTION: void*
-cairo_get_user_data ( cairo_t* cr, cairo_user_data_key_t* key ) ;
-
-FUNCTION: cairo_status_t
-cairo_set_user_data ( cairo_t* cr, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
-
-FUNCTION: void
-cairo_save ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_restore ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_push_group ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_push_group_with_content ( cairo_t* cr, cairo_content_t content ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pop_group ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_pop_group_to_source ( cairo_t* cr ) ;
-
-! Modify state
-TYPEDEF: int cairo_operator_t
-C-ENUM:
- CAIRO_OPERATOR_CLEAR
-
- CAIRO_OPERATOR_SOURCE
- CAIRO_OPERATOR_OVER
- CAIRO_OPERATOR_IN
- CAIRO_OPERATOR_OUT
- CAIRO_OPERATOR_ATOP
-
- CAIRO_OPERATOR_DEST
- CAIRO_OPERATOR_DEST_OVER
- CAIRO_OPERATOR_DEST_IN
- CAIRO_OPERATOR_DEST_OUT
- CAIRO_OPERATOR_DEST_ATOP
-
- CAIRO_OPERATOR_XOR
- CAIRO_OPERATOR_ADD
- CAIRO_OPERATOR_SATURATE ;
-
-FUNCTION: void
-cairo_set_operator ( cairo_t* cr, cairo_operator_t op ) ;
-
-FUNCTION: void
-cairo_set_source ( cairo_t* cr, cairo_pattern_t* source ) ;
-
-FUNCTION: void
-cairo_set_source_rgb ( cairo_t* cr, double red, double green, double blue ) ;
-
-FUNCTION: void
-cairo_set_source_rgba ( cairo_t* cr, double red, double green, double blue, double alpha ) ;
-
-FUNCTION: void
-cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, double y ) ;
-
-FUNCTION: void
-cairo_set_tolerance ( cairo_t* cr, double tolerance ) ;
-
-TYPEDEF: int cairo_antialias_t
-C-ENUM:
- CAIRO_ANTIALIAS_DEFAULT
- CAIRO_ANTIALIAS_NONE
- CAIRO_ANTIALIAS_GRAY
- CAIRO_ANTIALIAS_SUBPIXEL ;
-
-FUNCTION: void
-cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ;
-
-TYPEDEF: int cairo_fill_rule_t
-C-ENUM:
- CAIRO_FILL_RULE_WINDING
- CAIRO_FILL_RULE_EVEN_ODD ;
-
-FUNCTION: void
-cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ;
-
-FUNCTION: void
-cairo_set_line_width ( cairo_t* cr, double width ) ;
-
-TYPEDEF: int cairo_line_cap_t
-C-ENUM:
- CAIRO_LINE_CAP_BUTT
- CAIRO_LINE_CAP_ROUND
- CAIRO_LINE_CAP_SQUARE ;
-
-FUNCTION: void
-cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ;
-
-TYPEDEF: int cairo_line_join_t
-C-ENUM:
- CAIRO_LINE_JOIN_MITER
- CAIRO_LINE_JOIN_ROUND
- CAIRO_LINE_JOIN_BEVEL ;
-
-FUNCTION: void
-cairo_set_line_join ( cairo_t* cr, cairo_line_join_t line_join ) ;
-
-FUNCTION: void
-cairo_set_dash ( cairo_t* cr, double* dashes, int num_dashes, double offset ) ;
-
-FUNCTION: void
-cairo_set_miter_limit ( cairo_t* cr, double limit ) ;
-
-FUNCTION: void
-cairo_translate ( cairo_t* cr, double tx, double ty ) ;
-
-FUNCTION: void
-cairo_scale ( cairo_t* cr, double sx, double sy ) ;
-
-FUNCTION: void
-cairo_rotate ( cairo_t* cr, double angle ) ;
-
-FUNCTION: void
-cairo_transform ( cairo_t* cr, cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_set_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_identity_matrix ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_user_to_device ( cairo_t* cr, double* x, double* y ) ;
-
-FUNCTION: void
-cairo_user_to_device_distance ( cairo_t* cr, double* dx, double* dy ) ;
-
-FUNCTION: void
-cairo_device_to_user ( cairo_t* cr, double* x, double* y ) ;
-
-FUNCTION: void
-cairo_device_to_user_distance ( cairo_t* cr, double* dx, double* dy ) ;
-
-! Path creation functions
-FUNCTION: void
-cairo_new_path ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_move_to ( cairo_t* cr, double x, double y ) ;
-
-FUNCTION: void
-cairo_new_sub_path ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_line_to ( cairo_t* cr, double x, double y ) ;
-
-FUNCTION: void
-cairo_curve_to ( cairo_t* cr, double x1, double y1, double x2, double y2, double x3, double y3 ) ;
-
-FUNCTION: void
-cairo_arc ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
-
-FUNCTION: void
-cairo_arc_negative ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
-
-FUNCTION: void
-cairo_rel_move_to ( cairo_t* cr, double dx, double dy ) ;
-
-FUNCTION: void
-cairo_rel_line_to ( cairo_t* cr, double dx, double dy ) ;
-
-FUNCTION: void
-cairo_rel_curve_to ( cairo_t* cr, double dx1, double dy1, double dx2, double dy2, double dx3, double dy3 ) ;
-
-FUNCTION: void
-cairo_rectangle ( cairo_t* cr, double x, double y, double width, double height ) ;
-
-FUNCTION: void
-cairo_close_path ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_path_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
-
-! Painting functions
-FUNCTION: void
-cairo_paint ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_paint_with_alpha ( cairo_t* cr, double alpha ) ;
-
-FUNCTION: void
-cairo_mask ( cairo_t* cr, cairo_pattern_t* pattern ) ;
-
-FUNCTION: void
-cairo_mask_surface ( cairo_t* cr, cairo_surface_t* surface, double surface_x, double surface_y ) ;
-
-FUNCTION: void
-cairo_stroke ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_stroke_preserve ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_fill ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_fill_preserve ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_copy_page ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_show_page ( cairo_t* cr ) ;
-
-! Insideness testing
-FUNCTION: cairo_bool_t
-cairo_in_stroke ( cairo_t* cr, double x, double y ) ;
-
-FUNCTION: cairo_bool_t
-cairo_in_fill ( cairo_t* cr, double x, double y ) ;
-
-! Rectangular extents
-FUNCTION: void
-cairo_stroke_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
-
-FUNCTION: void
-cairo_fill_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
-
-! Clipping
-FUNCTION: void
-cairo_reset_clip ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_clip ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_clip_preserve ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
-
-C-STRUCT: cairo_rectangle_t
- { "double" "x" }
- { "double" "y" }
- { "double" "width" }
- { "double" "height" } ;
-
-C-STRUCT: cairo_rectangle_list_t
- { "cairo_status_t" "status" }
- { "cairo_rectangle_t*" "rectangles" }
- { "int" "num_rectangles" } ;
-
-FUNCTION: cairo_rectangle_list_t*
-cairo_copy_clip_rectangle_list ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_rectangle_list_destroy ( cairo_rectangle_list_t* rectangle_list ) ;
-
-! Font/Text functions
-
-TYPEDEF: void* cairo_scaled_font_t
-
-TYPEDEF: void* cairo_font_face_t
-
-C-STRUCT: cairo_glyph_t
- { "ulong" "index" }
- { "double" "x" }
- { "double" "y" } ;
-
-C-STRUCT: cairo_text_extents_t
- { "double" "x_bearing" }
- { "double" "y_bearing" }
- { "double" "width" }
- { "double" "height" }
- { "double" "x_advance" }
- { "double" "y_advance" } ;
-
-C-STRUCT: cairo_font_extents_t
- { "double" "ascent" }
- { "double" "descent" }
- { "double" "height" }
- { "double" "max_x_advance" }
- { "double" "max_y_advance" } ;
-
-TYPEDEF: int cairo_font_slant_t
-C-ENUM:
- CAIRO_FONT_SLANT_NORMAL
- CAIRO_FONT_SLANT_ITALIC
- CAIRO_FONT_SLANT_OBLIQUE ;
-
-TYPEDEF: int cairo_font_weight_t
-C-ENUM:
- CAIRO_FONT_WEIGHT_NORMAL
- CAIRO_FONT_WEIGHT_BOLD ;
-
-TYPEDEF: int cairo_subpixel_order_t
-C-ENUM:
- CAIRO_SUBPIXEL_ORDER_DEFAULT
- CAIRO_SUBPIXEL_ORDER_RGB
- CAIRO_SUBPIXEL_ORDER_BGR
- CAIRO_SUBPIXEL_ORDER_VRGB
- CAIRO_SUBPIXEL_ORDER_VBGR ;
-
-TYPEDEF: int cairo_hint_style_t
-C-ENUM:
- CAIRO_HINT_STYLE_DEFAULT
- CAIRO_HINT_STYLE_NONE
- CAIRO_HINT_STYLE_SLIGHT
- CAIRO_HINT_STYLE_MEDIUM
- CAIRO_HINT_STYLE_FULL ;
-
-TYPEDEF: int cairo_hint_metrics_t
-C-ENUM:
- CAIRO_HINT_METRICS_DEFAULT
- CAIRO_HINT_METRICS_OFF
- CAIRO_HINT_METRICS_ON ;
-
-TYPEDEF: void* cairo_font_options_t
-
-FUNCTION: cairo_font_options_t*
-cairo_font_options_create ( ) ;
-
-FUNCTION: cairo_font_options_t*
-cairo_font_options_copy ( cairo_font_options_t* original ) ;
-
-FUNCTION: void
-cairo_font_options_destroy ( cairo_font_options_t* options ) ;
-
-FUNCTION: cairo_status_t
-cairo_font_options_status ( cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_font_options_merge ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
-
-FUNCTION: cairo_bool_t
-cairo_font_options_equal ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
-
-FUNCTION: ulong
-cairo_font_options_hash ( cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_font_options_set_antialias ( cairo_font_options_t* options, cairo_antialias_t antialias ) ;
-
-FUNCTION: cairo_antialias_t
-cairo_font_options_get_antialias ( cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_font_options_set_subpixel_order ( cairo_font_options_t* options, cairo_subpixel_order_t subpixel_order ) ;
-
-FUNCTION: cairo_subpixel_order_t
-cairo_font_options_get_subpixel_order ( cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_font_options_set_hint_style ( cairo_font_options_t* options, cairo_hint_style_t hint_style ) ;
-
-FUNCTION: cairo_hint_style_t
-cairo_font_options_get_hint_style ( cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_font_options_set_hint_metrics ( cairo_font_options_t* options, cairo_hint_metrics_t hint_metrics ) ;
-
-FUNCTION: cairo_hint_metrics_t
-cairo_font_options_get_hint_metrics ( cairo_font_options_t* options ) ;
-
-! This interface is for dealing with text as text, not caring about the
-! font object inside the the cairo_t.
-
-FUNCTION: void
-cairo_select_font_face ( cairo_t* cr, char* family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
-
-FUNCTION: void
-cairo_set_font_size ( cairo_t* cr, double size ) ;
-
-FUNCTION: void
-cairo_set_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_get_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_set_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_get_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_set_font_face ( cairo_t* cr, cairo_font_face_t* font_face ) ;
-
-FUNCTION: cairo_font_face_t*
-cairo_get_font_face ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_set_scaled_font ( cairo_t* cr, cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: cairo_scaled_font_t*
-cairo_get_scaled_font ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_show_text ( cairo_t* cr, char* utf8 ) ;
-
-FUNCTION: void
-cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
-
-FUNCTION: void
-cairo_text_path ( cairo_t* cr, char* utf8 ) ;
-
-FUNCTION: void
-cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
-
-FUNCTION: void
-cairo_text_extents ( cairo_t* cr, char* utf8, cairo_text_extents_t* extents ) ;
-
-FUNCTION: void
-cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
-
-FUNCTION: void
-cairo_font_extents ( cairo_t* cr, cairo_font_extents_t* extents ) ;
-
-! Generic identifier for a font style
-
-FUNCTION: cairo_font_face_t*
-cairo_font_face_reference ( cairo_font_face_t* font_face ) ;
-
-FUNCTION: void
-cairo_font_face_destroy ( cairo_font_face_t* font_face ) ;
-
-FUNCTION: uint
-cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ;
-
-FUNCTION: cairo_status_t
-cairo_font_face_status ( cairo_font_face_t* font_face ) ;
-
-TYPEDEF: int cairo_font_type_t
-C-ENUM:
- CAIRO_FONT_TYPE_TOY
- CAIRO_FONT_TYPE_FT
- CAIRO_FONT_TYPE_WIN32
- CAIRO_FONT_TYPE_QUARTZ ;
-
-FUNCTION: cairo_font_type_t
-cairo_font_face_get_type ( cairo_font_face_t* font_face ) ;
-
-FUNCTION: void*
-cairo_font_face_get_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key ) ;
-
-FUNCTION: cairo_status_t
-cairo_font_face_set_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
-
-! Portable interface to general font features.
-
-FUNCTION: cairo_scaled_font_t*
-cairo_scaled_font_create ( cairo_font_face_t* font_face, cairo_matrix_t* font_matrix, cairo_matrix_t* ctm, cairo_font_options_t* options ) ;
-
-FUNCTION: cairo_scaled_font_t*
-cairo_scaled_font_reference ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: void
-cairo_scaled_font_destroy ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: uint
-cairo_scaled_font_get_reference_count ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: cairo_status_t
-cairo_scaled_font_status ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: cairo_font_type_t
-cairo_scaled_font_get_type ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: void*
-cairo_scaled_font_get_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key ) ;
-
-FUNCTION: cairo_status_t
-cairo_scaled_font_set_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
-
-FUNCTION: void
-cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ;
-
-FUNCTION: void
-cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, char* utf8, cairo_text_extents_t* extents ) ;
-
-FUNCTION: void
-cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
-
-FUNCTION: cairo_font_face_t*
-cairo_scaled_font_get_font_face ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: void
-cairo_scaled_font_get_font_matrix ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* font_matrix ) ;
-
-FUNCTION: void
-cairo_scaled_font_get_ctm ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* ctm ) ;
-
-FUNCTION: void
-cairo_scaled_font_get_font_options ( cairo_scaled_font_t* scaled_font, cairo_font_options_t* options ) ;
-
-! Query functions
-
-FUNCTION: cairo_operator_t
-cairo_get_operator ( cairo_t* cr ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_get_source ( cairo_t* cr ) ;
-
-FUNCTION: double
-cairo_get_tolerance ( cairo_t* cr ) ;
-
-FUNCTION: cairo_antialias_t
-cairo_get_antialias ( cairo_t* cr ) ;
-
-FUNCTION: cairo_bool_t
-cairo_has_current_point ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_get_current_point ( cairo_t* cr, double* x, double* y ) ;
-
-FUNCTION: cairo_fill_rule_t
-cairo_get_fill_rule ( cairo_t* cr ) ;
-
-FUNCTION: double
-cairo_get_line_width ( cairo_t* cr ) ;
-
-FUNCTION: cairo_line_cap_t
-cairo_get_line_cap ( cairo_t* cr ) ;
-
-FUNCTION: cairo_line_join_t
-cairo_get_line_join ( cairo_t* cr ) ;
-
-FUNCTION: double
-cairo_get_miter_limit ( cairo_t* cr ) ;
-
-FUNCTION: int
-cairo_get_dash_count ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_get_dash ( cairo_t* cr, double* dashes, double* offset ) ;
-
-FUNCTION: void
-cairo_get_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_get_target ( cairo_t* cr ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_get_group_target ( cairo_t* cr ) ;
-
-TYPEDEF: int cairo_path_data_type_t
-C-ENUM:
- CAIRO_PATH_MOVE_TO
- CAIRO_PATH_LINE_TO
- CAIRO_PATH_CURVE_TO
- CAIRO_PATH_CLOSE_PATH ;
-
-! NEED TO DO UNION HERE
-C-STRUCT: cairo_path_data_t-point
- { "double" "x" }
- { "double" "y" } ;
-
-C-STRUCT: cairo_path_data_t-header
- { "cairo_path_data_type_t" "type" }
- { "int" "length" } ;
-
-C-UNION: cairo_path_data_t "cairo_path_data_t-point" "cairo_path_data_t-header" ;
-
-C-STRUCT: cairo_path_t
- { "cairo_status_t" "status" }
- { "cairo_path_data_t*" "data" }
- { "int" "num_data" } ;
-
-FUNCTION: cairo_path_t*
-cairo_copy_path ( cairo_t* cr ) ;
-
-FUNCTION: cairo_path_t*
-cairo_copy_path_flat ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_append_path ( cairo_t* cr, cairo_path_t* path ) ;
-
-FUNCTION: void
-cairo_path_destroy ( cairo_path_t* path ) ;
-
-! Error status queries
-
-FUNCTION: cairo_status_t
-cairo_status ( cairo_t* cr ) ;
-
-FUNCTION: char*
-cairo_status_to_string ( cairo_status_t status ) ;
-
-! Surface manipulation
-
-FUNCTION: cairo_surface_t*
-cairo_surface_create_similar ( cairo_surface_t* other, cairo_content_t content, int width, int height ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_surface_reference ( cairo_surface_t* surface ) ;
-
-FUNCTION: void
-cairo_surface_finish ( cairo_surface_t* surface ) ;
-
-FUNCTION: void
-cairo_surface_destroy ( cairo_surface_t* surface ) ;
-
-FUNCTION: uint
-cairo_surface_get_reference_count ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_status_t
-cairo_surface_status ( cairo_surface_t* surface ) ;
-
-TYPEDEF: int cairo_surface_type_t
-C-ENUM:
- CAIRO_SURFACE_TYPE_IMAGE
- CAIRO_SURFACE_TYPE_PDF
- CAIRO_SURFACE_TYPE_PS
- CAIRO_SURFACE_TYPE_XLIB
- CAIRO_SURFACE_TYPE_XCB
- CAIRO_SURFACE_TYPE_GLITZ
- CAIRO_SURFACE_TYPE_QUARTZ
- CAIRO_SURFACE_TYPE_WIN32
- CAIRO_SURFACE_TYPE_BEOS
- CAIRO_SURFACE_TYPE_DIRECTFB
- CAIRO_SURFACE_TYPE_SVG
- CAIRO_SURFACE_TYPE_OS2
- CAIRO_SURFACE_TYPE_WIN32_PRINTING
- CAIRO_SURFACE_TYPE_QUARTZ_IMAGE ;
-
-FUNCTION: cairo_surface_type_t
-cairo_surface_get_type ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_content_t
-cairo_surface_get_content ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_status_t
-cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ;
-
-FUNCTION: cairo_status_t
-cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
-
-FUNCTION: void*
-cairo_surface_get_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key ) ;
-
-FUNCTION: cairo_status_t
-cairo_surface_set_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
-
-FUNCTION: void
-cairo_surface_get_font_options ( cairo_surface_t* surface, cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_surface_flush ( cairo_surface_t* surface ) ;
-
-FUNCTION: void
-cairo_surface_mark_dirty ( cairo_surface_t* surface ) ;
-
-FUNCTION: void
-cairo_surface_mark_dirty_rectangle ( cairo_surface_t* surface, int x, int y, int width, int height ) ;
-
-FUNCTION: void
-cairo_surface_set_device_offset ( cairo_surface_t* surface, double x_offset, double y_offset ) ;
-
-FUNCTION: void
-cairo_surface_get_device_offset ( cairo_surface_t* surface, double* x_offset, double* y_offset ) ;
-
-FUNCTION: void
-cairo_surface_set_fallback_resolution ( cairo_surface_t* surface, double x_pixels_per_inch, double y_pixels_per_inch ) ;
-
-FUNCTION: void
-cairo_surface_copy_page ( cairo_surface_t* surface ) ;
-
-FUNCTION: void
-cairo_surface_show_page ( cairo_surface_t* surface ) ;
-
-! Image-surface functions
-
-TYPEDEF: int cairo_format_t
-C-ENUM:
- CAIRO_FORMAT_ARGB32
- CAIRO_FORMAT_RGB24
- CAIRO_FORMAT_A8
- CAIRO_FORMAT_A1
- CAIRO_FORMAT_RGB16_565 ;
-
-FUNCTION: cairo_surface_t*
-cairo_image_surface_create ( cairo_format_t format, int width, int height ) ;
-
-FUNCTION: int
-cairo_format_stride_for_width ( cairo_format_t format, int width ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_image_surface_create_for_data ( uchar* data, cairo_format_t format, int width, int height, int stride ) ;
-
-FUNCTION: uchar*
-cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_format_t
-cairo_image_surface_get_format ( cairo_surface_t* surface ) ;
-
-FUNCTION: int
-cairo_image_surface_get_width ( cairo_surface_t* surface ) ;
-
-FUNCTION: int
-cairo_image_surface_get_height ( cairo_surface_t* surface ) ;
-
-FUNCTION: int
-cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_image_surface_create_from_png ( char* filename ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;
-
-! Pattern creation functions
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_create_rgb ( double red, double green, double blue ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_create_rgba ( double red, double green, double blue, double alpha ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_create_for_surface ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_create_linear ( double x0, double y0, double x1, double y1 ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_create_radial ( double cx0, double cy0, double radius0, double cx1, double cy1, double radius1 ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_reference ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: void
-cairo_pattern_destroy ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: uint
-cairo_pattern_get_reference_count ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_status ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: void*
-cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
-
-TYPEDEF: int cairo_pattern_type_t
-C-ENUM:
- CAIRO_PATTERN_TYPE_SOLID
- CAIRO_PATTERN_TYPE_SURFACE
- CAIRO_PATTERN_TYPE_LINEAR
- CAIRO_PATTERN_TYPE_RADIA ;
-
-FUNCTION: cairo_pattern_type_t
-cairo_pattern_get_type ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: void
-cairo_pattern_add_color_stop_rgb ( cairo_pattern_t* pattern, double offset, double red, double green, double blue ) ;
-
-FUNCTION: void
-cairo_pattern_add_color_stop_rgba ( cairo_pattern_t* pattern, double offset, double red, double green, double blue, double alpha ) ;
-
-FUNCTION: void
-cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
-
-TYPEDEF: int cairo_extend_t
-C-ENUM:
- CAIRO_EXTEND_NONE
- CAIRO_EXTEND_REPEAT
- CAIRO_EXTEND_REFLECT
- CAIRO_EXTEND_PAD ;
-
-FUNCTION: void
-cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ;
-
-FUNCTION: cairo_extend_t
-cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ;
-
-TYPEDEF: int cairo_filter_t
-C-ENUM:
- CAIRO_FILTER_FAST
- CAIRO_FILTER_GOOD
- CAIRO_FILTER_BEST
- CAIRO_FILTER_NEAREST
- CAIRO_FILTER_BILINEAR
- CAIRO_FILTER_GAUSSIAN ;
-
-FUNCTION: void
-cairo_pattern_set_filter ( cairo_pattern_t* pattern, cairo_filter_t filter ) ;
-
-FUNCTION: cairo_filter_t
-cairo_pattern_get_filter ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_color_stop_count ( cairo_pattern_t* pattern, int* count ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_linear_points ( cairo_pattern_t* pattern, double* x0, double* y0, double* x1, double* y1 ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_radial_circles ( cairo_pattern_t* pattern, double* x0, double* y0, double* r0, double* x1, double* y1, double* r1 ) ;
-
-! Matrix functions
-
-FUNCTION: void
-cairo_matrix_init ( cairo_matrix_t* matrix, double xx, double yx, double xy, double yy, double x0, double y0 ) ;
-
-FUNCTION: void
-cairo_matrix_init_identity ( cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_matrix_init_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
-
-FUNCTION: void
-cairo_matrix_init_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
-
-FUNCTION: void
-cairo_matrix_init_rotate ( cairo_matrix_t* matrix, double radians ) ;
-
-FUNCTION: void
-cairo_matrix_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
-
-FUNCTION: void
-cairo_matrix_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
-
-FUNCTION: void
-cairo_matrix_rotate ( cairo_matrix_t* matrix, double radians ) ;
-
-FUNCTION: cairo_status_t
-cairo_matrix_invert ( cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_matrix_multiply ( cairo_matrix_t* result, cairo_matrix_t* a, cairo_matrix_t* b ) ;
-
-FUNCTION: void
-cairo_matrix_transform_distance ( cairo_matrix_t* matrix, double* dx, double* dy ) ;
-
-FUNCTION: void
-cairo_matrix_transform_point ( cairo_matrix_t* matrix, double* x, double* y ) ;
-
-! Functions to be used while debugging (not intended for use in production code)
-FUNCTION: void
-cairo_debug_reset_static_data ( ) ;
+++ /dev/null
-! Copyright (C) 2008 Matthew Willis.
-! See http://factorcode.org/license.txt for BSD license.
-USING: sequences math opengl.gadgets kernel
-byte-arrays cairo.ffi cairo io.backend
-ui.gadgets accessors opengl.gl
-arrays ;
-
-IN: cairo.gadgets
-
-: width>stride ( width -- stride ) 4 * ;
-
-: copy-cairo ( dim quot -- byte-array )
- >r first2 over width>stride
- [ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
- [ cairo_image_surface_create_for_data ] 3bi
- r> with-cairo-from-surface ; inline
-
-TUPLE: cairo-gadget < texture-gadget dim quot ;
-
-: <cairo-gadget> ( dim quot -- gadget )
- cairo-gadget construct-gadget
- swap >>quot
- swap >>dim ;
-
-M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ;
-
-: render-cairo ( dim quot -- bytes format )
- >r 2^-bounds r> copy-cairo GL_BGRA ; inline
-
-! M: cairo-gadget render*
-! [ dim>> dup ] [ quot>> ] bi
-! render-cairo render-bytes* ;
-
-! maybe also texture>png
-! : cairo>png ( gadget path -- )
-! >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
-! [ height>> ] tri over width>stride
-! cairo_image_surface_create_for_data
-! r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
-
-: copy-surface ( surface -- )
- cr swap 0 0 cairo_set_source_surface
- cr cairo_paint ;
-
-TUPLE: png-gadget < texture-gadget path ;
-: <png> ( path -- gadget )
- png-gadget construct-gadget
- swap >>path ;
-
-M: png-gadget render*
- path>> normalize-path cairo_image_surface_create_from_png
- [ cairo_image_surface_get_width ]
- [ cairo_image_surface_get_height 2array dup 2^-bounds ]
- [ [ copy-surface ] curry copy-cairo ] tri
- GL_BGRA render-bytes* ;
-
-M: png-gadget cache-key* path>> ;
+++ /dev/null
-! Copyright (C) 2008 Matthew Willis
-! See http://factorcode.org/license.txt for BSD license.
-!
-! these samples are a subset of the samples on
-! http://cairographics.org/samples/
-USING: cairo cairo.ffi locals math.constants math
-io.backend kernel alien.c-types libc namespaces ;
-
-IN: cairo.samples
-
-:: arc ( -- )
- [let | xc [ 128.0 ]
- yc [ 128.0 ]
- radius [ 100.0 ]
- angle1 [ pi 1/4 * ]
- angle2 [ pi ] |
- cr 10.0 cairo_set_line_width
- cr xc yc radius angle1 angle2 cairo_arc
- cr cairo_stroke
-
- ! draw helping lines
- cr 1 0.2 0.2 0.6 cairo_set_source_rgba
- cr 6.0 cairo_set_line_width
-
- cr xc yc 10.0 0 2 pi * cairo_arc
- cr cairo_fill
-
- cr xc yc radius angle1 angle1 cairo_arc
- cr xc yc cairo_line_to
- cr xc yc radius angle2 angle2 cairo_arc
- cr xc yc cairo_line_to
- cr cairo_stroke
- ] ;
-
-: clip ( -- )
- cr 128 128 76.8 0 2 pi * cairo_arc
- cr cairo_clip
- cr cairo_new_path
-
- cr 0 0 256 256 cairo_rectangle
- cr cairo_fill
- cr 0 1 0 cairo_set_source_rgb
- cr 0 0 cairo_move_to
- cr 256 256 cairo_line_to
- cr 256 0 cairo_move_to
- cr 0 256 cairo_line_to
- cr 10 cairo_set_line_width
- cr cairo_stroke ;
-
-:: clip-image ( -- )
- [let* | png [ "resource:misc/icons/Factor_128x128.png"
- normalize-path cairo_image_surface_create_from_png ]
- w [ png cairo_image_surface_get_width ]
- h [ png cairo_image_surface_get_height ] |
- cr 128 128 76.8 0 2 pi * cairo_arc
- cr cairo_clip
- cr cairo_new_path
-
- cr 192.0 w / 192.0 h / cairo_scale
- cr png 32 32 cairo_set_source_surface
- cr cairo_paint
- png cairo_surface_destroy
- ] ;
-
-:: dash ( -- )
- [let | dashes [ { 50 10 10 10 } >c-double-array ]
- ndash [ 4 ] |
- cr dashes ndash -50 cairo_set_dash
- cr 10 cairo_set_line_width
- cr 128.0 25.6 cairo_move_to
- cr 230.4 230.4 cairo_line_to
- cr -102.4 0 cairo_rel_line_to
- cr 51.2 230.4 51.2 128.0 128.0 128.0 cairo_curve_to
- cr cairo_stroke
- ] ;
-
-:: gradient ( -- )
- [let | pat [ 0 0 0 256 cairo_pattern_create_linear ]
- radial [ 115.2 102.4 25.6 102.4 102.4 128.0
- cairo_pattern_create_radial ] |
- pat 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
- pat 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
- cr 0 0 256 256 cairo_rectangle
- cr pat cairo_set_source
- cr cairo_fill
- pat cairo_pattern_destroy
-
- radial 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
- radial 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
- cr radial cairo_set_source
- cr 128.0 128.0 76.8 0 2 pi * cairo_arc
- cr cairo_fill
- radial cairo_pattern_destroy
- ] ;
-
-: text ( -- )
- cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
- cairo_select_font_face
- cr 50 cairo_set_font_size
- cr 10 135 cairo_move_to
- cr "Hello" cairo_show_text
-
- cr 70 165 cairo_move_to
- cr "factor" cairo_text_path
- cr 0.5 0.5 1 cairo_set_source_rgb
- cr cairo_fill_preserve
- cr 0 0 0 cairo_set_source_rgb
- cr 2.56 cairo_set_line_width
- cr cairo_stroke
-
- ! draw helping lines
- cr 1 0.2 0.2 0.6 cairo_set_source_rgba
- cr 10 135 5.12 0 2 pi * cairo_arc
- cr cairo_close_path
- cr 70 165 5.12 0 2 pi * cairo_arc
- cr cairo_fill ;
-
-: utf8 ( -- )
- cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
- cairo_select_font_face
- cr 50 cairo_set_font_size
- "cairo_text_extents_t" malloc-object
- cr "日本語" pick cairo_text_extents
- cr over
- [ cairo_text_extents_t-width 2 / ]
- [ cairo_text_extents_t-x_bearing ] bi +
- 128 swap - pick
- [ cairo_text_extents_t-height 2 / ]
- [ cairo_text_extents_t-y_bearing ] bi +
- 128 swap - cairo_move_to
- free
- cr "日本語" cairo_show_text
-
- cr 1 0.2 0.2 0.6 cairo_set_source_rgba
- cr 6 cairo_set_line_width
- cr 128 0 cairo_move_to
- cr 0 256 cairo_rel_line_to
- cr 0 128 cairo_move_to
- cr 256 0 cairo_rel_line_to
- cr cairo_stroke ;
-
- USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
- : samples ( -- )
- { arc clip clip-image dash gradient text utf8 }
- [ { 256 256 } swap 1quotation <cairo-gadget> gadget. ] each ;
-
- MAIN: samples
+++ /dev/null
-Cairo graphics library binding
--- /dev/null
+
+USING: kernel namespaces sequences
+ io io.files io.launcher io.encodings.ascii
+ bake builder.util
+ accessors vars
+ math.parser ;
+
+IN: size-of
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: headers
+
+: include-headers ( -- seq )
+ headers> [ `{ "#include <" , ">" } to-string ] map ;
+
+: size-of-c-program ( type -- lines )
+ `{
+ "#include <stdio.h>"
+ include-headers
+ { "main() { printf( \"%i\" , sizeof( " , " ) ) ; }" }
+ }
+ to-strings ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: c-file ( -- path ) "size-of.c" temp-file ;
+
+: exe ( -- path ) "size-of" temp-file ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: size-of ( type -- n )
+ size-of-c-program c-file ascii set-file-lines
+
+ { "gcc" c-file "-o" exe } to-strings
+ [ "Error compiling generated C program" print ] run-or-bail
+
+ exe ascii <process-reader> contents string>number ;
\ No newline at end of file
}
/* make an alien pointing at an offset of another alien */
-DEFINE_PRIMITIVE(displaced_alien)
+void primitive_displaced_alien(void)
{
CELL alien = dpop();
CELL displacement = to_cell(dpop());
/* address of an object representing a C pointer. Explicitly throw an error
if the object is a byte array, as a sanity check. */
-DEFINE_PRIMITIVE(alien_address)
+void primitive_alien_address(void)
{
box_unsigned_cell((CELL)pinned_alien_offset(dpop()));
}
/* define words to read/write values at an alien address */
#define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \
- DEFINE_PRIMITIVE(alien_##name) \
+ void primitive_alien_##name(void) \
{ \
boxer(*(type*)alien_pointer()); \
} \
- DEFINE_PRIMITIVE(set_alien_##name) \
+ void primitive_set_alien_##name(void) \
{ \
type* ptr = alien_pointer(); \
type value = to(dpop()); \
}
/* open a native library and push a handle */
-DEFINE_PRIMITIVE(dlopen)
+void primitive_dlopen(void)
{
CELL path = tag_object(string_to_native_alien(
untag_string(dpop())));
}
/* look up a symbol in a native library */
-DEFINE_PRIMITIVE(dlsym)
+void primitive_dlsym(void)
{
CELL dll = dpop();
REGISTER_ROOT(dll);
}
/* close a native library handle */
-DEFINE_PRIMITIVE(dlclose)
+void primitive_dlclose(void)
{
ffi_dlclose(untag_dll(dpop()));
}
-DEFINE_PRIMITIVE(dll_validp)
+void primitive_dll_validp(void)
{
CELL dll = dpop();
if(dll == F)
CELL allot_alien(CELL delegate, CELL displacement);
-DECLARE_PRIMITIVE(displaced_alien);
-DECLARE_PRIMITIVE(alien_address);
+void primitive_displaced_alien(void);
+void primitive_alien_address(void);
DLLEXPORT void *alien_offset(CELL object);
DLLEXPORT void *unbox_alien(void);
DLLEXPORT void box_alien(void *ptr);
-DECLARE_PRIMITIVE(alien_signed_cell);
-DECLARE_PRIMITIVE(set_alien_signed_cell);
-DECLARE_PRIMITIVE(alien_unsigned_cell);
-DECLARE_PRIMITIVE(set_alien_unsigned_cell);
-DECLARE_PRIMITIVE(alien_signed_8);
-DECLARE_PRIMITIVE(set_alien_signed_8);
-DECLARE_PRIMITIVE(alien_unsigned_8);
-DECLARE_PRIMITIVE(set_alien_unsigned_8);
-DECLARE_PRIMITIVE(alien_signed_4);
-DECLARE_PRIMITIVE(set_alien_signed_4);
-DECLARE_PRIMITIVE(alien_unsigned_4);
-DECLARE_PRIMITIVE(set_alien_unsigned_4);
-DECLARE_PRIMITIVE(alien_signed_2);
-DECLARE_PRIMITIVE(set_alien_signed_2);
-DECLARE_PRIMITIVE(alien_unsigned_2);
-DECLARE_PRIMITIVE(set_alien_unsigned_2);
-DECLARE_PRIMITIVE(alien_signed_1);
-DECLARE_PRIMITIVE(set_alien_signed_1);
-DECLARE_PRIMITIVE(alien_unsigned_1);
-DECLARE_PRIMITIVE(set_alien_unsigned_1);
-DECLARE_PRIMITIVE(alien_float);
-DECLARE_PRIMITIVE(set_alien_float);
-DECLARE_PRIMITIVE(alien_double);
-DECLARE_PRIMITIVE(set_alien_double);
-DECLARE_PRIMITIVE(alien_cell);
-DECLARE_PRIMITIVE(set_alien_cell);
+void primitive_alien_signed_cell(void);
+void primitive_set_alien_signed_cell(void);
+void primitive_alien_unsigned_cell(void);
+void primitive_set_alien_unsigned_cell(void);
+void primitive_alien_signed_8(void);
+void primitive_set_alien_signed_8(void);
+void primitive_alien_unsigned_8(void);
+void primitive_set_alien_unsigned_8(void);
+void primitive_alien_signed_4(void);
+void primitive_set_alien_signed_4(void);
+void primitive_alien_unsigned_4(void);
+void primitive_set_alien_unsigned_4(void);
+void primitive_alien_signed_2(void);
+void primitive_set_alien_signed_2(void);
+void primitive_alien_unsigned_2(void);
+void primitive_set_alien_unsigned_2(void);
+void primitive_alien_signed_1(void);
+void primitive_set_alien_signed_1(void);
+void primitive_alien_unsigned_1(void);
+void primitive_set_alien_unsigned_1(void);
+void primitive_alien_float(void);
+void primitive_set_alien_float(void);
+void primitive_alien_double(void);
+void primitive_set_alien_double(void);
+void primitive_alien_cell(void);
+void primitive_set_alien_cell(void);
DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size);
DLLEXPORT void box_value_struct(void *src, CELL size);
DEFINE_UNTAG(F_DLL,DLL_TYPE,dll)
-DECLARE_PRIMITIVE(dlopen);
-DECLARE_PRIMITIVE(dlsym);
-DECLARE_PRIMITIVE(dlclose);
-DECLARE_PRIMITIVE(dll_validp);
+void primitive_dlopen(void);
+void primitive_dlsym(void);
+void primitive_dlclose(void);
+void primitive_dll_validp(void);
stack_chain->callstack_bottom = callstack_bottom;
}
-F_FASTCALL __attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top)
-{
- stack_chain->callstack_top = callstack_top;
-}
-
void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator)
{
F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1;
return frame + 1;
}
-DEFINE_PRIMITIVE(callstack)
+void primitive_callstack(void)
{
F_STACK_FRAME *top = capture_start();
F_STACK_FRAME *bottom = stack_chain->callstack_bottom;
dpush(tag_object(callstack));
}
-DEFINE_PRIMITIVE(set_callstack)
+void primitive_set_callstack(void)
{
F_CALLSTACK *stack = untag_callstack(dpop());
F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)
{
if(frame->size == 0)
- critical_error("Stack frame has zero size",frame);
+ critical_error("Stack frame has zero size",(CELL)frame);
return (F_STACK_FRAME *)((CELL)frame - frame->size);
}
set_array_nth(array,frame_index++,frame_scan(frame));
}
-DEFINE_PRIMITIVE(callstack_to_array)
+void primitive_callstack_to_array(void)
{
F_CALLSTACK *stack = untag_callstack(dpop());
/* Some primitives implementing a limited form of callstack mutation.
Used by the single stepper. */
-DEFINE_PRIMITIVE(innermost_stack_frame_quot)
+void primitive_innermost_stack_frame_quot(void)
{
F_STACK_FRAME *inner = innermost_stack_frame(
untag_callstack(dpop()));
dpush(frame_executing(inner));
}
-DEFINE_PRIMITIVE(innermost_stack_frame_scan)
+void primitive_innermost_stack_frame_scan(void)
{
F_STACK_FRAME *inner = innermost_stack_frame(
untag_callstack(dpop()));
dpush(frame_scan(inner));
}
-DEFINE_PRIMITIVE(set_innermost_stack_frame_quot)
+void primitive_set_innermost_stack_frame_quot(void)
{
F_CALLSTACK *callstack = untag_callstack(dpop());
F_QUOTATION *quot = untag_quotation(dpop());
F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom);
-F_FASTCALL __attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top);
#define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1)
CELL frame_scan(F_STACK_FRAME *frame);
CELL frame_type(F_STACK_FRAME *frame);
-DECLARE_PRIMITIVE(callstack);
-DECLARE_PRIMITIVE(set_datastack);
-DECLARE_PRIMITIVE(set_retainstack);
-DECLARE_PRIMITIVE(set_callstack);
-DECLARE_PRIMITIVE(callstack_to_array);
-DECLARE_PRIMITIVE(innermost_stack_frame_quot);
-DECLARE_PRIMITIVE(innermost_stack_frame_scan);
-DECLARE_PRIMITIVE(set_innermost_stack_frame_quot);
+void primitive_callstack(void);
+void primitive_set_datastack(void);
+void primitive_set_retainstack(void);
+void primitive_set_callstack(void);
+void primitive_callstack_to_array(void);
+void primitive_innermost_stack_frame_quot(void);
+void primitive_innermost_stack_frame_scan(void);
+void primitive_set_innermost_stack_frame_quot(void);
}
/* Push the free space and total size of the code heap */
-DEFINE_PRIMITIVE(code_room)
+void primitive_code_room(void)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
void dump_heap(F_HEAP *heap);
void compact_code_heap(void);
-DECLARE_PRIMITIVE(code_room);
+void primitive_code_room(void);
case RT_XT:
return (CELL)untag_word(get(CREF(literals_start,REL_ARGUMENT(rel))))->xt;
case RT_HERE:
- return rel->offset + code_start;
+ return rel->offset + code_start + (short)REL_ARGUMENT(rel);
case RT_LABEL:
return code_start + REL_ARGUMENT(rel);
+ case RT_STACK_CHAIN:
+ return (CELL)&stack_chain;
default:
critical_error("Bad rel type",rel->type);
return -1; /* Can't happen */
word->compiledp = F;
}
-DEFINE_PRIMITIVE(modify_code_heap)
+void primitive_modify_code_heap(void)
{
bool rescan_code_heap = to_boolean(dpop());
F_ARRAY *alist = untag_array(dpop());
RT_HERE,
/* a local label */
RT_LABEL,
- /* immeditae literal */
- RT_IMMEDIATE
+ /* immediate literal */
+ RT_IMMEDIATE,
+ /* address of stack_chain var */
+ RT_STACK_CHAIN
} F_RELTYPE;
typedef enum {
CELL compiled_code_format(void);
bool stack_traces_p(void);
-DECLARE_PRIMITIVE(modify_code_heap);
+void primitive_modify_code_heap(void);
#define DS_REG %esi
#define RETURN_REG %eax
+#define NV_TEMP_REG %ebx
+
#define CELL_SIZE 4
#define STACK_PADDING 12
#define PUSH_NONVOLATILE \
push %ebx ; \
+ push %ebp ; \
push %ebp
#define POP_NONVOLATILE \
+ pop %ebp ; \
pop %ebp ; \
pop %ebx
#define CELL_SIZE 8
#define STACK_PADDING 56
+#define NV_TEMP_REG %rbp
+
#ifdef WINDOWS
#define ARG0 %rcx
push %rdi ; \
push %rsi ; \
push %rbx ; \
+ push %rbp ; \
push %rbp
#define POP_NONVOLATILE \
+ pop %rbp ; \
pop %rbp ; \
pop %rbx ; \
pop %rsi ; \
push %rbx ; \
push %rbp ; \
push %r12 ; \
+ push %r13 ; \
push %r13
#define POP_NONVOLATILE \
+ pop %r13 ; \
pop %r13 ; \
pop %r12 ; \
pop %rbp ; \
DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
PUSH_NONVOLATILE
- push ARG0
-
- /* Save stack pointer */
- lea -CELL_SIZE(STACK_REG),ARG0
+ mov ARG0,NV_TEMP_REG
/* Create register shadow area for Win64 */
- sub $32,STACK_REG
+ sub $32,STACK_REG
+
+ /* Save stack pointer */
+ lea -CELL_SIZE(STACK_REG),ARG0
call MANGLE(save_callstack_bottom)
- add $32,STACK_REG
/* Call quot-xt */
- mov (STACK_REG),ARG0
+ mov NV_TEMP_REG,ARG0
call *QUOT_XT_OFFSET(ARG0)
- pop ARG0
+ /* Tear down register shadow area */
+ add $32,STACK_REG
+
POP_NONVOLATILE
ret
}
}
-DEFINE_PRIMITIVE(size)
+void primitive_size(void)
{
box_unsigned_cell(object_size(dpop()));
}
/* Push memory usage statistics in data heap */
-DEFINE_PRIMITIVE(data_room)
+void primitive_data_room(void)
{
F_ARRAY *a = allot_array(ARRAY_TYPE,data_heap->gen_count * 2,F);
int gen;
gc_off = true;
}
-DEFINE_PRIMITIVE(begin_scan)
+void primitive_begin_scan(void)
{
gc();
begin_scan();
}
/* Push object at heap scan cursor and advance; pushes f when done */
-DEFINE_PRIMITIVE(next_object)
+void primitive_next_object(void)
{
dpush(next_object());
}
/* Re-enables GC */
-DEFINE_PRIMITIVE(end_scan)
+void primitive_end_scan(void)
{
gc_off = false;
}
garbage_collection(NURSERY,false,0);
}
-DEFINE_PRIMITIVE(gc)
+void primitive_gc(void)
{
gc();
}
-DEFINE_PRIMITIVE(gc_stats)
+void primitive_gc_stats(void)
{
GROWABLE_ARRAY(stats);
dpush(stats);
}
-DEFINE_PRIMITIVE(gc_reset)
+void primitive_gc_reset(void)
{
gc_reset();
}
-DEFINE_PRIMITIVE(become)
+void primitive_become(void)
{
F_ARRAY *new_objects = untag_array(dpop());
F_ARRAY *old_objects = untag_array(dpop());
void begin_scan(void);
CELL next_object(void);
-DECLARE_PRIMITIVE(data_room);
-DECLARE_PRIMITIVE(size);
-DECLARE_PRIMITIVE(begin_scan);
-DECLARE_PRIMITIVE(next_object);
-DECLARE_PRIMITIVE(end_scan);
+void primitive_data_room(void);
+void primitive_size(void);
+void primitive_begin_scan(void);
+void primitive_next_object(void);
+void primitive_end_scan(void);
void gc(void);
DLLEXPORT void minor_gc(void);
CELL collect_next(CELL scan);
-DECLARE_PRIMITIVE(gc);
-DECLARE_PRIMITIVE(gc_stats);
-DECLARE_PRIMITIVE(gc_reset);
-DECLARE_PRIMITIVE(become);
+void primitive_gc(void);
+void primitive_gc_stats(void);
+void primitive_gc_reset(void);
+void primitive_become(void);
CELL find_all_words(void);
}
}
-DEFINE_PRIMITIVE(die)
+void primitive_die(void)
{
fprintf(stderr,"The die word was called by the library. Unless you called it yourself,\n");
fprintf(stderr,"you have triggered a bug in Factor. Please report.\n");
bool fep_disabled;
-DECLARE_PRIMITIVE(die);
+void primitive_die(void);
signal_error(signal_number,signal_callstack_top);
}
-DEFINE_PRIMITIVE(throw)
+void primitive_throw(void)
{
dpop();
throw_impl(dpop(),stack_chain->callstack_top);
}
-DEFINE_PRIMITIVE(call_clear)
+void primitive_call_clear(void)
{
throw_impl(dpop(),stack_chain->callstack_bottom);
}
/* For testing purposes */
-DEFINE_PRIMITIVE(unimplemented)
+void primitive_unimplemented(void)
{
not_implemented_error();
}
void out_of_memory(void);
void fatal_error(char* msg, CELL tagged);
void critical_error(char* msg, CELL tagged);
-DECLARE_PRIMITIVE(die);
+void primitive_die(void);
void throw_error(CELL error, F_STACK_FRAME *native_stack);
void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack);
void type_error(CELL type, CELL tagged);
void not_implemented_error(void);
-DECLARE_PRIMITIVE(throw);
-DECLARE_PRIMITIVE(call_clear);
+void primitive_throw(void);
+void primitive_call_clear(void);
INLINE void type_check(CELL type, CELL tagged)
{
void divide_by_zero_signal_handler_impl(void);
void misc_signal_handler_impl(void);
-DECLARE_PRIMITIVE(unimplemented);
+void primitive_unimplemented(void);
return true;
}
-DEFINE_PRIMITIVE(save_image)
+void primitive_save_image(void)
{
/* do a full GC to push everything into tenured space */
gc();
gc_off = false;
}
-DEFINE_PRIMITIVE(save_image_and_exit)
+void primitive_save_image_and_exit(void)
{
/* We unbox this before doing anything else. This is the only point
where we might throw an error, so we have to throw an error here since
void init_objects(F_HEADER *h);
bool save_image(const F_CHAR *file);
-DECLARE_PRIMITIVE(save_image);
-DECLARE_PRIMITIVE(save_image_and_exit);
+void primitive_save_image(void);
+void primitive_save_image_and_exit(void);
/* relocation base of currently loaded image's data heap */
CELL data_relocation_base;
general_error(ERROR_IO,error,F,NULL);
}
-DEFINE_PRIMITIVE(fopen)
+void primitive_fopen(void)
{
char *mode = unbox_char_string();
REGISTER_C_STRING(mode);
}
}
-DEFINE_PRIMITIVE(fgetc)
+void primitive_fgetc(void)
{
FILE* file = unbox_alien();
}
}
-DEFINE_PRIMITIVE(fread)
+void primitive_fread(void)
{
FILE* file = unbox_alien();
CELL size = unbox_array_size();
}
}
-DEFINE_PRIMITIVE(fputc)
+void primitive_fputc(void)
{
FILE *file = unbox_alien();
F_FIXNUM ch = to_fixnum(dpop());
}
}
-DEFINE_PRIMITIVE(fwrite)
+void primitive_fwrite(void)
{
FILE *file = unbox_alien();
F_BYTE_ARRAY *text = untag_byte_array(dpop());
}
}
-DEFINE_PRIMITIVE(fflush)
+void primitive_fflush(void)
{
FILE *file = unbox_alien();
for(;;)
}
}
-DEFINE_PRIMITIVE(fclose)
+void primitive_fclose(void)
{
FILE *file = unbox_alien();
for(;;)
int err_no(void);
void clear_err_no(void);
-DECLARE_PRIMITIVE(fopen);
-DECLARE_PRIMITIVE(fgetc);
-DECLARE_PRIMITIVE(fread);
-DECLARE_PRIMITIVE(fputc);
-DECLARE_PRIMITIVE(fwrite);
-DECLARE_PRIMITIVE(fflush);
-DECLARE_PRIMITIVE(fclose);
+void primitive_fopen(void);
+void primitive_fgetc(void);
+void primitive_fread(void);
+void primitive_fputc(void);
+void primitive_fwrite(void);
+void primitive_fflush(void);
+void primitive_fclose(void);
/* Platform specific primitives */
-DECLARE_PRIMITIVE(open_file);
-DECLARE_PRIMITIVE(existsp);
-DECLARE_PRIMITIVE(read_dir);
+void primitive_open_file(void);
+void primitive_existsp(void);
+void primitive_read_dir(void);
return (CELL)to_fixnum(tagged);
}
-DEFINE_PRIMITIVE(bignum_to_fixnum)
+void primitive_bignum_to_fixnum(void)
{
drepl(tag_fixnum(bignum_to_fixnum(untag_object(dpeek()))));
}
-DEFINE_PRIMITIVE(float_to_fixnum)
+void primitive_float_to_fixnum(void)
{
drepl(tag_fixnum(float_to_fixnum(dpeek())));
}
F_FIXNUM y = untag_fixnum_fast(dpop()); \
F_FIXNUM x = untag_fixnum_fast(dpop());
-DEFINE_PRIMITIVE(fixnum_add)
+void primitive_fixnum_add(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x + y);
}
-DEFINE_PRIMITIVE(fixnum_subtract)
+void primitive_fixnum_subtract(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x - y);
/* Multiply two integers, and trap overflow.
Thanks to David Blaikie (The_Vulture from freenode #java) for the hint. */
-DEFINE_PRIMITIVE(fixnum_multiply)
+void primitive_fixnum_multiply(void)
{
POP_FIXNUMS(x,y)
}
}
-DEFINE_PRIMITIVE(fixnum_divint)
+void primitive_fixnum_divint(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x / y);
}
-DEFINE_PRIMITIVE(fixnum_divmod)
+void primitive_fixnum_divmod(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x / y);
* If we're shifting right by n bits, we won't overflow as long as none of the
* high WORD_SIZE-TAG_BITS-n bits are set.
*/
-DEFINE_PRIMITIVE(fixnum_shift)
+void primitive_fixnum_shift(void)
{
POP_FIXNUMS(x,y)
}
/* Bignums */
-DEFINE_PRIMITIVE(fixnum_to_bignum)
+void primitive_fixnum_to_bignum(void)
{
drepl(tag_bignum(fixnum_to_bignum(untag_fixnum_fast(dpeek()))));
}
-DEFINE_PRIMITIVE(float_to_bignum)
+void primitive_float_to_bignum(void)
{
drepl(tag_bignum(float_to_bignum(dpeek())));
}
F_ARRAY *y = untag_object(dpop()); \
F_ARRAY *x = untag_object(dpop());
-DEFINE_PRIMITIVE(bignum_eq)
+void primitive_bignum_eq(void)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_equal_p(x,y));
}
-DEFINE_PRIMITIVE(bignum_add)
+void primitive_bignum_add(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_add(x,y)));
}
-DEFINE_PRIMITIVE(bignum_subtract)
+void primitive_bignum_subtract(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_subtract(x,y)));
}
-DEFINE_PRIMITIVE(bignum_multiply)
+void primitive_bignum_multiply(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_multiply(x,y)));
}
-DEFINE_PRIMITIVE(bignum_divint)
+void primitive_bignum_divint(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_quotient(x,y)));
}
-DEFINE_PRIMITIVE(bignum_divmod)
+void primitive_bignum_divmod(void)
{
F_ARRAY *q, *r;
POP_BIGNUMS(x,y);
dpush(tag_bignum(r));
}
-DEFINE_PRIMITIVE(bignum_mod)
+void primitive_bignum_mod(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_remainder(x,y)));
}
-DEFINE_PRIMITIVE(bignum_and)
+void primitive_bignum_and(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_bitwise_and(x,y)));
}
-DEFINE_PRIMITIVE(bignum_or)
+void primitive_bignum_or(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_bitwise_ior(x,y)));
}
-DEFINE_PRIMITIVE(bignum_xor)
+void primitive_bignum_xor(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_bitwise_xor(x,y)));
}
-DEFINE_PRIMITIVE(bignum_shift)
+void primitive_bignum_shift(void)
{
F_FIXNUM y = to_fixnum(dpop());
F_ARRAY* x = untag_object(dpop());
dpush(tag_bignum(bignum_arithmetic_shift(x,y)));
}
-DEFINE_PRIMITIVE(bignum_less)
+void primitive_bignum_less(void)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) == bignum_comparison_less);
}
-DEFINE_PRIMITIVE(bignum_lesseq)
+void primitive_bignum_lesseq(void)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) != bignum_comparison_greater);
}
-DEFINE_PRIMITIVE(bignum_greater)
+void primitive_bignum_greater(void)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) == bignum_comparison_greater);
}
-DEFINE_PRIMITIVE(bignum_greatereq)
+void primitive_bignum_greatereq(void)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) != bignum_comparison_less);
}
-DEFINE_PRIMITIVE(bignum_not)
+void primitive_bignum_not(void)
{
drepl(tag_bignum(bignum_bitwise_not(untag_object(dpeek()))));
}
-DEFINE_PRIMITIVE(bignum_bitp)
+void primitive_bignum_bitp(void)
{
F_FIXNUM bit = to_fixnum(dpop());
F_ARRAY *x = untag_object(dpop());
box_boolean(bignum_logbitp(bit,x));
}
-DEFINE_PRIMITIVE(bignum_log2)
+void primitive_bignum_log2(void)
{
drepl(tag_bignum(bignum_integer_length(untag_object(dpeek()))));
}
return *(ptr + digit);
}
-DEFINE_PRIMITIVE(byte_array_to_bignum)
+void primitive_byte_array_to_bignum(void)
{
type_check(BYTE_ARRAY_TYPE,dpeek());
CELL n_digits = array_capacity(untag_object(dpeek()));
/* Does not reduce to lowest terms, so should only be used by math
library implementation, to avoid breaking invariants. */
-DEFINE_PRIMITIVE(from_fraction)
+void primitive_from_fraction(void)
{
F_RATIO* ratio = allot_object(RATIO_TYPE,sizeof(F_RATIO));
ratio->denominator = dpop();
}
/* Floats */
-DEFINE_PRIMITIVE(fixnum_to_float)
+void primitive_fixnum_to_float(void)
{
drepl(allot_float(fixnum_to_float(dpeek())));
}
-DEFINE_PRIMITIVE(bignum_to_float)
+void primitive_bignum_to_float(void)
{
drepl(allot_float(bignum_to_float(dpeek())));
}
-DEFINE_PRIMITIVE(str_to_float)
+void primitive_str_to_float(void)
{
char *c_str, *end;
double f;
drepl(allot_float(f));
}
-DEFINE_PRIMITIVE(float_to_str)
+void primitive_float_to_str(void)
{
char tmp[33];
snprintf(tmp,32,"%.16g",untag_float(dpop()));
double y = untag_float_fast(dpop()); \
double x = untag_float_fast(dpop());
-DEFINE_PRIMITIVE(float_eq)
+void primitive_float_eq(void)
{
POP_FLOATS(x,y);
box_boolean(x == y);
}
-DEFINE_PRIMITIVE(float_add)
+void primitive_float_add(void)
{
POP_FLOATS(x,y);
box_double(x + y);
}
-DEFINE_PRIMITIVE(float_subtract)
+void primitive_float_subtract(void)
{
POP_FLOATS(x,y);
box_double(x - y);
}
-DEFINE_PRIMITIVE(float_multiply)
+void primitive_float_multiply(void)
{
POP_FLOATS(x,y);
box_double(x * y);
}
-DEFINE_PRIMITIVE(float_divfloat)
+void primitive_float_divfloat(void)
{
POP_FLOATS(x,y);
box_double(x / y);
}
-DEFINE_PRIMITIVE(float_mod)
+void primitive_float_mod(void)
{
POP_FLOATS(x,y);
box_double(fmod(x,y));
}
-DEFINE_PRIMITIVE(float_less)
+void primitive_float_less(void)
{
POP_FLOATS(x,y);
box_boolean(x < y);
}
-DEFINE_PRIMITIVE(float_lesseq)
+void primitive_float_lesseq(void)
{
POP_FLOATS(x,y);
box_boolean(x <= y);
}
-DEFINE_PRIMITIVE(float_greater)
+void primitive_float_greater(void)
{
POP_FLOATS(x,y);
box_boolean(x > y);
}
-DEFINE_PRIMITIVE(float_greatereq)
+void primitive_float_greatereq(void)
{
POP_FLOATS(x,y);
box_boolean(x >= y);
}
-DEFINE_PRIMITIVE(float_bits)
+void primitive_float_bits(void)
{
box_unsigned_4(float_bits(untag_float(dpop())));
}
-DEFINE_PRIMITIVE(bits_float)
+void primitive_bits_float(void)
{
box_float(bits_float(to_cell(dpop())));
}
-DEFINE_PRIMITIVE(double_bits)
+void primitive_double_bits(void)
{
box_unsigned_8(double_bits(untag_float(dpop())));
}
-DEFINE_PRIMITIVE(bits_double)
+void primitive_bits_double(void)
{
box_double(bits_double(to_unsigned_8(dpop())));
}
/* Complex numbers */
-DEFINE_PRIMITIVE(from_rect)
+void primitive_from_rect(void)
{
F_COMPLEX* complex = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX));
complex->imaginary = dpop();
DLLEXPORT F_FIXNUM to_fixnum(CELL tagged);
DLLEXPORT CELL to_cell(CELL tagged);
-DECLARE_PRIMITIVE(bignum_to_fixnum);
-DECLARE_PRIMITIVE(float_to_fixnum);
+void primitive_bignum_to_fixnum(void);
+void primitive_float_to_fixnum(void);
-DECLARE_PRIMITIVE(fixnum_add);
-DECLARE_PRIMITIVE(fixnum_subtract);
-DECLARE_PRIMITIVE(fixnum_multiply);
-DECLARE_PRIMITIVE(fixnum_divint);
-DECLARE_PRIMITIVE(fixnum_divmod);
-DECLARE_PRIMITIVE(fixnum_shift);
+void primitive_fixnum_add(void);
+void primitive_fixnum_subtract(void);
+void primitive_fixnum_multiply(void);
+void primitive_fixnum_divint(void);
+void primitive_fixnum_divmod(void);
+void primitive_fixnum_shift(void);
CELL bignum_zero;
CELL bignum_pos_one;
return RETAG(bignum,BIGNUM_TYPE);
}
-DECLARE_PRIMITIVE(fixnum_to_bignum);
-DECLARE_PRIMITIVE(float_to_bignum);
-DECLARE_PRIMITIVE(bignum_eq);
-DECLARE_PRIMITIVE(bignum_add);
-DECLARE_PRIMITIVE(bignum_subtract);
-DECLARE_PRIMITIVE(bignum_multiply);
-DECLARE_PRIMITIVE(bignum_divint);
-DECLARE_PRIMITIVE(bignum_divmod);
-DECLARE_PRIMITIVE(bignum_mod);
-DECLARE_PRIMITIVE(bignum_and);
-DECLARE_PRIMITIVE(bignum_or);
-DECLARE_PRIMITIVE(bignum_xor);
-DECLARE_PRIMITIVE(bignum_shift);
-DECLARE_PRIMITIVE(bignum_less);
-DECLARE_PRIMITIVE(bignum_lesseq);
-DECLARE_PRIMITIVE(bignum_greater);
-DECLARE_PRIMITIVE(bignum_greatereq);
-DECLARE_PRIMITIVE(bignum_not);
-DECLARE_PRIMITIVE(bignum_bitp);
-DECLARE_PRIMITIVE(bignum_log2);
-DECLARE_PRIMITIVE(byte_array_to_bignum);
+void primitive_fixnum_to_bignum(void);
+void primitive_float_to_bignum(void);
+void primitive_bignum_eq(void);
+void primitive_bignum_add(void);
+void primitive_bignum_subtract(void);
+void primitive_bignum_multiply(void);
+void primitive_bignum_divint(void);
+void primitive_bignum_divmod(void);
+void primitive_bignum_mod(void);
+void primitive_bignum_and(void);
+void primitive_bignum_or(void);
+void primitive_bignum_xor(void);
+void primitive_bignum_shift(void);
+void primitive_bignum_less(void);
+void primitive_bignum_lesseq(void);
+void primitive_bignum_greater(void);
+void primitive_bignum_greatereq(void);
+void primitive_bignum_not(void);
+void primitive_bignum_bitp(void);
+void primitive_bignum_log2(void);
+void primitive_byte_array_to_bignum(void);
INLINE CELL allot_integer(F_FIXNUM x)
{
CELL unbox_array_size(void);
-DECLARE_PRIMITIVE(from_fraction);
+void primitive_from_fraction(void);
INLINE double untag_float_fast(CELL tagged)
{
DLLEXPORT void box_double(double flo);
DLLEXPORT double to_double(CELL value);
-DECLARE_PRIMITIVE(fixnum_to_float);
-DECLARE_PRIMITIVE(bignum_to_float);
-DECLARE_PRIMITIVE(str_to_float);
-DECLARE_PRIMITIVE(float_to_str);
-DECLARE_PRIMITIVE(float_to_bits);
-
-DECLARE_PRIMITIVE(float_eq);
-DECLARE_PRIMITIVE(float_add);
-DECLARE_PRIMITIVE(float_subtract);
-DECLARE_PRIMITIVE(float_multiply);
-DECLARE_PRIMITIVE(float_divfloat);
-DECLARE_PRIMITIVE(float_mod);
-DECLARE_PRIMITIVE(float_less);
-DECLARE_PRIMITIVE(float_lesseq);
-DECLARE_PRIMITIVE(float_greater);
-DECLARE_PRIMITIVE(float_greatereq);
-
-DECLARE_PRIMITIVE(float_bits);
-DECLARE_PRIMITIVE(bits_float);
-DECLARE_PRIMITIVE(double_bits);
-DECLARE_PRIMITIVE(bits_double);
-
-DECLARE_PRIMITIVE(from_rect);
+void primitive_fixnum_to_float(void);
+void primitive_bignum_to_float(void);
+void primitive_str_to_float(void);
+void primitive_float_to_str(void);
+void primitive_float_to_bits(void);
+
+void primitive_float_eq(void);
+void primitive_float_add(void);
+void primitive_float_subtract(void);
+void primitive_float_multiply(void);
+void primitive_float_divfloat(void);
+void primitive_float_mod(void);
+void primitive_float_less(void);
+void primitive_float_lesseq(void);
+void primitive_float_greater(void);
+void primitive_float_greatereq(void);
+
+void primitive_float_bits(void);
+void primitive_bits_float(void);
+void primitive_double_bits(void);
+void primitive_bits_double(void);
+
+void primitive_from_rect(void);
dll->dll = NULL;
}
-DEFINE_PRIMITIVE(existsp)
+void primitive_existsp(void)
{
struct stat sb;
box_boolean(stat(unbox_char_string(),&sb) >= 0);
return 0; /* unreachable */
}
-DEFINE_PRIMITIVE(os_envs)
+void primitive_os_envs(void)
{
not_implemented_error();
}
return safe_strdup(full_path);
}
-DEFINE_PRIMITIVE(existsp)
+void primitive_existsp(void)
{
BY_HANDLE_FILE_INFORMATION bhfi;
extern void *primitives[];
-
-/* Primitives are called with two parameters, the word itself and the current
-callstack pointer. The DEFINE_PRIMITIVE() macro takes care of boilerplate to
-save the current callstack pointer so that GC and other facilities can proceed
-to inspect Factor stack frames below the primitive's C stack frame.
-
-Usage:
-
-DEFINE_PRIMITIVE(name)
-{
- ... CODE ...
-}
-
-Becomes
-
-F_FASTCALL void primitive_name(CELL word, F_STACK_FRAME *callstack_top)
-{
- save_callstack_top(callstack_top);
- ... CODE ...
-}
-
-On x86, F_FASTCALL expands into a GCC declaration which forces the two
-parameters to be passed in registers. This simplifies the quotation compiler
-and support code in cpu-x86.S.
-
-We do the assignment of stack_chain->callstack_top in a ``noinline'' function
-to inhibit assignment re-ordering. */
-#define DEFINE_PRIMITIVE(name) \
- INLINE void primitive_##name##_impl(void); \
- \
- F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) \
- { \
- save_callstack_top(callstack_top); \
- primitive_##name##_impl(); \
- } \
- \
- INLINE void primitive_##name##_impl(void) \
-
-/* Prototype for header files */
-#define DECLARE_PRIMITIVE(name) \
- F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top)
/* Allocates memory */
void update_word_xt(F_WORD *word)
{
- /* If we just enabled the profiler, reset call count */
if(profiling_p)
{
if(!word->profiling)
iterate_code_heap(relocate_code_block);
}
-DEFINE_PRIMITIVE(profiling)
+void primitive_profiling(void)
{
set_profiling(to_boolean(dpop()));
}
bool profiling_p;
-DECLARE_PRIMITIVE(profiling);
+void primitive_profiling(void);
F_COMPILED *compile_profiling_stub(F_WORD *word);
void update_word_xt(F_WORD *word);
case FIXNUM_TYPE:
if(jit_primitive_call_p(untag_object(array),i))
{
+ EMIT(userenv[JIT_SAVE_STACK],0);
EMIT(userenv[JIT_PRIMITIVE],to_fixnum(obj));
i++;
case FIXNUM_TYPE:
if(jit_primitive_call_p(untag_object(array),i))
{
+ COUNT(userenv[JIT_SAVE_STACK],i);
COUNT(userenv[JIT_PRIMITIVE],i);
i++;
}
/* push a new quotation on the stack */
-DEFINE_PRIMITIVE(array_to_quotation)
+void primitive_array_to_quotation(void)
{
F_QUOTATION *quot = allot_object(QUOTATION_TYPE,sizeof(F_QUOTATION));
quot->array = dpeek();
drepl(tag_object(quot));
}
-DEFINE_PRIMITIVE(quotation_xt)
+void primitive_quotation_xt(void)
{
F_QUOTATION *quot = untag_quotation(dpeek());
drepl(allot_cell((CELL)quot->xt));
void jit_compile(CELL quot, bool relocate);
F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack);
F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset);
-DECLARE_PRIMITIVE(array_to_quotation);
-DECLARE_PRIMITIVE(quotation_xt);
+void primitive_array_to_quotation(void);
+void primitive_quotation_xt(void);
}
}
-DEFINE_PRIMITIVE(datastack)
+void primitive_datastack(void)
{
if(!stack_to_array(ds_bot,ds))
general_error(ERROR_DS_UNDERFLOW,F,F,NULL);
}
-DEFINE_PRIMITIVE(retainstack)
+void primitive_retainstack(void)
{
if(!stack_to_array(rs_bot,rs))
general_error(ERROR_RS_UNDERFLOW,F,F,NULL);
return bottom + depth - CELLS;
}
-DEFINE_PRIMITIVE(set_datastack)
+void primitive_set_datastack(void)
{
ds = array_to_stack(untag_array(dpop()),ds_bot);
}
-DEFINE_PRIMITIVE(set_retainstack)
+void primitive_set_retainstack(void)
{
rs = array_to_stack(untag_array(dpop()),rs_bot);
}
-DEFINE_PRIMITIVE(getenv)
+void primitive_getenv(void)
{
F_FIXNUM e = untag_fixnum_fast(dpeek());
drepl(userenv[e]);
}
-DEFINE_PRIMITIVE(setenv)
+void primitive_setenv(void)
{
F_FIXNUM e = untag_fixnum_fast(dpop());
CELL value = dpop();
userenv[e] = value;
}
-DEFINE_PRIMITIVE(exit)
+void primitive_exit(void)
{
exit(to_fixnum(dpop()));
}
-DEFINE_PRIMITIVE(millis)
+void primitive_millis(void)
{
box_unsigned_8(current_millis());
}
-DEFINE_PRIMITIVE(sleep)
+void primitive_sleep(void)
{
sleep_millis(to_cell(dpop()));
}
-DEFINE_PRIMITIVE(set_slot)
+void primitive_set_slot(void)
{
F_FIXNUM slot = untag_fixnum_fast(dpop());
CELL obj = dpop();
JIT_RETURN,
JIT_PROFILING,
JIT_PUSH_IMMEDIATE,
-
JIT_DECLARE_WORD = 42,
+ JIT_SAVE_STACK,
STACK_TRACES_ENV = 59,
DLLEXPORT void unnest_stacks(void);
void init_stacks(CELL ds_size, CELL rs_size);
-DECLARE_PRIMITIVE(datastack);
-DECLARE_PRIMITIVE(retainstack);
-DECLARE_PRIMITIVE(getenv);
-DECLARE_PRIMITIVE(setenv);
-DECLARE_PRIMITIVE(exit);
-DECLARE_PRIMITIVE(os_env);
-DECLARE_PRIMITIVE(os_envs);
-DECLARE_PRIMITIVE(set_os_env);
-DECLARE_PRIMITIVE(unset_os_env);
-DECLARE_PRIMITIVE(set_os_envs);
-DECLARE_PRIMITIVE(millis);
-DECLARE_PRIMITIVE(sleep);
-DECLARE_PRIMITIVE(set_slot);
+void primitive_datastack(void);
+void primitive_retainstack(void);
+void primitive_getenv(void);
+void primitive_setenv(void);
+void primitive_exit(void);
+void primitive_os_env(void);
+void primitive_os_envs(void);
+void primitive_set_os_env(void);
+void primitive_unset_os_env(void);
+void primitive_set_os_envs(void);
+void primitive_millis(void);
+void primitive_sleep(void);
+void primitive_set_slot(void);
bool stage2;
}
}
-DEFINE_PRIMITIVE(clone)
+void primitive_clone(void)
{
drepl(clone_object(dpeek()));
}
update_word_xt(word);
UNREGISTER_UNTAGGED(word);
+ if(profiling_p)
+ iterate_code_heap_step(word->profiling,relocate_code_block);
+
return word;
}
/* <word> ( name vocabulary -- word ) */
-DEFINE_PRIMITIVE(word)
+void primitive_word(void)
{
CELL vocab = dpop();
CELL name = dpop();
}
/* word-xt ( word -- start end ) */
-DEFINE_PRIMITIVE(word_xt)
+void primitive_word_xt(void)
{
F_WORD *word = untag_word(dpop());
- F_COMPILED *code = word->code;
+ F_COMPILED *code = (profiling_p ? word->profiling : word->code);
dpush(allot_cell((CELL)code + sizeof(F_COMPILED)));
dpush(allot_cell((CELL)code + sizeof(F_COMPILED) + code->code_length));
}
-DEFINE_PRIMITIVE(wrapper)
+void primitive_wrapper(void)
{
F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
wrapper->object = dpeek();
}
/* push a new array on the stack */
-DEFINE_PRIMITIVE(array)
+void primitive_array(void)
{
CELL initial = dpop();
CELL size = unbox_array_size();
return new_array;
}
-DEFINE_PRIMITIVE(resize_array)
+void primitive_resize_array(void)
{
F_ARRAY* array = untag_array(dpop());
CELL capacity = unbox_array_size();
}
/* push a new byte array on the stack */
-DEFINE_PRIMITIVE(byte_array)
+void primitive_byte_array(void)
{
CELL size = unbox_array_size();
dpush(tag_object(allot_byte_array(size)));
return new_array;
}
-DEFINE_PRIMITIVE(resize_byte_array)
+void primitive_resize_byte_array(void)
{
F_BYTE_ARRAY* array = untag_byte_array(dpop());
CELL capacity = unbox_array_size();
return tuple;
}
-DEFINE_PRIMITIVE(tuple)
+void primitive_tuple(void)
{
F_TUPLE_LAYOUT *layout = untag_object(dpop());
F_FIXNUM size = untag_fixnum_fast(layout->size);
}
/* push a new tuple on the stack, filling its slots from the stack */
-DEFINE_PRIMITIVE(tuple_boa)
+void primitive_tuple_boa(void)
{
F_TUPLE_LAYOUT *layout = untag_object(dpop());
F_FIXNUM size = untag_fixnum_fast(layout->size);
return string;
}
-DEFINE_PRIMITIVE(string)
+void primitive_string(void)
{
CELL initial = to_cell(dpop());
CELL length = unbox_array_size();
return new_string;
}
-DEFINE_PRIMITIVE(resize_string)
+void primitive_resize_string(void)
{
F_STRING* string = untag_string(dpop());
CELL capacity = unbox_array_size();
for(i = 0; i < capacity; i++) \
string[i] = string_nth(s,i); \
} \
- DEFINE_PRIMITIVE(type##_string_to_memory) \
+ void primitive_##type##_string_to_memory(void) \
{ \
type *address = unbox_alien(); \
F_STRING *str = untag_string(dpop()); \
STRING_TO_MEMORY(char);
STRING_TO_MEMORY(u16);
-DEFINE_PRIMITIVE(string_nth)
+void primitive_string_nth(void)
{
F_STRING *string = untag_object(dpop());
CELL index = untag_fixnum_fast(dpop());
dpush(tag_fixnum(string_nth(string,index)));
}
-DEFINE_PRIMITIVE(set_string_nth)
+void primitive_set_string_nth(void)
{
F_STRING *string = untag_object(dpop());
CELL index = untag_fixnum_fast(dpop());
CELL allot_array_2(CELL v1, CELL v2);
CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4);
-DECLARE_PRIMITIVE(array);
-DECLARE_PRIMITIVE(tuple);
-DECLARE_PRIMITIVE(tuple_boa);
-DECLARE_PRIMITIVE(tuple_layout);
-DECLARE_PRIMITIVE(byte_array);
-DECLARE_PRIMITIVE(clone);
+void primitive_array(void);
+void primitive_tuple(void);
+void primitive_tuple_boa(void);
+void primitive_tuple_layout(void);
+void primitive_byte_array(void);
+void primitive_clone(void);
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
-DECLARE_PRIMITIVE(resize_array);
-DECLARE_PRIMITIVE(resize_byte_array);
+void primitive_resize_array(void);
+void primitive_resize_byte_array(void);
F_STRING* allot_string_internal(CELL capacity);
F_STRING* allot_string(CELL capacity, CELL fill);
-DECLARE_PRIMITIVE(string);
+void primitive_string(void);
F_STRING *reallot_string(F_STRING *string, CELL capacity, CELL fill);
-DECLARE_PRIMITIVE(resize_string);
+void primitive_resize_string(void);
F_STRING *memory_to_char_string(const char *string, CELL length);
F_STRING *from_char_string(const char *c_string);
CELL string_nth(F_STRING* string, CELL index);
void set_string_nth(F_STRING* string, CELL index, CELL value);
-DECLARE_PRIMITIVE(string_nth);
-DECLARE_PRIMITIVE(set_string_nth);
+void primitive_string_nth(void);
+void primitive_set_string_nth(void);
F_WORD *allot_word(CELL vocab, CELL name);
-DECLARE_PRIMITIVE(word);
-DECLARE_PRIMITIVE(word_xt);
+void primitive_word(void);
+void primitive_word_xt(void);
-DECLARE_PRIMITIVE(wrapper);
+void primitive_wrapper(void);
/* Macros to simulate a vector in C */
#define GROWABLE_ARRAY(result) \
projects / factor.git / commitdiff