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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2009-08-27 19:53:46 -05:00
parent 03fc2a3461 367f024a1b
commit ee418a75d9
67 changed files with 989 additions and 327 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/alien/c-types/c-types.factor
View File

@ -236,9 +236,9 @@ M: c-type stack-size size>> cell align ;
GENERIC: byte-length ( seq -- n ) flushable
M: byte-array byte-length length ;
M: byte-array byte-length length ; inline
M: f byte-length drop 0 ;
M: f byte-length drop 0 ; inline
: c-getter ( name -- quot )
c-type-getter [
@ -281,7 +281,7 @@ M: memory-stream stream-read
] [ [ + ] change-index drop ] 2bi ;
: byte-array>memory ( byte-array base -- )
swap dup byte-length memcpy ;
swap dup byte-length memcpy ; inline
: array-accessor ( type quot -- def )
[

15
basis/alien/structs/structs.factor
View File

@ -3,7 +3,7 @@
USING: accessors arrays assocs generic hashtables kernel kernel.private
math namespaces parser sequences strings words libc fry
alien.c-types alien.structs.fields cpu.architecture math.order
quotations byte-arrays struct-arrays ;
quotations byte-arrays ;
IN: alien.structs
TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
@ -12,16 +12,6 @@ M: struct-type c-type ;
M: struct-type c-type-stack-align? drop f ;
M: struct-type <c-type-array> ( len c-type -- array )
dup c-type-array-constructor
[ execute( len -- array ) ]
[ <struct-array> ] ?if ; inline
M: struct-type <c-type-direct-array> ( alien len c-type -- array )
dup c-type-direct-array-constructor
[ execute( alien len -- array ) ]
[ <direct-struct-array> ] ?if ; inline
: if-value-struct ( ctype true false -- )
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
@ -75,3 +65,6 @@ M: struct-type stack-size
: offset-of ( field struct -- offset )
c-types get at fields>>
[ name>> = ] with find nip offset>> ;
USE: vocabs.loader
"struct-arrays" require

2
basis/bit-arrays/bit-arrays.factor
View File

@ -83,7 +83,7 @@ M: bit-array resize
bit-array boa
dup clean-up ; inline
M: bit-array byte-length length 7 + -3 shift ;
M: bit-array byte-length length 7 + -3 shift ; inline
SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;

0
extra/classes/struct/prettyprint/prettyprint.factor → basis/classes/struct/prettyprint/prettyprint.factor
View File

0
extra/classes/struct/struct-docs.factor → basis/classes/struct/struct-docs.factor
View File

46
extra/classes/struct/struct-tests.factor → basis/classes/struct/struct-tests.factor
View File

@ -4,7 +4,9 @@ alien.structs.fields alien.syntax ascii classes.struct combinators
destructors io.encodings.utf8 io.pathnames io.streams.string
kernel libc literals math multiline namespaces prettyprint
prettyprint.config see sequences specialized-arrays.ushort
system tools.test ;
system tools.test compiler.tree.debugger struct-arrays
classes.tuple.private specialized-arrays.direct.int
compiler.units ;
IN: classes.struct.tests
<<
@ -21,6 +23,11 @@ IN: classes.struct.tests
"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
>>
SYMBOL: struct-test-empty
[ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
[ struct-must-have-slots? ] must-fail-with
STRUCT: struct-test-foo
{ x char }
{ y int initial: 123 }
@ -138,6 +145,25 @@ UNION-STRUCT: struct-test-float-and-bits
}
} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
STRUCT: struct-test-equality-1
{ x int } ;
STRUCT: struct-test-equality-2
{ y int } ;
[ t ] [
[
struct-test-equality-1 <struct> 5 >>x
struct-test-equality-1 malloc-struct &free 5 >>x =
] with-destructors
] unit-test
[ f ] [
[
struct-test-equality-1 <struct> 5 >>x
struct-test-equality-2 malloc-struct &free 5 >>y =
] with-destructors
] unit-test
STRUCT: struct-test-ffi-foo
{ x int }
{ y int } ;
@ -159,3 +185,21 @@ STRUCT: struct-test-array-slots
[ y>> [ 8 3 ] dip set-nth ]
[ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
] unit-test
STRUCT: struct-test-optimization
{ x int[3] } { y int } ;
[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
[ t ] [
[ 3 struct-test-optimization <direct-struct-array> third y>> ]
{ <tuple> <tuple-boa> memory>struct y>> } inlined?
] unit-test
[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
[ t ] [
[ struct-test-optimization memory>struct x>> second ]
{ memory>struct x>> <direct-int-array> <tuple> <tuple-boa> } inlined?
] unit-test
[ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test

51
extra/classes/struct/struct.factor → basis/classes/struct/struct.factor
View File

@ -1,16 +1,19 @@
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.structs alien.structs.fields arrays
byte-arrays classes classes.parser classes.tuple
classes.tuple.parser classes.tuple.private combinators
combinators.smart fry generalizations generic.parser kernel
kernel.private lexer libc macros make math math.order parser
quotations sequences slots slots.private struct-arrays
vectors words ;
USING: accessors alien alien.c-types alien.structs
alien.structs.fields arrays byte-arrays classes classes.parser
classes.tuple classes.tuple.parser classes.tuple.private
combinators combinators.short-circuit combinators.smart fry
generalizations generic.parser kernel kernel.private lexer
libc macros make math math.order parser quotations sequences
slots slots.private struct-arrays vectors words
compiler.tree.propagation.transforms ;
FROM: slots => reader-word writer-word ;
IN: classes.struct
! struct class
ERROR: struct-must-have-slots ;
TUPLE: struct
{ (underlying) c-ptr read-only } ;
@ -18,7 +21,7 @@ TUPLE: struct-slot-spec < slot-spec
c-type ;
PREDICATE: struct-class < tuple-class
\ struct subclass-of? ;
{ [ \ struct subclass-of? ] [ all-slots length 1 = ] } 1&& ;
: struct-slots ( struct -- slots )
"struct-slots" word-prop ;
@ -28,9 +31,18 @@ PREDICATE: struct-class < tuple-class
M: struct >c-ptr
2 slot { c-ptr } declare ; inline
M: struct equal?
{
[ [ class ] bi@ = ]
[ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
} 2&& ;
: memory>struct ( ptr class -- struct )
over c-ptr? [ swap \ c-ptr bad-slot-value ] unless
tuple-layout <tuple> [ 2 set-slot ] keep ;
[ 1array ] dip slots>tuple ;
\ memory>struct [
dup struct-class? [ '[ _ boa ] ] [ drop f ] if
] 1 define-partial-eval
: malloc-struct ( class -- struct )
[ heap-size malloc ] keep memory>struct ; inline
@ -38,8 +50,10 @@ M: struct >c-ptr
: (struct) ( class -- struct )
[ heap-size <byte-array> ] keep memory>struct ; inline
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
: <struct> ( class -- struct )
dup "prototype" word-prop
dup struct-prototype
[ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline
MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
@ -166,7 +180,7 @@ M: struct-class heap-size
! class definition
: struct-prototype ( class -- prototype )
: make-struct-prototype ( class -- prototype )
[ heap-size <byte-array> ]
[ memory>struct ]
[ struct-slots ] tri
@ -188,14 +202,17 @@ M: struct-class heap-size
[ "struct-size" set-word-prop ]
[ "struct-align" set-word-prop ] tri-curry*
[ tri ] 3curry
[ dup struct-prototype "prototype" set-word-prop ]
[ dup make-struct-prototype "prototype" set-word-prop ]
[ (struct-methods) ] tri ;
: check-struct-slots ( slots -- )
[ c-type>> c-type drop ] each ;
: (define-struct-class) ( class slots offsets-quot -- )
[ drop struct f define-tuple-class ]
[
[ struct-must-have-slots ]
[ drop struct f define-tuple-class ] if-empty
]
swap '[
make-slots dup
[ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
@ -236,9 +253,9 @@ SYNTAX: STRUCT:
SYNTAX: UNION-STRUCT:
parse-struct-definition define-union-struct-class ;
SYNTAX: S{
scan-word dup struct-slots parse-tuple-literal-slots parsed ;
USING: vocabs vocabs.loader ;
"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
SYNTAX: S{
scan-word dup struct-slots parse-tuple-literal-slots parsed ;

2
basis/cocoa/application/application.factor
View File

@ -18,7 +18,7 @@ NSApplicationDelegateReplyFailure ;
: NSApp ( -- app ) NSApplication -> sharedApplication ;
: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline
CONSTANT: NSAnyEventMask HEX: ffffffff
FUNCTION: void NSBeep ( ) ;

8
basis/combinators/smart/smart.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors fry generalizations kernel macros math.order
stack-checker math ;
stack-checker math sequences ;
IN: combinators.smart
MACRO: drop-outputs ( quot -- quot' )
@ -42,3 +42,9 @@ MACRO: append-outputs-as ( quot exemplar -- newquot )
MACRO: append-outputs ( quot -- seq )
'[ _ { } append-outputs-as ] ;
MACRO: preserving ( quot -- )
[ infer in>> length ] keep '[ _ ndup @ ] ;
MACRO: smart-if ( pred true false -- )
'[ _ preserving _ _ if ] ; inline

1
basis/compiler/cfg/def-use/def-use.factor
View File

@ -21,6 +21,7 @@ M: ##slot temp-vregs temp>> 1array ;
M: ##set-slot temp-vregs temp>> 1array ;
M: ##string-nth temp-vregs temp>> 1array ;
M: ##set-string-nth-fast temp-vregs temp>> 1array ;
M: ##box-displaced-alien temp-vregs temp>> 1array ;
M: ##compare temp-vregs temp>> 1array ;
M: ##compare-imm temp-vregs temp>> 1array ;
M: ##compare-float temp-vregs temp>> 1array ;

1
basis/compiler/cfg/hats/hats.factor
View File

@ -51,6 +51,7 @@ IN: compiler.cfg.hats
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline
: ^^box-displaced-alien ( base displacement -- dst ) ^^r2 next-vreg ##box-displaced-alien ; inline
: ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline

8
basis/compiler/cfg/instructions/instructions.factor
View File

@ -118,6 +118,7 @@ INSN: ##unbox-float < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary/temp ;
INSN: ##box-float < ##unary/temp ;
INSN: ##box-alien < ##unary/temp ;
INSN: ##box-displaced-alien < ##binary temp ;
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
@ -152,7 +153,12 @@ INSN: ##set-alien-double < ##alien-setter ;
! Memory allocation
INSN: ##allot < ##flushable size class temp ;
UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ;
UNION: ##allocation
##allot
##box-float
##box-alien
##box-displaced-alien
##integer>bignum ;
INSN: ##write-barrier < ##effect card# table ;

17
basis/compiler/cfg/intrinsics/alien/alien.factor
View File

@ -1,11 +1,24 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences alien math classes.algebra fry
locals combinators cpu.architecture compiler.tree.propagation.info
compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
locals combinators combinators.short-circuit cpu.architecture
compiler.tree.propagation.info compiler.cfg.hats
compiler.cfg.stacks compiler.cfg.instructions
compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.alien
: emit-<displaced-alien>? ( node -- ? )
node-input-infos {
[ first class>> fixnum class<= ]
[ second class>> c-ptr class<= ]
} 1&& ;
: emit-<displaced-alien> ( node -- )
dup emit-<displaced-alien>?
[ drop 2inputs [ ^^untag-fixnum ] dip ^^box-displaced-alien ds-push ]
[ emit-primitive ]
if ;
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;

5
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -10,6 +10,8 @@ compiler.cfg.intrinsics.float
compiler.cfg.intrinsics.slots
compiler.cfg.intrinsics.misc
compiler.cfg.comparisons ;
QUALIFIED: alien
QUALIFIED: alien.accessors
QUALIFIED: kernel
QUALIFIED: arrays
QUALIFIED: byte-arrays
@ -20,7 +22,6 @@ QUALIFIED: classes.tuple.private
QUALIFIED: math.private
QUALIFIED: math.integers.private
QUALIFIED: math.libm
QUALIFIED: alien.accessors
IN: compiler.cfg.intrinsics
{
@ -54,6 +55,7 @@ IN: compiler.cfg.intrinsics
byte-arrays:<byte-array>
byte-arrays:(byte-array)
kernel:<wrapper>
alien:<displaced-alien>
alien.accessors:alien-unsigned-1
alien.accessors:set-alien-unsigned-1
alien.accessors:alien-signed-1
@ -144,6 +146,7 @@ IN: compiler.cfg.intrinsics
{ \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
{ \ byte-arrays:(byte-array) [ emit-(byte-array) ] }
{ \ kernel:<wrapper> [ emit-simple-allot ] }
{ \ alien:<displaced-alien> [ emit-<displaced-alien> ] }
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }

3
basis/compiler/cfg/renaming/functor/functor.factor
View File

@ -140,6 +140,9 @@ M: ##string-nth rename-insn-temps
M: ##set-string-nth-fast rename-insn-temps
TEMP-QUOT change-temp drop ;
M: ##box-displaced-alien rename-insn-temps
TEMP-QUOT change-temp drop ;
M: ##compare rename-insn-temps
TEMP-QUOT change-temp drop ;

1
basis/compiler/cfg/representations/preferred/preferred.factor
View File

@ -25,6 +25,7 @@ M: ##slot temp-vreg-reps drop { int-rep } ;
M: ##set-slot temp-vreg-reps drop { int-rep } ;
M: ##string-nth temp-vreg-reps drop { int-rep } ;
M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ;
M: ##box-displaced-alien temp-vreg-reps drop { int-rep } ;
M: ##compare temp-vreg-reps drop { int-rep } ;
M: ##compare-imm temp-vreg-reps drop { int-rep } ;
M: ##compare-float temp-vreg-reps drop { int-rep } ;

23
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit arrays
fry kernel layouts math namespaces sequences cpu.architecture
math.bitwise math.order classes vectors
math.bitwise math.order classes vectors locals make
compiler.cfg
compiler.cfg.registers
compiler.cfg.comparisons
@ -350,3 +350,24 @@ M: ##shl rewrite \ ##shl-imm rewrite-arithmetic ;
M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ;
M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
: box-displaced-alien? ( expr -- ? )
op>> \ ##box-displaced-alien eq? ;
! ##box-displaced-alien f 1 2 3
! ##unbox-any-c-ptr 4 1
! =>
! ##box-displaced-alien f 1 2 3
! ##unbox-any-c-ptr 5 3
! ##add 4 5 2
:: rewrite-unbox-displaced-alien ( insn expr -- insns )
[
next-vreg :> temp
temp expr in2>> vn>vreg insn temp>> ##unbox-any-c-ptr
insn dst>> temp expr in1>> vn>vreg ##add
] { } make ;
M: ##unbox-any-c-ptr rewrite
dup src>> vreg>expr dup box-displaced-alien?
[ rewrite-unbox-displaced-alien ] [ 2drop f ] if ;

7
basis/compiler/cfg/value-numbering/simplify/simplify.factor
View File

@ -87,6 +87,12 @@ M: unary-expr simplify*
[ 2drop f ]
} cond ; inline
: simplify-box-displaced-alien ( expr -- vn/expr/f )
>binary-expr< {
{ [ over expr-zero? ] [ nip ] }
[ 2drop f ]
} cond ;
M: binary-expr simplify*
dup op>> {
{ \ ##add [ simplify-add ] }
@ -107,6 +113,7 @@ M: binary-expr simplify*
{ \ ##sar-imm [ simplify-shr ] }
{ \ ##shl [ simplify-shl ] }
{ \ ##shl-imm [ simplify-shl ] }
{ \ ##box-displaced-alien [ simplify-box-displaced-alien ] }
[ 2drop f ]
} case ;

58
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -870,6 +870,63 @@ cell 8 = [
] unit-test
] when
! Displaced alien optimizations
3 vreg-counter set-global
[
{
T{ ##peek f 0 D 0 }
T{ ##load-immediate f 2 16 }
T{ ##box-displaced-alien f 1 2 0 }
T{ ##unbox-any-c-ptr f 4 0 }
T{ ##add-imm f 3 4 16 }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##load-immediate f 2 16 }
T{ ##box-displaced-alien f 1 2 0 }
T{ ##unbox-any-c-ptr f 3 1 }
} value-numbering-step
] unit-test
4 vreg-counter set-global
[
{
T{ ##box-alien f 0 1 }
T{ ##load-immediate f 2 16 }
T{ ##box-displaced-alien f 3 2 0 }
T{ ##copy f 5 1 any-rep }
T{ ##add-imm f 4 5 16 }
}
] [
{
T{ ##box-alien f 0 1 }
T{ ##load-immediate f 2 16 }
T{ ##box-displaced-alien f 3 2 0 }
T{ ##unbox-any-c-ptr f 4 3 }
} value-numbering-step
] unit-test
3 vreg-counter set-global
[
{
T{ ##peek f 0 D 0 }
T{ ##load-immediate f 2 0 }
T{ ##copy f 3 0 any-rep }
T{ ##replace f 3 D 1 }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##load-immediate f 2 0 }
T{ ##box-displaced-alien f 3 2 0 }
T{ ##replace f 3 D 1 }
} value-numbering-step
] unit-test
! Branch folding
[
{
@ -1301,3 +1358,4 @@ V{
] unit-test
[ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test

8
basis/compiler/cfg/value-numbering/value-numbering.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs kernel accessors
sorting sets sequences
sorting sets sequences arrays
cpu.architecture
sequences.deep
compiler.cfg
compiler.cfg.rpo
compiler.cfg.instructions
@ -32,10 +33,13 @@ M: insn process-instruction
dup rewrite
[ process-instruction ] [ ] ?if ;
M: array process-instruction
[ process-instruction ] map ;
: value-numbering-step ( insns -- insns' )
init-value-graph
init-expressions
[ process-instruction ] map ;
[ process-instruction ] map flatten ;
: value-numbering ( cfg -- cfg' )
[ value-numbering-step ] local-optimization

9
basis/compiler/codegen/codegen.factor
View File

@ -177,10 +177,13 @@ M: ##float>integer generate-insn dst/src %float>integer ;
M: ##copy generate-insn [ dst/src ] [ rep>> ] bi %copy ;
M: ##unbox-float generate-insn dst/src %unbox-float ;
M: ##unbox-float generate-insn dst/src %unbox-float ;
M: ##unbox-any-c-ptr generate-insn dst/src/temp %unbox-any-c-ptr ;
M: ##box-float generate-insn dst/src/temp %box-float ;
M: ##box-alien generate-insn dst/src/temp %box-alien ;
M: ##box-float generate-insn dst/src/temp %box-float ;
M: ##box-alien generate-insn dst/src/temp %box-alien ;
M: ##box-displaced-alien generate-insn
[ dst/src1/src2 ] [ temp>> ] bi %box-displaced-alien ;
M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;

277
basis/compiler/tests/alien.factor
View File

@ -1,9 +1,10 @@
USING: alien alien.c-types alien.syntax compiler kernel namespaces
sequences stack-checker stack-checker.errors words arrays parser
quotations continuations effects namespaces.private io
io.streams.string memory system threads tools.test math accessors
combinators specialized-arrays.float alien.libraries io.pathnames
io.backend ;
USING: accessors alien alien.c-types alien.libraries
alien.syntax arrays classes.struct combinators
compiler continuations effects io io.backend io.pathnames
io.streams.string kernel math memory namespaces
namespaces.private parser quotations sequences
specialized-arrays.float stack-checker stack-checker.errors
system threads tools.test words specialized-arrays.char ;
IN: compiler.tests.alien
<<
@ -46,25 +47,22 @@ FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
C-STRUCT: foo
{ "int" "x" }
{ "int" "y" }
;
STRUCT: FOO { x int } { y int } ;
: make-foo ( x y -- foo )
"foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
: make-FOO ( x y -- FOO )
FOO <struct> swap >>y swap >>x ;
FUNCTION: int ffi_test_11 int a foo b int c ;
FUNCTION: int ffi_test_11 int a FOO b int c ;
[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
[ 14 ] [ 1 2 3 make-FOO 4 ffi_test_11 ] unit-test
FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
FUNCTION: foo ffi_test_14 int x int y ;
FUNCTION: FOO ffi_test_14 int x int y ;
[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
[ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
FUNCTION: char* ffi_test_15 char* x char* y ;
@ -72,25 +70,19 @@ FUNCTION: char* ffi_test_15 char* x char* y ;
[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
[ 1 2 ffi_test_15 ] must-fail
C-STRUCT: bar
{ "long" "x" }
{ "long" "y" }
{ "long" "z" }
;
STRUCT: BAR { x long } { y long } { z long } ;
FUNCTION: bar ffi_test_16 long x long y long z ;
FUNCTION: BAR ffi_test_16 long x long y long z ;
[ 11 6 -7 ] [
11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri
] unit-test
C-STRUCT: tiny
{ "int" "x" }
;
STRUCT: TINY { x int } ;
FUNCTION: tiny ffi_test_17 int x ;
FUNCTION: TINY ffi_test_17 int x ;
[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
[ 11 ] [ 11 ffi_test_17 x>> ] unit-test
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
@ -132,12 +124,12 @@ unit-test
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
: ffi_test_19 ( x y z -- bar )
"bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
: ffi_test_19 ( x y z -- BAR )
"BAR" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
alien-invoke gc ;
[ 11 6 -7 ] [
11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
] unit-test
FUNCTION: double ffi_test_6 float x float y ;
@ -189,23 +181,20 @@ FUNCTION: long ffi_test_22 long x longlong y longlong z ;
[ 1111 f 123456789 ffi_test_22 ] must-fail
C-STRUCT: rect
{ "float" "x" }
{ "float" "y" }
{ "float" "w" }
{ "float" "h" }
;
STRUCT: RECT
{ x float } { y float }
{ w float } { h float } ;
: <rect> ( x y w h -- rect )
"rect" <c-object>
[ set-rect-h ] keep
[ set-rect-w ] keep
[ set-rect-y ] keep
[ set-rect-x ] keep ;
: <RECT> ( x y w h -- rect )
RECT <struct>
swap >>h
swap >>w
swap >>y
swap >>x ;
FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
@ -218,97 +207,97 @@ FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
] unit-test
! Test odd-size structs
C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
STRUCT: test-struct-1 { x char[1] } ;
FUNCTION: test-struct-1 ffi_test_24 ;
[ B{ 1 } ] [ ffi_test_24 ] unit-test
[ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
STRUCT: test-struct-2 { x char[2] } ;
FUNCTION: test-struct-2 ffi_test_25 ;
[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
[ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
STRUCT: test-struct-3 { x char[3] } ;
FUNCTION: test-struct-3 ffi_test_26 ;
[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
[ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
STRUCT: test-struct-4 { x char[4] } ;
FUNCTION: test-struct-4 ffi_test_27 ;
[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
[ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
STRUCT: test-struct-5 { x char[5] } ;
FUNCTION: test-struct-5 ffi_test_28 ;
[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
[ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
STRUCT: test-struct-6 { x char[6] } ;
FUNCTION: test-struct-6 ffi_test_29 ;
[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
[ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
STRUCT: test-struct-7 { x char[7] } ;
FUNCTION: test-struct-7 ffi_test_30 ;
[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
[ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
STRUCT: test-struct-8 { x double } { y double } ;
FUNCTION: double ffi_test_32 test-struct-8 x int y ;
[ 9.0 ] [
"test-struct-8" <c-object>
1.0 over set-test-struct-8-x
2.0 over set-test-struct-8-y
test-struct-8 <struct>
1.0 >>x
2.0 >>y
3 ffi_test_32
] unit-test
C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
STRUCT: test-struct-9 { x float } { y float } ;
FUNCTION: double ffi_test_33 test-struct-9 x int y ;
[ 9.0 ] [
"test-struct-9" <c-object>
1.0 over set-test-struct-9-x
2.0 over set-test-struct-9-y
test-struct-9 <struct>
1.0 >>x
2.0 >>y
3 ffi_test_33
] unit-test
C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
STRUCT: test-struct-10 { x float } { y int } ;
FUNCTION: double ffi_test_34 test-struct-10 x int y ;
[ 9.0 ] [
"test-struct-10" <c-object>
1.0 over set-test-struct-10-x
2 over set-test-struct-10-y
test-struct-10 <struct>
1.0 >>x
2 >>y
3 ffi_test_34
] unit-test
C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
STRUCT: test-struct-11 { x int } { y int } ;
FUNCTION: double ffi_test_35 test-struct-11 x int y ;
[ 9.0 ] [
"test-struct-11" <c-object>
1 over set-test-struct-11-x
2 over set-test-struct-11-y
test-struct-11 <struct>
1 >>x
2 >>y
3 ffi_test_35
] unit-test
C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
STRUCT: test-struct-12 { a int } { x double } ;
: make-struct-12 ( x -- alien )
"test-struct-12" <c-object>
[ set-test-struct-12-x ] keep ;
test-struct-12 <struct>
swap >>x ;
FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
@ -408,50 +397,47 @@ FUNCTION: int ffi_test_37 ( void* func ) ;
[ 7 ] [ callback-9 ffi_test_37 ] unit-test
C-STRUCT: test_struct_13
{ "float" "x1" }
{ "float" "x2" }
{ "float" "x3" }
{ "float" "x4" }
{ "float" "x5" }
{ "float" "x6" } ;
STRUCT: test_struct_13
{ x1 float }
{ x2 float }
{ x3 float }
{ x4 float }
{ x5 float }
{ x6 float } ;
: make-test-struct-13 ( -- alien )
"test_struct_13" <c-object>
1.0 over set-test_struct_13-x1
2.0 over set-test_struct_13-x2
3.0 over set-test_struct_13-x3
4.0 over set-test_struct_13-x4
5.0 over set-test_struct_13-x5
6.0 over set-test_struct_13-x6 ;
test_struct_13 <struct>
1.0 >>x1
2.0 >>x2
3.0 >>x3
4.0 >>x4
5.0 >>x5
6.0 >>x6 ;
FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
[ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
! Joe Groff found this problem
C-STRUCT: double-rect
{ "double" "a" }
{ "double" "b" }
{ "double" "c" }
{ "double" "d" } ;
STRUCT: double-rect
{ a double }
{ b double }
{ c double }
{ d double } ;
: <double-rect> ( a b c d -- foo )
"double-rect" <c-object>
{
[ set-double-rect-d ]
[ set-double-rect-c ]
[ set-double-rect-b ]
[ set-double-rect-a ]
[ ]
} cleave ;
double-rect <struct>
swap >>d
swap >>c
swap >>b
swap >>a ;
: >double-rect< ( foo -- a b c d )
{
[ double-rect-a ]
[ double-rect-b ]
[ double-rect-c ]
[ double-rect-d ]
[ a>> ]
[ b>> ]
[ c>> ]
[ d>> ]
} cleave ;
: double-rect-callback ( -- alien )
@ -467,23 +453,22 @@ C-STRUCT: double-rect
[ 1.0 2.0 3.0 4.0 ]
[ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
C-STRUCT: test_struct_14
{ "double" "x1" }
{ "double" "x2" } ;
STRUCT: test_struct_14
{ x1 double }
{ x2 double } ;
FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
[ 1.0 2.0 ] [
1.0 2.0 ffi_test_40
[ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
] unit-test
: callback-10 ( -- callback )
"test_struct_14" { "double" "double" } "cdecl"
[
"test_struct_14" <c-object>
[ set-test_struct_14-x2 ] keep
[ set-test_struct_14-x1 ] keep
test_struct_14 <struct>
swap >>x2
swap >>x1
] alien-callback ;
: callback-10-test ( x1 x2 callback -- result )
@ -491,22 +476,22 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
[ 1.0 2.0 ] [
1.0 2.0 callback-10 callback-10-test
[ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
[ x1>> ] [ x2>> ] bi
] unit-test
FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
[ 1 2.0 ] [
1 2.0 ffi_test_41
[ test-struct-12-a ] [ test-struct-12-x ] bi
[ a>> ] [ x>> ] bi
] unit-test
: callback-11 ( -- callback )
"test-struct-12" { "int" "double" } "cdecl"
[
"test-struct-12" <c-object>
[ set-test-struct-12-x ] keep
[ set-test-struct-12-a ] keep
test-struct-12 <struct>
swap >>x
swap >>a
] alien-callback ;
: callback-11-test ( x1 x2 callback -- result )
@ -514,47 +499,46 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
[ 1 2.0 ] [
1 2.0 callback-11 callback-11-test
[ test-struct-12-a ] [ test-struct-12-x ] bi
[ a>> ] [ x>> ] bi
] unit-test
C-STRUCT: test_struct_15
{ "float" "x" }
{ "float" "y" } ;
STRUCT: test_struct_15
{ x float }
{ y float } ;
FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ test_struct_15-x ] [ test_struct_15-y ] bi ] unit-test
[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
: callback-12 ( -- callback )
"test_struct_15" { "float" "float" } "cdecl"
[
"test_struct_15" <c-object>
[ set-test_struct_15-y ] keep
[ set-test_struct_15-x ] keep
test_struct_15 <struct>
swap >>y
swap >>x
] alien-callback ;
: callback-12-test ( x1 x2 callback -- result )
"test_struct_15" { "float" "float" } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [
1.0 2.0 callback-12 callback-12-test
[ test_struct_15-x ] [ test_struct_15-y ] bi
1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
] unit-test
C-STRUCT: test_struct_16
{ "float" "x" }
{ "int" "a" } ;
STRUCT: test_struct_16
{ x float }
{ a int } ;
FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ test_struct_16-x ] [ test_struct_16-a ] bi ] unit-test
[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
: callback-13 ( -- callback )
"test_struct_16" { "float" "int" } "cdecl"
[
"test_struct_16" <c-object>
[ set-test_struct_16-a ] keep
[ set-test_struct_16-x ] keep
test_struct_16 <struct>
swap >>a
swap >>x
] alien-callback ;
: callback-13-test ( x1 x2 callback -- result )
@ -562,12 +546,12 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
[ 1.0 2 ] [
1.0 2 callback-13 callback-13-test
[ test_struct_16-x ] [ test_struct_16-a ] bi
[ x>> ] [ a>> ] bi
] unit-test
FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
[ 1.0 2.0 ] [ ffi_test_44 [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi ] unit-test
[ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
: stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
@ -589,14 +573,15 @@ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
] unit-test
! Reported by jedahu
C-STRUCT: bool-field-test
{ "char*" "name" }
{ "bool" "on" }
{ "short" "parents" } ;
STRUCT: bool-field-test
{ name char* }
{ on bool }
{ parents short } ;
FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
[ 123 ] [
"bool-field-test" <c-object> 123 over set-bool-field-test-parents
bool-field-test <struct>
123 >>parents
ffi_test_48
] unit-test

8
basis/compiler/tests/codegen.factor
View File

@ -401,4 +401,10 @@ cell 4 = [
dup [ [ 1 fixnum+fast ] dip ] [ [ drop 1 ] dip ] if ;
[ 2 t ] [ 0 t global-dcn-bug-1 ] unit-test
[ 1 f ] [ 0 f global-dcn-bug-1 ] unit-test
[ 1 f ] [ 0 f global-dcn-bug-1 ] unit-test
! Forgot a GC check
: missing-gc-check-1 ( a -- b ) { fixnum } declare <alien> ;
: missing-gc-check-2 ( -- ) 10000000 [ missing-gc-check-1 drop ] each-integer ;
[ ] [ missing-gc-check-2 ] unit-test

48
basis/compiler/tests/intrinsics.factor
View File

@ -463,6 +463,54 @@ cell 8 = [
] compile-call
] unit-test
[ ALIEN: 123 ] [
123 [ <alien> ] compile-call
] unit-test
[ ALIEN: 123 ] [
123 [ { fixnum } declare <alien> ] compile-call
] unit-test
[ ALIEN: 123 ] [
[ 123 <alien> ] compile-call
] unit-test
[ f ] [
0 [ <alien> ] compile-call
] unit-test
[ f ] [
0 [ { fixnum } declare <alien> ] compile-call
] unit-test
[ f ] [
[ 0 <alien> ] compile-call
] unit-test
[ ALIEN: 321 ] [
0 ALIEN: 321 [ <displaced-alien> ] compile-call
] unit-test
[ ALIEN: 321 ] [
0 ALIEN: 321 [ { fixnum c-ptr } declare <displaced-alien> ] compile-call
] unit-test
[ ALIEN: 321 ] [
ALIEN: 321 [ 0 swap <displaced-alien> ] compile-call
] unit-test
[ B{ 0 1 2 3 4 } ] [
2 B{ 0 1 2 3 4 } <displaced-alien>
[ 1 swap <displaced-alien> ] compile-call
underlying>>
] unit-test
[ B{ 0 1 2 3 4 } ] [
2 B{ 0 1 2 3 4 } <displaced-alien>
[ 1 swap { c-ptr } declare <displaced-alien> ] compile-call
underlying>>
] unit-test
[
B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
] must-fail

4
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -780,6 +780,10 @@ M: f whatever2 ; inline
[ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
[ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test
SYMBOL: not-an-assoc
[ f ] [ [ not-an-assoc at ] { at* } inlined? ] unit-test
[ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test
[ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test

14
basis/compiler/tree/propagation/transforms/transforms.factor
View File

@ -207,12 +207,14 @@ CONSTANT: lookup-table-at-max 256
] ;
: at-quot ( assoc -- quot )
dup lookup-table-at? [
dup fast-lookup-table-at? [
fast-lookup-table-quot
] [
lookup-table-quot
] if
dup assoc? [
dup lookup-table-at? [
dup fast-lookup-table-at? [
fast-lookup-table-quot
] [
lookup-table-quot
] if
] [ drop f ] if
] [ drop f ] if ;
\ at* [ at-quot ] 1 define-partial-eval

13
basis/core-text/core-text.factor
View File

@ -2,10 +2,11 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.syntax kernel destructors
accessors fry words hashtables strings sequences memoize assocs math
math.vectors math.rectangles math.functions locals init namespaces
combinators fonts colors cache core-foundation core-foundation.strings
core-foundation.attributed-strings core-foundation.utilities
core-graphics core-graphics.types core-text.fonts core-text.utilities ;
math.order math.vectors math.rectangles math.functions locals init
namespaces combinators fonts colors cache core-foundation
core-foundation.strings core-foundation.attributed-strings
core-foundation.utilities core-graphics core-graphics.types
core-text.fonts core-text.utilities ;
IN: core-text
TYPEDEF: void* CTLineRef
@ -120,7 +121,7 @@ TUPLE: line < disposable line metrics image loc dim ;
(ext) [ (loc) (dim) v+ ]
loc [ (loc) [ floor ] map ]
ext [ (loc) (dim) [ + ceiling ] 2map ]
dim [ ext loc [ - >integer ] 2map ]
dim [ ext loc [ - >integer 1 max ] 2map ]
metrics [ open-font line compute-line-metrics ] |
line >>line
@ -149,4 +150,4 @@ SYMBOL: cached-lines
: cached-line ( font string -- line )
cached-lines get [ <line> ] 2cache ;
[ <cache-assoc> cached-lines set-global ] "core-text" add-init-hook
[ <cache-assoc> cached-lines set-global ] "core-text" add-init-hook

1
basis/cpu/architecture/architecture.factor
View File

@ -120,6 +120,7 @@ HOOK: %unbox-float cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
HOOK: %box-float cpu ( dst src temp -- )
HOOK: %box-alien cpu ( dst src temp -- )
HOOK: %box-displaced-alien cpu ( dst displacement base temp -- )
HOOK: %alien-unsigned-1 cpu ( dst src -- )
HOOK: %alien-unsigned-2 cpu ( dst src -- )

43
basis/cpu/ppc/ppc.factor
View File

@ -315,23 +315,50 @@ M:: ppc %unbox-any-c-ptr ( dst src temp -- )
: alien@ ( n -- n' ) cells object tag-number - ;
:: %allot-alien ( dst displacement base temp -- )
dst 4 cells alien temp %allot
temp \ f tag-number %load-immediate
! Store underlying-alien slot
base dst 1 alien@ STW
! Store expired slot
temp dst 2 alien@ STW
! Store offset
displacement dst 3 alien@ STW ;
M:: ppc %box-alien ( dst src temp -- )
[
"f" define-label
dst \ f tag-number %load-immediate
0 src 0 CMPI
"f" get BEQ
dst 4 cells alien temp %allot
! Store offset
src dst 3 alien@ STW
! Store expired slot
temp \ f tag-number %load-immediate
temp dst 1 alien@ STW
! Store underlying-alien slot
temp dst 2 alien@ STW
dst src temp temp %allot-alien
"f" resolve-label
] with-scope ;
M:: ppc %box-displaced-alien ( dst displacement base temp -- )
[
"end" define-label
"ok" define-label
! If displacement is zero, return the base
dst base MR
0 displacement 0 CMPI
"end" get BEQ
! If base is already a displaced alien, unpack it
0 base \ f tag-number CMPI
"ok" get BEQ
temp base header-offset LWZ
0 temp alien type-number tag-fixnum CMPI
"ok" get BNE
! displacement += base.displacement
temp base 3 alien@ LWZ
displacement displacement temp ADD
! base = base.base
base base 1 alien@ LWZ
"ok" resolve-label
dst displacement base temp %allot-alien
"end" resolve-label
] with-scope ;
M: ppc %alien-unsigned-1 0 LBZ ;
M: ppc %alien-unsigned-2 0 LHZ ;

35
basis/cpu/x86/x86.factor
View File

@ -255,17 +255,42 @@ M:: x86 %box-float ( dst src temp -- )
: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
:: %allot-alien ( dst displacement base temp -- )
dst 4 cells alien temp %allot
dst 1 alien@ base MOV ! alien
dst 2 alien@ \ f tag-number MOV ! expired
dst 3 alien@ displacement MOV ! displacement
;
M:: x86 %box-alien ( dst src temp -- )
[
"end" define-label
dst \ f tag-number MOV
src 0 CMP
"end" get JE
dst 4 cells alien temp %allot
dst 1 alien@ \ f tag-number MOV
dst 2 alien@ \ f tag-number MOV
! Store src in alien-offset slot
dst 3 alien@ src MOV
dst src \ f tag-number temp %allot-alien
"end" resolve-label
] with-scope ;
M:: x86 %box-displaced-alien ( dst displacement base temp -- )
[
"end" define-label
"ok" define-label
! If displacement is zero, return the base
dst base MOV
displacement 0 CMP
"end" get JE
! If base is already a displaced alien, unpack it
base \ f tag-number CMP
"ok" get JE
base header-offset [+] alien type-number tag-fixnum CMP
"ok" get JNE
! displacement += base.displacement
displacement base 3 alien@ ADD
! base = base.base
base base 1 alien@ MOV
"ok" resolve-label
dst displacement base temp %allot-alien
"end" resolve-label
] with-scope ;

6
basis/generalizations/generalizations.factor
View File

@ -15,7 +15,7 @@ IN: generalizations
MACRO: nsequence ( n seq -- )
[
[ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
[ drop iota <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
] keep
'[ @ _ like ] ;
@ -27,7 +27,7 @@ MACRO: nsum ( n -- )
1 - [ + ] n*quot ;
MACRO: firstn-unsafe ( n -- )
[ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
iota [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
@ -94,7 +94,7 @@ MACRO: mnswap ( m n -- )
1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
MACRO: nweave ( n -- )
[ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
[ dup iota <reversed> [ '[ _ _ mnswap ] ] with map ] keep
'[ _ _ ncleave ] ;
MACRO: nbi-curry ( n -- )

6
basis/images/bitmap/loading/loading.factor
View File

@ -342,8 +342,8 @@ M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
ERROR: unsupported-bitmap-file magic ;
: load-bitmap ( path -- loading-bitmap )
binary stream-throws <limited-file-reader> [
: load-bitmap ( stream -- loading-bitmap )
[
\ loading-bitmap new
parse-file-header [ >>file-header ] [ ] bi magic>> {
{ "BM" [
@ -363,7 +363,7 @@ ERROR: unsupported-bitmap-file magic ;
: loading-bitmap>bytes ( loading-bitmap -- byte-array )
uncompress-bitmap bitmap>bytes ;
M: bitmap-image load-image* ( path bitmap-image -- bitmap )
M: bitmap-image stream>image ( stream bitmap-image -- bitmap )
drop load-bitmap
[ image new ] dip
{

1
basis/images/http/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

7
basis/images/http/http.factor Normal file
View File

@ -0,0 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: http.client images.loader images.loader.private kernel ;
IN: images.http
: load-http-image ( path -- image )
[ http-get nip ] [ image-class new ] bi load-image* ;

2
basis/images/images.factor
View File

@ -68,8 +68,6 @@ TUPLE: image dim component-order component-type upside-down? bitmap ;
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
GENERIC: load-image* ( path class -- image )
: bytes-per-component ( component-type -- n )
{
{ ubyte-components [ 1 ] }

15
basis/images/jpeg/jpeg.factor
View File

@ -6,7 +6,7 @@ images.processing io io.binary io.encodings.binary io.files
io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order
math.ranges math.vectors memoize multiline namespaces
sequences sequences.deep ;
sequences sequences.deep images.loader ;
IN: images.jpeg
QUALIFIED-WITH: bitstreams bs
@ -19,6 +19,9 @@ TUPLE: jpeg-image < image
{ huff-tables initial: { f f f f } }
{ components } ;
"jpg" jpeg-image register-image-class
"jpeg" jpeg-image register-image-class
<PRIVATE
: <jpeg-image> ( headers bitstream -- image )
@ -353,17 +356,13 @@ ERROR: not-a-jpeg-image ;
PRIVATE>
: load-jpeg ( path -- image )
binary [
M: jpeg-image stream>image ( stream jpeg-image -- bitmap )
drop [
parse-marker { SOI } = [ not-a-jpeg-image ] unless
parse-headers
contents <jpeg-image>
] with-file-reader
] with-input-stream
dup jpeg-image [
baseline-parse
baseline-decompress
] with-variable ;
M: jpeg-image load-image* ( path jpeg-image -- bitmap )
drop load-jpeg ;

24
basis/images/loader/loader.factor
View File

@ -1,7 +1,9 @@
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel splitting unicode.case combinators accessors images
io.pathnames namespaces assocs ;
USING: accessors assocs byte-arrays combinators images
io.encodings.binary io.pathnames io.streams.byte-array
io.streams.limited kernel namespaces splitting strings
unicode.case ;
IN: images.loader
ERROR: unknown-image-extension extension ;
@ -15,10 +17,26 @@ types [ H{ } clone ] initialize
file-extension >lower types get ?at
[ unknown-image-extension ] unless ;
: open-image-file ( path -- stream )
binary stream-throws <limited-file-reader> ;
PRIVATE>
GENERIC# load-image* 1 ( obj class -- image )
GENERIC: stream>image ( stream class -- image )
: register-image-class ( extension class -- )
swap types get set-at ;
: load-image ( path -- image )
dup image-class load-image* ;
[ open-image-file ] [ image-class ] bi load-image* ;
M: byte-array load-image*
[ binary <byte-reader> ] dip stream>image ;
M: limited-stream load-image* stream>image ;
M: string load-image* [ open-image-file ] dip stream>image ;
M: pathname load-image* [ open-image-file ] dip stream>image ;

7
basis/images/png/png.factor
View File

@ -111,14 +111,11 @@ ERROR: unimplemented-color-type image ;
[ unknown-color-type ]
} case ;
: load-png ( path -- image )
binary stream-throws <limited-file-reader> [
M: png-image stream>image
drop [
<loading-png>
read-png-header
read-png-chunks
parse-ihdr-chunk
decode-png
] with-input-stream ;
M: png-image load-image*
drop load-png ;

21
basis/images/tiff/tiff.factor
View File

@ -517,14 +517,14 @@ ERROR: unknown-component-order ifd ;
: with-tiff-endianness ( loading-tiff quot -- )
[ dup endianness>> ] dip with-endianness ; inline
: load-tiff-ifds ( path -- loading-tiff )
binary [
: load-tiff-ifds ( stream -- loading-tiff )
[
<loading-tiff>
read-header [
dup ifd-offset>> read-ifds
process-ifds
] with-tiff-endianness
] with-file-reader ;
] with-input-stream* ;
: process-chunky-ifd ( ifd -- )
read-strips
@ -555,13 +555,18 @@ ERROR: unknown-component-order ifd ;
ifds>> [ process-ifd ] each ;
: load-tiff ( path -- loading-tiff )
[ load-tiff-ifds dup ] keep
binary [
[ process-tif-ifds ] with-tiff-endianness
] with-file-reader ;
[ load-tiff-ifds dup ]
[
[ [ 0 seek-absolute ] dip stream-seek ]
[
[
[ process-tif-ifds ] with-tiff-endianness
] with-input-stream
] bi
] bi ;
! tiff files can store several images -- we just take the first for now
M: tiff-image load-image* ( path tiff-image -- image )
M: tiff-image stream>image ( stream tiff-image -- image )
drop load-tiff tiff>image ;
{ "tif" "tiff" } [ tiff-image register-image-class ] each

2
basis/io/buffers/buffers.factor
View File

@ -42,7 +42,7 @@ M: buffer dispose* ptr>> free ;
[ fill>> ] [ pos>> ] bi - ; inline
: buffer@ ( buffer -- alien )
[ pos>> ] [ ptr>> ] bi <displaced-alien> ;
[ pos>> ] [ ptr>> ] bi <displaced-alien> ; inline
: buffer-read ( n buffer -- byte-array )
[ buffer-length min ] keep

3
basis/io/streams/limited/limited.factor
View File

@ -98,5 +98,8 @@ PRIVATE>
M: limited-stream stream-read-until
swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ;
M: limited-stream stream-seek
stream>> stream-seek ;
M: limited-stream dispose
stream>> dispose ;

6
basis/libc/libc.factor
View File

@ -83,6 +83,12 @@ PRIVATE>
: memcpy ( dst src size -- )
"void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ;
: memcmp ( a b size -- cmp )
"int" "libc" "memcmp" { "void*" "void*" "ulong" } alien-invoke ;
: memory= ( a b size -- ? )
memcmp 0 = ;
: strlen ( alien -- len )
"size_t" "libc" "strlen" { "char*" } alien-invoke ;

5
basis/multiline/multiline-docs.factor
View File

@ -21,7 +21,7 @@ HELP: /*
HELP: HEREDOC:
{ $syntax "HEREDOC: marker\n...text...\nmarker" }
{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } }
{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: HEREDOC: } " until the end of the line containing the " { $link POSTPONE: HEREDOC: } ". Text is captured until a line is found conatining exactly this delimter string." }
{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after " { $link POSTPONE: HEREDOC: } " until the end of the line containing " { $link POSTPONE: HEREDOC: } ". Text is captured until a line is found conatining exactly this delimter string." }
{ $warning "Whitespace is significant." }
{ $examples
{ $example "USING: multiline prettyprint ;"
@ -37,7 +37,8 @@ HELP: HEREDOC:
HELP: DELIMITED:
{ $syntax "DELIMITED: marker\n...text...\nmarker" }
{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } }
{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: DELIMITED: } " until the end of the line containing the " { $link POSTPONE: DELIMITED: } ". Text is captured until the exact delimiter string is found, regardless of where." }
{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after " { $link POSTPONE: DELIMITED: } " until the end of the line containing " { $link POSTPONE: DELIMITED: } ". Text is captured until the exact delimiter string is found, regardless of where." }
{ $warning "Whitespace is significant on the " { $link POSTPONE: DELIMITED: } " line." }
{ $examples
{ $example "USING: multiline prettyprint ;"
"DELIMITED: factor blows my mind"

12
basis/specialized-arrays/direct/functor/functor.factor
View File

@ -26,13 +26,13 @@ TUPLE: A
{ length fixnum read-only } ;
: <A> ( alien len -- direct-array ) A boa ; inline
M: A length length>> ;
M: A nth-unsafe underlying>> NTH call ;
M: A set-nth-unsafe underlying>> SET-NTH call ;
M: A like drop dup A instance? [ >A' ] unless ;
M: A new-sequence drop <A'> ;
M: A length length>> ; inline
M: A nth-unsafe underlying>> NTH call ; inline
M: A set-nth-unsafe underlying>> SET-NTH call ; inline
M: A like drop dup A instance? [ >A' ] unless ; inline
M: A new-sequence drop <A'> ; inline
M: A byte-length length>> T heap-size * ;
M: A byte-length length>> T heap-size * ; inline
M: A pprint-delims drop \ A'{ \ } ;

13
basis/struct-arrays/prettyprint/prettyprint.factor Normal file
View File

@ -0,0 +1,13 @@
! (c)Joe Groff bsd license
USING: accessors arrays kernel prettyprint.backend
prettyprint.custom sequences struct-arrays ;
IN: struct-arrays.prettyprint
M: struct-array pprint-delims
drop \ struct-array{ \ } ;
M: struct-array >pprint-sequence
[ >array ] [ class>> ] bi prefix ;
M: struct-array pprint* pprint-object ;

34
basis/struct-arrays/struct-arrays-tests.factor
View File

@ -1,40 +1,46 @@
IN: struct-arrays.tests
USING: struct-arrays tools.test kernel math sequences
USING: classes.struct struct-arrays tools.test kernel math sequences
alien.syntax alien.c-types destructors libc accessors sequences.private ;
C-STRUCT: test-struct
{ "int" "x" }
{ "int" "y" } ;
STRUCT: test-struct-array
{ x int }
{ y int } ;
: make-point ( x y -- struct )
"test-struct" <c-object>
[ set-test-struct-y ] keep
[ set-test-struct-x ] keep ;
test-struct-array <struct-boa> ;
[ 5/4 ] [
2 "test-struct" <struct-array>
2 test-struct-array <struct-array>
1 2 make-point over set-first
3 4 make-point over set-second
0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce
0 [ [ x>> ] [ y>> ] bi / + ] reduce
] unit-test
[ 5/4 ] [
[
2 "test-struct" malloc-struct-array
2 test-struct-array malloc-struct-array
dup &free drop
1 2 make-point over set-first
3 4 make-point over set-second
0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce
0 [ [ x>> ] [ y>> ] bi / + ] reduce
] with-destructors
] unit-test
[ ] [ ALIEN: 123 10 "test-struct" <direct-struct-array> drop ] unit-test
[ ] [ ALIEN: 123 10 test-struct-array <direct-struct-array> drop ] unit-test
[ ] [
[
10 "test-struct" malloc-struct-array
10 test-struct-array malloc-struct-array
&free drop
] with-destructors
] unit-test
[ 15 ] [ 15 10 "test-struct" <struct-array> resize length ] unit-test
[ 15 ] [ 15 10 test-struct-array <struct-array> resize length ] unit-test
[ S{ test-struct-array f 12 20 } ] [
struct-array{ test-struct-array
S{ test-struct-array f 4 20 }
S{ test-struct-array f 12 20 }
S{ test-struct-array f 20 20 }
} second
] unit-test

57
basis/struct-arrays/struct-arrays.factor
View File

@ -1,45 +1,76 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types byte-arrays kernel libc
math sequences sequences.private ;
USING: accessors alien alien.c-types alien.structs byte-arrays
classes.struct kernel libc math parser sequences sequences.private ;
IN: struct-arrays
: c-type-struct-class ( c-type -- class )
c-type boxed-class>> ; foldable
TUPLE: struct-array
{ underlying c-ptr read-only }
{ length array-capacity read-only }
{ element-size array-capacity read-only } ;
{ element-size array-capacity read-only }
{ class read-only } ;
M: struct-array length length>> ;
M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ;
M: struct-array length length>> ; inline
M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
: (nth-ptr) ( i struct-array -- alien )
[ element-size>> * ] [ underlying>> ] bi <displaced-alien> ; inline
M: struct-array nth-unsafe
[ element-size>> * ] [ underlying>> ] bi <displaced-alien> ;
[ (nth-ptr) ] [ class>> dup struct-class? ] bi [ memory>struct ] [ drop ] if ; inline
M: struct-array set-nth-unsafe
[ nth-unsafe swap ] [ element-size>> ] bi memcpy ;
[ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline
M: struct-array new-sequence
element-size>> [ * <byte-array> ] 2keep struct-array boa ; inline
[ element-size>> [ * <byte-array> ] 2keep ]
[ class>> ] bi struct-array boa ; inline
M: struct-array resize ( n seq -- newseq )
[ [ element-size>> * ] [ underlying>> ] bi resize ] [ element-size>> ] 2bi
[ [ element-size>> * ] [ underlying>> ] bi resize ]
[ [ element-size>> ] [ class>> ] bi ] 2bi
struct-array boa ;
: <struct-array> ( length c-type -- struct-array )
heap-size [ * <byte-array> ] 2keep struct-array boa ; inline
[ heap-size [ * <byte-array> ] 2keep ]
[ c-type-struct-class ] bi struct-array boa ; inline
ERROR: bad-byte-array-length byte-array ;
: byte-array>struct-array ( byte-array c-type -- struct-array )
heap-size [
[ heap-size [
[ dup length ] dip /mod 0 =
[ drop bad-byte-array-length ] unless
] keep struct-array boa ; inline
] keep ] [ c-type-struct-class ] bi struct-array boa ; inline
: <direct-struct-array> ( alien length c-type -- struct-array )
heap-size struct-array boa ; inline
[ heap-size ] [ c-type-struct-class ] bi struct-array boa ; inline
: malloc-struct-array ( length c-type -- struct-array )
[ heap-size calloc ] 2keep <direct-struct-array> ; inline
INSTANCE: struct-array sequence
M: struct-type <c-type-array> ( len c-type -- array )
dup c-type-array-constructor
[ execute( len -- array ) ]
[ <struct-array> ] ?if ; inline
M: struct-type <c-type-direct-array> ( alien len c-type -- array )
dup c-type-direct-array-constructor
[ execute( alien len -- array ) ]
[ <direct-struct-array> ] ?if ; inline
: >struct-array ( sequence class -- struct-array )
[ dup length ] dip <struct-array>
[ 0 swap copy ] keep ; inline
SYNTAX: struct-array{
\ } scan-word [ >struct-array ] curry parse-literal ;
USING: vocabs vocabs.loader ;
"prettyprint" vocab [ "struct-arrays.prettyprint" require ] when

2
basis/ui/backend/cocoa/cocoa.factor
View File

@ -211,7 +211,7 @@ CLASS: {
{ +name+ "FactorApplicationDelegate" }
}
{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
[ 3drop reset-run-loop ]
} ;

2
basis/ui/backend/cocoa/views/views.factor
View File

@ -149,7 +149,7 @@ CLASS: {
! Rendering
{ "drawRect:" "void" { "id" "SEL" "NSRect" }
[ 2drop window relayout-1 ]
[ 2drop window relayout-1 yield ]
}
! Events

40
build-support/factor.sh
View File

@ -14,6 +14,7 @@ WORD=
NO_UI=
GIT_PROTOCOL=${GIT_PROTOCOL:="git"}
GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"}
SCRIPT_ARGS="$*"
test_program_installed() {
if ! [[ -n `type -p $1` ]] ; then
@ -353,9 +354,40 @@ git_clone() {
invoke_git clone $GIT_URL
}
git_pull_factorcode() {
echo "Updating the git repository from factorcode.org..."
invoke_git pull $GIT_URL master
update_script_name() {
echo `dirname $0`/_update.sh
}
update_script() {
update_script=`update_script_name`
echo "#!/bin/sh" >"$update_script"
echo "git pull \"$GIT_URL\" master" >>"$update_script"
echo "if [[ \$? -eq 0 ]]; then exec \"$0\" $SCRIPT_ARGS; else echo \"git pull failed\"; exit 2; fi" \
>>"$update_script"
echo "exit 0" >>"$update_script"
chmod 755 "$update_script"
exec "$update_script"
}
update_script_changed() {
invoke_git diff --stat `invoke_git merge-base HEAD FETCH_HEAD` FETCH_HEAD | grep 'build-support.factor\.sh' >/dev/null
}
git_fetch_factorcode() {
echo "Fetching the git repository from factorcode.org..."
rm -f `update_script_name`
invoke_git fetch "$GIT_URL" master
if update_script_changed; then
echo "Updating and restarting the factor.sh script..."
update_script
else
echo "Updating the working tree..."
invoke_git pull "$GIT_URL" master
fi
}
cd_factor() {
@ -475,7 +507,7 @@ install() {
update() {
get_config_info
git_pull_factorcode
git_fetch_factorcode
backup_factor
make_clean
make_factor

6
core/classes/algebra/algebra-tests.factor
View File

@ -2,8 +2,8 @@ USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings
tools.test words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
random stack-checker effects kernel.private sbufs math.order
vectors source-files compiler.units growable random
stack-checker effects kernel.private sbufs math.order
classes.tuple accessors ;
IN: classes.algebra.tests
@ -317,4 +317,4 @@ SINGLETON: sc
! UNION: u1 sa sb ;
! UNION: u2 sc ;
! [ f ] [ u1 u2 classes-intersect? ] unit-test
! [ f ] [ u1 u2 classes-intersect? ] unit-test

2
core/classes/classes-tests.factor
View File

@ -2,7 +2,7 @@ USING: alien arrays generic assocs hashtables io
io.streams.string kernel math namespaces parser prettyprint
sequences strings tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files compiler.units
classes.algebra definitions source-files compiler.units
kernel.private sorting vocabs memory eval accessors sets ;
IN: classes.tests

4
core/classes/tuple/tuple.factor
View File

@ -35,7 +35,7 @@ M: tuple class layout-of 2 slot { word } declare ; inline
layout-of 3 slot { fixnum } declare ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
check-tuple [ tuple-size iota ] [ ] [ layout-of ] tri ;
: copy-tuple-slots ( n tuple -- array )
[ array-nth ] curry map ;
@ -69,7 +69,7 @@ GENERIC: slots>tuple ( seq class -- tuple )
M: tuple-class slots>tuple ( seq class -- tuple )
check-slots pad-slots
tuple-layout <tuple> [
[ tuple-size ]
[ tuple-size iota ]
[ [ set-array-nth ] curry ]
bi 2each
] keep ;

5
core/classes/union/union-tests.factor
View File

@ -2,9 +2,8 @@ USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files
compiler.units kernel.private sorting vocabs io.streams.string
eval see ;
classes.algebra source-files compiler.units kernel.private
sorting vocabs io.streams.string eval see ;
IN: classes.union.tests
! DEFER: bah

19
core/effects/effects.factor
View File

@ -6,25 +6,29 @@ IN: effects
TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ;
GENERIC: effect-length ( obj -- n )
M: sequence effect-length length ;
M: integer effect-length ;
: <effect> ( in out -- effect )
dup { "*" } sequence= [ drop { } t ] [ f ] if
effect boa ;
: effect-height ( effect -- n )
[ out>> length ] [ in>> length ] bi - ; inline
[ out>> effect-length ] [ in>> effect-length ] bi - ; inline
: effect<= ( effect1 effect2 -- ? )
{
{ [ over terminated?>> ] [ t ] }
{ [ dup terminated?>> ] [ f ] }
{ [ 2dup [ in>> length ] bi@ > ] [ f ] }
{ [ 2dup [ in>> effect-length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
[ t ]
} cond 2nip ; inline
: effect= ( effect1 effect2 -- ? )
[ [ in>> length ] bi@ = ]
[ [ out>> length ] bi@ = ]
[ [ in>> effect-length ] bi@ = ]
[ [ out>> effect-length ] bi@ = ]
[ [ terminated?>> ] bi@ = ]
2tri and and ;
@ -62,7 +66,7 @@ M: effect clone
stack-effect effect-height ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
in>> length cut* ;
in>> effect-length cut* ;
: shuffle-mapping ( effect -- mapping )
[ out>> ] [ in>> ] bi [ index ] curry map ;
@ -77,8 +81,9 @@ M: effect clone
over terminated?>> [
drop
] [
[ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ]
[ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
[ [ [ in>> effect-length ] [ out>> effect-length ] bi ] [ in>> effect-length ] bi* swap [-] + ]
[ [ out>> effect-length ] [ [ in>> effect-length ] [ out>> effect-length ] bi ] bi* [ [-] ] dip + ]
[ nip terminated?>> ] 2tri
[ [ [ "obj" ] replicate ] bi@ ] dip
effect boa
] if ; inline

2
core/sequences/sequences-tests.factor
View File

@ -293,4 +293,4 @@ USE: make
[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test
[ t ] [ 0 array-capacity? ] unit-test
[ f ] [ -1 array-capacity? ] unit-test
[ f ] [ -1 array-capacity? ] unit-test

4
core/sequences/sequences.factor
View File

@ -919,7 +919,7 @@ PRIVATE>
<PRIVATE
: generic-flip ( matrix -- newmatrix )
[ dup first length [ length min ] reduce ] keep
[ dup first length [ length min ] reduce iota ] keep
[ [ nth-unsafe ] with { } map-as ] curry { } map-as ; inline
USE: arrays
@ -929,7 +929,7 @@ USE: arrays
: array-flip ( matrix -- newmatrix )
{ array } declare
[ dup first array-length [ array-length min ] reduce ] keep
[ dup first array-length [ array-length min ] reduce iota ] keep
[ [ { array } declare array-nth ] with { } map-as ] curry { } map-as ;
PRIVATE>

6
core/words/words-docs.factor
View File

@ -219,7 +219,11 @@ HELP: <word> ( name vocab -- word )
HELP: gensym
{ $values { "word" word } }
{ $description "Creates an uninterned word that is not equal to any other word in the system." }
{ $examples { $unchecked-example "gensym ." "G:260561" } }
{ $examples { $example "USING: prettyprint words ;"
"gensym ."
"( gensym )"
}
}
{ $notes "Gensyms are often used as placeholder values that have no meaning of their own but must be unique. For example, the compiler uses gensyms to label sections of code." } ;
HELP: bootstrapping?

8
extra/bloom-filters/bloom-filters-tests.factor
View File

@ -66,7 +66,8 @@ IN: bloom-filters.tests
[ t ] [ 2000 iota
full-bloom-filter
[ bloom-filter-member? ] curry map
[ ] all? ] unit-test
[ ] all?
] unit-test
! We shouldn't have more than 0.01 false-positive rate.
[ t ] [ 1000 iota [ drop most-positive-fixnum random 1000 + ] map
@ -74,5 +75,6 @@ IN: bloom-filters.tests
[ bloom-filter-member? ] curry map
[ ] filter
! TODO: This should be 10, but the false positive rate is currently very
! high. It shouldn't be much more than this.
length 150 <= ] unit-test
! high. 300 is large enough not to prevent builds from succeeding.
length 300 <=
] unit-test

9
extra/gpu/demos/bunny/bunny.factor
View File

@ -4,8 +4,7 @@ game-worlds gpu gpu.buffers gpu.util.wasd gpu.framebuffers gpu.render
gpu.shaders gpu.state gpu.textures gpu.util grouping http.client images
images.loader io io.encodings.ascii io.files io.files.temp
kernel math math.matrices math.parser math.vectors
method-chains sequences specialized-arrays.direct.float
specialized-arrays.float specialized-vectors.uint splitting
method-chains sequences specialized-arrays.float specialized-vectors.uint splitting
struct-vectors threads ui ui.gadgets ui.gadgets.worlds
ui.pixel-formats ;
IN: gpu.demos.bunny
@ -99,10 +98,10 @@ UNIFORM-TUPLE: loading-uniforms
: calc-bunny-normal ( vertexes indexes -- )
swap
[ [ nth bunny-vertex-struct-vertex 3 <direct-float-array> ] curry { } map-as normal ]
[ [ nth bunny-vertex-struct-vertex ] curry { } map-as normal ]
[
[
nth [ bunny-vertex-struct-normal 3 <direct-float-array> v+ ] keep
nth [ bunny-vertex-struct-normal v+ ] keep
set-bunny-vertex-struct-normal
] curry with each
] 2bi ;
@ -113,7 +112,7 @@ UNIFORM-TUPLE: loading-uniforms
: normalize-bunny-normals ( vertexes -- )
[
[ bunny-vertex-struct-normal 3 <direct-float-array> normalize ] keep
[ bunny-vertex-struct-normal normalize ] keep
set-bunny-vertex-struct-normal
] each ;

11
extra/html/parser/analyzer/analyzer.factor
View File

@ -3,7 +3,7 @@
USING: assocs html.parser kernel math sequences strings ascii
arrays generalizations shuffle namespaces make
splitting http accessors io combinators http.client urls
urls.encoding fry prettyprint sets ;
urls.encoding fry prettyprint sets combinators.short-circuit ;
IN: html.parser.analyzer
TUPLE: link attributes clickable ;
@ -103,6 +103,15 @@ TUPLE: link attributes clickable ;
[ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ]
find-between-all ;
: find-images ( vector -- vector' )
[
{
[ name>> "img" = ]
[ attributes>> "src" swap at ]
} 1&&
] find-all
values [ attributes>> "src" swap at ] map ;
: <link> ( vector -- link )
[ first attributes>> ]
[ [ name>> { text "img" } member? ] filter ] bi

232
extra/images/gif/gif.factor Normal file
View File

@ -0,0 +1,232 @@
! Copyrigt (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators constructors destructors
images images.loader io io.binary io.buffers
io.encodings.binary io.encodings.string io.encodings.utf8
io.files io.files.info io.ports io.streams.limited kernel make
math math.bitwise math.functions multiline namespaces
prettyprint sequences ;
IN: images.gif
SINGLETON: gif-image
"gif" gif-image register-image-class
TUPLE: loading-gif
loading?
magic
width height
flags
background-color
default-aspect-ratio
global-color-table
graphic-control-extensions
application-extensions
plain-text-extensions
comment-extensions
image-descriptor
local-color-table
compressed-bytes ;
TUPLE: gif-frame
image-descriptor
local-color-table ;
ERROR: unsupported-gif-format magic ;
ERROR: unknown-extension n ;
ERROR: gif-unexpected-eof ;
TUPLE: graphics-control-extension
label block-size raw-data
packed delay-time color-index
block-terminator ;
TUPLE: image-descriptor
separator left top width height flags ;
TUPLE: plain-text-extension
introducer label block-size text-grid-left text-grid-top text-grid-width
text-grid-height cell-width cell-height
text-fg-color-index text-bg-color-index plain-text-data ;
TUPLE: application-extension
introducer label block-size identifier authentication-code
application-data ;
TUPLE: comment-extension
introducer label comment-data ;
TUPLE: trailer byte ;
CONSTRUCTOR: trailer ( byte -- obj ) ;
CONSTANT: image-descriptor HEX: 2c
! Extensions
CONSTANT: extension-identifier HEX: 21
CONSTANT: plain-text-extension HEX: 01
CONSTANT: graphic-control-extension HEX: f9
CONSTANT: comment-extension HEX: fe
CONSTANT: application-extension HEX: ff
CONSTANT: trailer HEX: 3b
: <loading-gif> ( -- loading-gif )
\ loading-gif new
V{ } clone >>graphic-control-extensions
V{ } clone >>application-extensions
V{ } clone >>plain-text-extensions
V{ } clone >>comment-extensions
t >>loading? ;
GENERIC: stream-peek1 ( stream -- byte )
M: input-port stream-peek1
dup check-disposed dup wait-to-read
[ drop f ] [ buffer>> buffer-peek ] if ; inline
: peek1 ( -- byte ) input-stream get stream-peek1 ;
: (read-sub-blocks) ( -- )
read1 [ read , (read-sub-blocks) ] unless-zero ;
: read-sub-blocks ( -- bytes )
[ (read-sub-blocks) ] { } make B{ } concat-as ;
: read-image-descriptor ( -- image-descriptor )
\ image-descriptor new
1 read le> >>separator
2 read le> >>left
2 read le> >>top
2 read le> >>width
2 read le> >>height
1 read le> >>flags ;
: read-graphic-control-extension ( -- graphic-control-extension )
\ graphics-control-extension new
1 read le> [ >>block-size ] [ read ] bi
>>raw-data
1 read le> >>block-terminator ;
: read-plain-text-extension ( -- plain-text-extension )
\ plain-text-extension new
1 read le> >>block-size
2 read le> >>text-grid-left
2 read le> >>text-grid-top
2 read le> >>text-grid-width
2 read le> >>text-grid-height
1 read le> >>cell-width
1 read le> >>cell-height
1 read le> >>text-fg-color-index
1 read le> >>text-bg-color-index
read-sub-blocks >>plain-text-data ;
: read-comment-extension ( -- comment-extension )
\ comment-extension new
read-sub-blocks >>comment-data ;
: read-application-extension ( -- read-application-extension )
\ application-extension new
1 read le> >>block-size
8 read utf8 decode >>identifier
3 read >>authentication-code
read-sub-blocks >>application-data ;
: read-gif-header ( loading-gif -- loading-gif )
6 read utf8 decode >>magic ;
ERROR: unimplemented message ;
: read-GIF87a ( loading-gif -- loading-gif )
"GIF87a" unimplemented ;
: read-logical-screen-descriptor ( loading-gif -- loading-gif )
2 read le> >>width
2 read le> >>height
1 read le> >>flags
1 read le> >>background-color
1 read le> >>default-aspect-ratio ;
: color-table? ( image -- ? ) flags>> 7 bit? ; inline
: interlaced? ( image -- ? ) flags>> 6 bit? ; inline
: sort? ( image -- ? ) flags>> 5 bit? ; inline
: color-table-size ( image -- ? ) flags>> 3 bits 1 + 2^ 3 * ; inline
: color-resolution ( image -- ? ) flags>> -4 shift 3 bits ; inline
: read-global-color-table ( loading-gif -- loading-gif )
dup color-table? [
dup color-table-size read >>global-color-table
] when ;
: maybe-read-local-color-table ( loading-gif -- loading-gif )
dup image-descriptor>> color-table? [
dup color-table-size read >>local-color-table
] when ;
: read-image-data ( loading-gif -- loading-gif )
read-sub-blocks >>compressed-bytes ;
: read-table-based-image ( loading-gif -- loading-gif )
read-image-descriptor >>image-descriptor
maybe-read-local-color-table
read-image-data ;
: read-graphic-rendering-block ( loading-gif -- loading-gif )
read-table-based-image ;
: read-extension ( loading-gif -- loading-gif )
read1 {
{ plain-text-extension [
read-plain-text-extension over plain-text-extensions>> push
] }
{ graphic-control-extension [
read-graphic-control-extension
over graphic-control-extensions>> push
] }
{ comment-extension [
read-comment-extension over comment-extensions>> push
] }
{ application-extension [
read-application-extension over application-extensions>> push
] }
{ f [ gif-unexpected-eof ] }
[ unknown-extension ]
} case ;
ERROR: unhandled-data byte ;
: read-data ( loading-gif -- loading-gif )
read1 {
{ extension-identifier [ read-extension ] }
{ graphic-control-extension [
read-graphic-control-extension
over graphic-control-extensions>> push
] }
{ image-descriptor [ read-table-based-image ] }
{ trailer [ f >>loading? ] }
[ unhandled-data ]
} case ;
: read-GIF89a ( loading-gif -- loading-gif )
read-logical-screen-descriptor
read-global-color-table
[ read-data dup loading?>> ] loop ;
: load-gif ( stream -- loading-gif )
[
<loading-gif>
read-gif-header dup magic>> {
{ "GIF87a" [ read-GIF87a ] }
{ "GIF89a" [ read-GIF89a ] }
[ unsupported-gif-format ]
} case
] with-input-stream ;
: loading-gif>image ( loading-gif -- image )
;
ERROR: loading-gif-error gif-image ;
: ensure-loaded ( gif-image -- gif-image )
dup loading?>> [ loading-gif-error ] when ;
M: gif-image stream>image ( path gif-image -- image )
drop load-gif ensure-loaded loading-gif>image ;

22
extra/images/viewer/viewer.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors images images.loader io.pathnames kernel namespaces
opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
ui.gadgets.panes ui.render ui.images ;
USING: accessors images images.loader io.pathnames kernel
models namespaces opengl opengl.gl opengl.textures sequences
strings ui ui.gadgets ui.gadgets.panes ui.images ui.render
constructors ;
IN: images.viewer
TUPLE: image-gadget < gadget image texture ;
@ -13,7 +14,20 @@ M: image-gadget pref-dim* image>> dim>> ;
dup texture>> [ ] [ dup image>> { 0 0 } <texture> >>texture texture>> ] ?if ;
M: image-gadget draw-gadget* ( gadget -- )
[ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture ;
dup image>> [
[ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture
] [
drop
] if ;
TUPLE: image-control < image-gadget ;
CONSTRUCTOR: image-control ( model -- image-control ) ;
M: image-control pref-dim* image>> [ dim>> ] [ { 640 480 } ] if* ;
M: image-control model-changed
swap value>> >>image relayout ;
! Todo: delete texture on ungraft

1
vm/Config.macosx.x86.32
View File

@ -1,2 +1,3 @@
include vm/Config.macosx
include vm/Config.x86.32
CFLAGS += -m32

2
vm/os-macosx-ppc.hpp
View File

@ -1,4 +1,4 @@
#include <ucontext.h>
#include <sys/ucontext.h>
namespace factor
{

2
vm/os-macosx-x86.32.hpp
View File

@ -1,4 +1,4 @@
#include <ucontext.h>
#include <sys/ucontext.h>
namespace factor
{

2
vm/os-macosx-x86.64.hpp
View File

@ -1,4 +1,4 @@
#include <ucontext.h>
#include <sys/ucontext.h>
namespace factor
{