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 [
] [ [ + ] 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 )
[
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? ;
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
: offset-of ( field struct -- offset )
c-types get at fields>>
[ name>> = ] with find nip offset>> ;
+
+USE: vocabs.loader
+"struct-arrays" require
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 ;
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors assocs classes classes.struct combinators
+kernel math prettyprint.backend prettyprint.custom
+prettyprint.sections see.private sequences words ;
+IN: classes.struct.prettyprint
+
+<PRIVATE
+
+: struct-definer-word ( class -- word )
+ struct-slots dup length 2 >=
+ [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
+ [ drop \ STRUCT: ] if ;
+
+: struct>assoc ( struct -- assoc )
+ [ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ;
+
+: pprint-struct-slot ( slot -- )
+ <flow \ { pprint-word
+ {
+ [ name>> text ]
+ [ c-type>> text ]
+ [ read-only>> [ \ read-only pprint-word ] when ]
+ [ initial>> [ \ initial: pprint-word pprint* ] when* ]
+ } cleave
+ \ } pprint-word block> ;
+
+PRIVATE>
+
+M: struct-class see-class*
+ <colon dup struct-definer-word pprint-word dup pprint-word
+ <block struct-slots [ pprint-struct-slot ] each
+ block> pprint-; block> ;
+
+M: struct pprint-delims
+ drop \ S{ \ } ;
+
+M: struct >pprint-sequence
+ [ class ] [ struct-slot-values ] bi class-slot-sequence ;
+
+M: struct pprint*
+ [ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
--- /dev/null
+! (c)Joe Groff bsd license
+USING: alien classes help.markup help.syntax kernel libc
+quotations slots ;
+IN: classes.struct
+
+HELP: <struct-boa>
+{ $values
+ { "class" class }
+}
+{ $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ;
+
+HELP: <struct>
+{ $values
+ { "class" class }
+ { "struct" struct }
+}
+{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized with the initial values specified in the struct definition." } ;
+
+{ <struct> <struct-boa> malloc-struct memory>struct } related-words
+
+HELP: STRUCT:
+{ $syntax "STRUCT: class { slot type } { slot type } ... ;" }
+{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
+{ $description "Defines a new " { $link struct } " type. The syntax is nearly identical to " { $link POSTPONE: TUPLE: } "; however, there are some additional restrictions on struct types:"
+{ $list
+{ "Struct classes cannot have a superclass defined." }
+{ "The slots of a struct must all have a type declared. The type must be a C type." }
+{ { $link read-only } " slots on structs are not enforced, though they may be declared." }
+} } ;
+
+HELP: S{
+{ $syntax "S{ class slots... }" }
+{ $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } }
+{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ;
+
+HELP: UNION-STRUCT:
+{ $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" }
+{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
+{ $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ;
+
+HELP: define-struct-class
+{ $values
+ { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
+}
+{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ;
+
+HELP: define-union-struct-class
+{ $values
+ { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
+}
+{ $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ;
+
+HELP: malloc-struct
+{ $values
+ { "class" class }
+ { "struct" struct }
+}
+{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized. The struct should be " { $link free } "d when it is no longer needed." } ;
+
+HELP: memory>struct
+{ $values
+ { "ptr" c-ptr } { "class" class }
+ { "struct" struct }
+}
+{ $description "Constructs a new " { $link struct } " of the specified " { $snippet "class" } " at the memory location referenced by " { $snippet "ptr" } ". The referenced memory is unchanged." } ;
+
+HELP: struct
+{ $class-description "The parent class of all struct types." } ;
+
+{ struct POSTPONE: STRUCT: POSTPONE: UNION-STRUCT: } related-words
+
+HELP: struct-class
+{ $class-description "The metaclass of all " { $link struct } " classes." } ;
+
+ARTICLE: "classes.struct" "Struct classes"
+{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:"
+{ $subsection POSTPONE: STRUCT: }
+"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:"
+{ $subsection <struct> }
+{ $subsection <struct-boa> }
+{ $subsection malloc-struct }
+{ $subsection memory>struct }
+"Structs have literal syntax like tuples:"
+{ $subsection POSTPONE: S{ }
+"Union structs are also supported, which behave like structs but share the same memory for all the type's slots."
+{ $subsection POSTPONE: UNION-STRUCT: }
+;
+
+ABOUT: "classes.struct"
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors alien.c-types alien.libraries
+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 compiler.tree.debugger struct-arrays
+classes.tuple.private specialized-arrays.direct.int
+compiler.units ;
+IN: classes.struct.tests
+
+<<
+: libfactor-ffi-tests-path ( -- string )
+ "resource:" (normalize-path)
+ {
+ { [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
+ { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
+ { [ os unix? ] [ "libfactor-ffi-test.so" ] }
+ } cond append-path ;
+
+"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
+
+"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 }
+ { z bool } ;
+
+STRUCT: struct-test-bar
+ { w ushort initial: HEX: ffff }
+ { foo struct-test-foo } ;
+
+[ 12 ] [ struct-test-foo heap-size ] unit-test
+[ 12 ] [ struct-test-foo <struct> byte-length ] unit-test
+[ 16 ] [ struct-test-bar heap-size ] unit-test
+[ 123 ] [ struct-test-foo <struct> y>> ] unit-test
+[ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
+
+[ 1 2 3 t ] [
+ 1 2 3 t struct-test-foo <struct-boa> struct-test-bar <struct-boa>
+ {
+ [ w>> ]
+ [ foo>> x>> ]
+ [ foo>> y>> ]
+ [ foo>> z>> ]
+ } cleave
+] unit-test
+
+[ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
+[ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
+
+UNION-STRUCT: struct-test-float-and-bits
+ { f float }
+ { bits uint } ;
+
+[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
+[ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
+
+[ ] [ [ struct-test-foo malloc-struct &free drop ] with-destructors ] unit-test
+
+STRUCT: struct-test-string-ptr
+ { x char* } ;
+
+[ "hello world" ] [
+ [
+ struct-test-string-ptr <struct>
+ "hello world" utf8 malloc-string &free >>x
+ x>>
+ ] with-destructors
+] unit-test
+
+[ "S{ struct-test-foo { y 7654 } }" ]
+[
+ f boa-tuples?
+ [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
+ with-variable
+] unit-test
+
+[ "S{ struct-test-foo f 0 7654 f }" ]
+[
+ t boa-tuples?
+ [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
+ with-variable
+] unit-test
+
+[ <" USING: classes.struct ;
+IN: classes.struct.tests
+STRUCT: struct-test-foo
+ { x char initial: 0 } { y int initial: 123 } { z bool } ;
+"> ]
+[ [ struct-test-foo see ] with-string-writer ] unit-test
+
+[ <" USING: classes.struct ;
+IN: classes.struct.tests
+UNION-STRUCT: struct-test-float-and-bits
+ { f float initial: 0.0 } { bits uint initial: 0 } ;
+"> ]
+[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
+
+[ {
+ T{ field-spec
+ { name "x" }
+ { offset 0 }
+ { type "char" }
+ { reader x>> }
+ { writer (>>x) }
+ }
+ T{ field-spec
+ { name "y" }
+ { offset 4 }
+ { type "int" }
+ { reader y>> }
+ { writer (>>y) }
+ }
+ T{ field-spec
+ { name "z" }
+ { offset 8 }
+ { type "bool" }
+ { reader z>> }
+ { writer (>>z) }
+ }
+} ] [ "struct-test-foo" c-type fields>> ] unit-test
+
+[ {
+ T{ field-spec
+ { name "f" }
+ { offset 0 }
+ { type "float" }
+ { reader f>> }
+ { writer (>>f) }
+ }
+ T{ field-spec
+ { name "bits" }
+ { offset 0 }
+ { type "uint" }
+ { reader bits>> }
+ { writer (>>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 } ;
+
+LIBRARY: f-cdecl
+FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ;
+
+[ 14 ] [ 1 2 3 struct-test-ffi-foo <struct-boa> 4 ffi_test_11 ] unit-test
+
+STRUCT: struct-test-array-slots
+ { x int }
+ { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
+ { z int } ;
+
+[ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
+
+[ t ] [
+ struct-test-array-slots <struct>
+ [ 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
--- /dev/null
+! (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.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 } ;
+
+TUPLE: struct-slot-spec < slot-spec
+ c-type ;
+
+PREDICATE: struct-class < tuple-class
+ { [ \ struct subclass-of? ] [ all-slots length 1 = ] } 1&& ;
+
+: struct-slots ( struct -- slots )
+ "struct-slots" word-prop ;
+
+! struct allocation
+
+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 )
+ [ 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
+
+: (struct) ( class -- struct )
+ [ heap-size <byte-array> ] keep memory>struct ; inline
+
+: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
+
+: <struct> ( class -- struct )
+ dup struct-prototype
+ [ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline
+
+MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
+ [
+ [ <wrapper> \ (struct) [ ] 2sequence ]
+ [
+ struct-slots
+ [ length \ ndip ]
+ [ [ name>> setter-word 1quotation ] map \ spread ] bi
+ ] bi
+ ] [ ] output>sequence ;
+
+: pad-struct-slots ( values class -- values' class )
+ [ struct-slots [ initial>> ] map over length tail append ] keep ;
+
+: (reader-quot) ( slot -- quot )
+ [ c-type>> c-type-getter-boxer ]
+ [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+
+: (writer-quot) ( slot -- quot )
+ [ c-type>> c-setter ]
+ [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+
+: (boxer-quot) ( class -- quot )
+ '[ _ memory>struct ] ;
+
+: (unboxer-quot) ( class -- quot )
+ drop [ >c-ptr ] ;
+
+M: struct-class boa>object
+ swap pad-struct-slots
+ [ (struct) ] [ struct-slots ] bi
+ [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
+
+! Struct slot accessors
+
+GENERIC: struct-slot-values ( struct -- sequence )
+
+M: struct-class reader-quot
+ nip (reader-quot) ;
+
+M: struct-class writer-quot
+ nip (writer-quot) ;
+
+: struct-slot-values-quot ( class -- quot )
+ struct-slots
+ [ name>> reader-word 1quotation ] map
+ \ cleave [ ] 2sequence
+ \ output>array [ ] 2sequence ;
+
+: (define-struct-slot-values-method) ( class -- )
+ [ \ struct-slot-values create-method-in ]
+ [ struct-slot-values-quot ] bi define ;
+
+: (define-byte-length-method) ( class -- )
+ [ \ byte-length create-method-in ]
+ [ heap-size \ drop swap [ ] 2sequence ] bi define ;
+
+! Struct as c-type
+
+: slot>field ( slot -- field )
+ field-spec new swap {
+ [ name>> >>name ]
+ [ offset>> >>offset ]
+ [ c-type>> >>type ]
+ [ name>> reader-word >>reader ]
+ [ name>> writer-word >>writer ]
+ } cleave ;
+
+: define-struct-for-class ( class -- )
+ [
+ {
+ [ name>> ]
+ [ "struct-size" word-prop ]
+ [ "struct-align" word-prop ]
+ [ struct-slots [ slot>field ] map ]
+ } cleave
+ struct-type (define-struct)
+ ] [
+ {
+ [ name>> c-type ]
+ [ (unboxer-quot) >>unboxer-quot ]
+ [ (boxer-quot) >>boxer-quot ]
+ [ >>boxed-class ]
+ } cleave drop
+ ] bi ;
+
+: align-offset ( offset class -- offset' )
+ c-type-align align ;
+
+: struct-offsets ( slots -- size )
+ 0 [
+ [ c-type>> align-offset ] keep
+ [ (>>offset) ] [ c-type>> heap-size + ] 2bi
+ ] reduce ;
+
+: union-struct-offsets ( slots -- size )
+ [ 0 >>offset c-type>> heap-size ] [ max ] map-reduce ;
+
+: struct-align ( slots -- align )
+ [ c-type>> c-type-align ] [ max ] map-reduce ;
+
+M: struct-class c-type
+ name>> c-type ;
+
+M: struct-class c-type-align
+ "struct-align" word-prop ;
+
+M: struct-class c-type-getter
+ drop [ swap <displaced-alien> ] ;
+
+M: struct-class c-type-setter
+ [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
+ '[ @ swap @ _ memcpy ] ;
+
+M: struct-class c-type-boxer-quot
+ (boxer-quot) ;
+
+M: struct-class c-type-unboxer-quot
+ (unboxer-quot) ;
+
+M: struct-class heap-size
+ "struct-size" word-prop ;
+
+! class definition
+
+: make-struct-prototype ( class -- prototype )
+ [ heap-size <byte-array> ]
+ [ memory>struct ]
+ [ struct-slots ] tri
+ [
+ [ initial>> ]
+ [ (writer-quot) ] bi
+ over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
+ ] each ;
+
+: (struct-methods) ( class -- )
+ [ (define-struct-slot-values-method) ]
+ [ (define-byte-length-method) ] bi ;
+
+: (struct-word-props) ( class slots size align -- )
+ [
+ [ "struct-slots" set-word-prop ]
+ [ define-accessors ] 2bi
+ ]
+ [ "struct-size" set-word-prop ]
+ [ "struct-align" set-word-prop ] tri-curry*
+ [ tri ] 3curry
+ [ 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 -- )
+ [
+ [ struct-must-have-slots ]
+ [ drop struct f define-tuple-class ] if-empty
+ ]
+ swap '[
+ make-slots dup
+ [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
+ (struct-word-props)
+ ]
+ [ drop define-struct-for-class ] 2tri ; inline
+
+: define-struct-class ( class slots -- )
+ [ struct-offsets ] (define-struct-class) ;
+
+: define-union-struct-class ( class slots -- )
+ [ union-struct-offsets ] (define-struct-class) ;
+
+ERROR: invalid-struct-slot token ;
+
+: struct-slot-class ( c-type -- class' )
+ c-type c-type-boxed-class
+ dup \ byte-array = [ drop \ c-ptr ] when ;
+
+: parse-struct-slot ( -- slot )
+ struct-slot-spec new
+ scan >>name
+ scan [ >>c-type ] [ struct-slot-class >>class ] bi
+ \ } parse-until [ dup empty? ] [ peel-off-attributes ] until drop ;
+
+: parse-struct-slots ( slots -- slots' more? )
+ scan {
+ { ";" [ f ] }
+ { "{" [ parse-struct-slot over push t ] }
+ [ invalid-struct-slot ]
+ } case ;
+
+: parse-struct-definition ( -- class slots )
+ CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
+
+SYNTAX: STRUCT:
+ parse-struct-definition define-struct-class ;
+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
: NSApp ( -- app ) NSApplication -> sharedApplication ;
-: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline
+CONSTANT: NSAnyEventMask HEX: ffffffff
FUNCTION: void NSBeep ( ) ;
! 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' )
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
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 ;
: ^^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
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 ;
! 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 ;
! 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 ;
compiler.cfg.intrinsics.slots
compiler.cfg.intrinsics.misc
compiler.cfg.comparisons ;
+QUALIFIED: alien
+QUALIFIED: alien.accessors
QUALIFIED: kernel
QUALIFIED: arrays
QUALIFIED: byte-arrays
QUALIFIED: math.private
QUALIFIED: math.integers.private
QUALIFIED: math.libm
-QUALIFIED: alien.accessors
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
{ \ 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 ] }
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 ;
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 } ;
! 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
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 ;
[ 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 ] }
{ \ ##sar-imm [ simplify-shr ] }
{ \ ##shl [ simplify-shl ] }
{ \ ##shl-imm [ simplify-shl ] }
+ { \ ##box-displaced-alien [ simplify-box-displaced-alien ] }
[ 2drop f ]
} case ;
] 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
[
{
] unit-test
[ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test
+
! 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
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
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 ;
-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
<<
[ "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 ;
[ "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
[ 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 ;
[ 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
] 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 ) ;
[ 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 )
[ 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 )
[ 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 )
[ 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 )
[ 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 ;
] 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
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
\ No newline at end of file
+[ 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
\ No newline at end of file
] 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
[ 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
] ;
: 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
! 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
(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
: cached-line ( font string -- line )
cached-lines get [ <line> ] 2cache ;
-[ <cache-assoc> cached-lines set-global ] "core-text" add-init-hook
\ No newline at end of file
+[ <cache-assoc> cached-lines set-global ] "core-text" add-init-hook
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 -- )
: 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 ;
: 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 ;
MACRO: nsequence ( n seq -- )
[
- [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
+ [ drop iota <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
] keep
'[ @ _ like ] ;
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 ] ] [
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 -- )
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" [
: 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
{
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! 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* ;
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
-GENERIC: load-image* ( path class -- image )
-
: bytes-per-component ( component-type -- n )
{
{ ubyte-components [ 1 ] }
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
{ 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 )
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 ;
-
! 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 ;
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 ;
[ 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 ;
: 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
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
[ 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
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 ;
: 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 ;
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 ;"
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"
{ 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'{ \ } ;
--- /dev/null
+! (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 ;
+
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
\ No newline at end of file
+[ 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
! 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>> ; inline
+M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
-M: struct-array length length>> ;
-M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ;
+: (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
{ +name+ "FactorApplicationDelegate" }
}
-{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
+{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
[ 3drop reset-run-loop ]
} ;
! Rendering
{ "drawRect:" "void" { "id" "SEL" "NSRect" }
- [ 2drop window relayout-1 ]
+ [ 2drop window relayout-1 yield ]
}
! Events
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
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() {
update() {
get_config_info
- git_pull_factorcode
+ git_fetch_factorcode
backup_factor
make_clean
make_factor
kernel math namespaces parser prettyprint sequences strings\r
tools.test words quotations classes classes.algebra\r
classes.private classes.union classes.mixin classes.predicate\r
-vectors definitions source-files compiler.units growable\r
-random stack-checker effects kernel.private sbufs math.order\r
+vectors source-files compiler.units growable random\r
+stack-checker effects kernel.private sbufs math.order\r
classes.tuple accessors ;\r
IN: classes.algebra.tests\r
\r
! UNION: u1 sa sb ;\r
! UNION: u2 sc ;\r
\r
-! [ f ] [ u1 u2 classes-intersect? ] unit-test
\ No newline at end of file
+! [ f ] [ u1 u2 classes-intersect? ] unit-test\r
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
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 ;
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 ;
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
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 ;
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 ;
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
[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test
[ t ] [ 0 array-capacity? ] unit-test
-[ f ] [ -1 array-capacity? ] unit-test
\ No newline at end of file
+[ f ] [ -1 array-capacity? ] unit-test
<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
: 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>
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?
[ 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
[ 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
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: accessors assocs classes classes.struct combinators
-kernel math prettyprint.backend prettyprint.custom
-prettyprint.sections see.private sequences words ;
-IN: classes.struct.prettyprint
-
-<PRIVATE
-
-: struct-definer-word ( class -- word )
- struct-slots dup length 2 >=
- [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
- [ drop \ STRUCT: ] if ;
-
-: struct>assoc ( struct -- assoc )
- [ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ;
-
-: pprint-struct-slot ( slot -- )
- <flow \ { pprint-word
- {
- [ name>> text ]
- [ c-type>> text ]
- [ read-only>> [ \ read-only pprint-word ] when ]
- [ initial>> [ \ initial: pprint-word pprint* ] when* ]
- } cleave
- \ } pprint-word block> ;
-
-PRIVATE>
-
-M: struct-class see-class*
- <colon dup struct-definer-word pprint-word dup pprint-word
- <block struct-slots [ pprint-struct-slot ] each
- block> pprint-; block> ;
-
-M: struct pprint-delims
- drop \ S{ \ } ;
-
-M: struct >pprint-sequence
- [ class ] [ struct-slot-values ] bi class-slot-sequence ;
-
-M: struct pprint*
- [ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: alien classes help.markup help.syntax kernel libc
-quotations slots ;
-IN: classes.struct
-
-HELP: <struct-boa>
-{ $values
- { "class" class }
-}
-{ $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ;
-
-HELP: <struct>
-{ $values
- { "class" class }
- { "struct" struct }
-}
-{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized with the initial values specified in the struct definition." } ;
-
-{ <struct> <struct-boa> malloc-struct memory>struct } related-words
-
-HELP: STRUCT:
-{ $syntax "STRUCT: class { slot type } { slot type } ... ;" }
-{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
-{ $description "Defines a new " { $link struct } " type. The syntax is nearly identical to " { $link POSTPONE: TUPLE: } "; however, there are some additional restrictions on struct types:"
-{ $list
-{ "Struct classes cannot have a superclass defined." }
-{ "The slots of a struct must all have a type declared. The type must be a C type." }
-{ { $link read-only } " slots on structs are not enforced, though they may be declared." }
-} } ;
-
-HELP: S{
-{ $syntax "S{ class slots... }" }
-{ $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } }
-{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ;
-
-HELP: UNION-STRUCT:
-{ $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" }
-{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
-{ $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ;
-
-HELP: define-struct-class
-{ $values
- { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
-}
-{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ;
-
-HELP: define-union-struct-class
-{ $values
- { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
-}
-{ $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ;
-
-HELP: malloc-struct
-{ $values
- { "class" class }
- { "struct" struct }
-}
-{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized. The struct should be " { $link free } "d when it is no longer needed." } ;
-
-HELP: memory>struct
-{ $values
- { "ptr" c-ptr } { "class" class }
- { "struct" struct }
-}
-{ $description "Constructs a new " { $link struct } " of the specified " { $snippet "class" } " at the memory location referenced by " { $snippet "ptr" } ". The referenced memory is unchanged." } ;
-
-HELP: struct
-{ $class-description "The parent class of all struct types." } ;
-
-{ struct POSTPONE: STRUCT: POSTPONE: UNION-STRUCT: } related-words
-
-HELP: struct-class
-{ $class-description "The metaclass of all " { $link struct } " classes." } ;
-
-ARTICLE: "classes.struct" "Struct classes"
-{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:"
-{ $subsection POSTPONE: STRUCT: }
-"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:"
-{ $subsection <struct> }
-{ $subsection <struct-boa> }
-{ $subsection malloc-struct }
-{ $subsection memory>struct }
-"Structs have literal syntax like tuples:"
-{ $subsection POSTPONE: S{ }
-"Union structs are also supported, which behave like structs but share the same memory for all the type's slots."
-{ $subsection POSTPONE: UNION-STRUCT: }
-;
-
-ABOUT: "classes.struct"
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: accessors alien.c-types alien.libraries
-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 ;
-IN: classes.struct.tests
-
-<<
-: libfactor-ffi-tests-path ( -- string )
- "resource:" (normalize-path)
- {
- { [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
- { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
- { [ os unix? ] [ "libfactor-ffi-test.so" ] }
- } cond append-path ;
-
-"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
-
-"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
->>
-
-STRUCT: struct-test-foo
- { x char }
- { y int initial: 123 }
- { z bool } ;
-
-STRUCT: struct-test-bar
- { w ushort initial: HEX: ffff }
- { foo struct-test-foo } ;
-
-[ 12 ] [ struct-test-foo heap-size ] unit-test
-[ 12 ] [ struct-test-foo <struct> byte-length ] unit-test
-[ 16 ] [ struct-test-bar heap-size ] unit-test
-[ 123 ] [ struct-test-foo <struct> y>> ] unit-test
-[ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
-
-[ 1 2 3 t ] [
- 1 2 3 t struct-test-foo <struct-boa> struct-test-bar <struct-boa>
- {
- [ w>> ]
- [ foo>> x>> ]
- [ foo>> y>> ]
- [ foo>> z>> ]
- } cleave
-] unit-test
-
-[ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
-[ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
-
-UNION-STRUCT: struct-test-float-and-bits
- { f float }
- { bits uint } ;
-
-[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
-[ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
-
-[ ] [ [ struct-test-foo malloc-struct &free drop ] with-destructors ] unit-test
-
-STRUCT: struct-test-string-ptr
- { x char* } ;
-
-[ "hello world" ] [
- [
- struct-test-string-ptr <struct>
- "hello world" utf8 malloc-string &free >>x
- x>>
- ] with-destructors
-] unit-test
-
-[ "S{ struct-test-foo { y 7654 } }" ]
-[
- f boa-tuples?
- [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
- with-variable
-] unit-test
-
-[ "S{ struct-test-foo f 0 7654 f }" ]
-[
- t boa-tuples?
- [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
- with-variable
-] unit-test
-
-[ <" USING: classes.struct ;
-IN: classes.struct.tests
-STRUCT: struct-test-foo
- { x char initial: 0 } { y int initial: 123 } { z bool } ;
-"> ]
-[ [ struct-test-foo see ] with-string-writer ] unit-test
-
-[ <" USING: classes.struct ;
-IN: classes.struct.tests
-UNION-STRUCT: struct-test-float-and-bits
- { f float initial: 0.0 } { bits uint initial: 0 } ;
-"> ]
-[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
-
-[ {
- T{ field-spec
- { name "x" }
- { offset 0 }
- { type "char" }
- { reader x>> }
- { writer (>>x) }
- }
- T{ field-spec
- { name "y" }
- { offset 4 }
- { type "int" }
- { reader y>> }
- { writer (>>y) }
- }
- T{ field-spec
- { name "z" }
- { offset 8 }
- { type "bool" }
- { reader z>> }
- { writer (>>z) }
- }
-} ] [ "struct-test-foo" c-type fields>> ] unit-test
-
-[ {
- T{ field-spec
- { name "f" }
- { offset 0 }
- { type "float" }
- { reader f>> }
- { writer (>>f) }
- }
- T{ field-spec
- { name "bits" }
- { offset 0 }
- { type "uint" }
- { reader bits>> }
- { writer (>>bits) }
- }
-} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
-
-STRUCT: struct-test-ffi-foo
- { x int }
- { y int } ;
-
-LIBRARY: f-cdecl
-FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ;
-
-[ 14 ] [ 1 2 3 struct-test-ffi-foo <struct-boa> 4 ffi_test_11 ] unit-test
-
-STRUCT: struct-test-array-slots
- { x int }
- { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
- { z int } ;
-
-[ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
-
-[ t ] [
- struct-test-array-slots <struct>
- [ y>> [ 8 3 ] dip set-nth ]
- [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
-] unit-test
+++ /dev/null
-! (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 ;
-FROM: slots => reader-word writer-word ;
-IN: classes.struct
-
-! struct class
-
-TUPLE: struct
- { (underlying) c-ptr read-only } ;
-
-TUPLE: struct-slot-spec < slot-spec
- c-type ;
-
-PREDICATE: struct-class < tuple-class
- \ struct subclass-of? ;
-
-: struct-slots ( struct -- slots )
- "struct-slots" word-prop ;
-
-! struct allocation
-
-M: struct >c-ptr
- 2 slot { c-ptr } declare ; inline
-
-: memory>struct ( ptr class -- struct )
- over c-ptr? [ swap \ c-ptr bad-slot-value ] unless
- tuple-layout <tuple> [ 2 set-slot ] keep ;
-
-: malloc-struct ( class -- struct )
- [ heap-size malloc ] keep memory>struct ; inline
-
-: (struct) ( class -- struct )
- [ heap-size <byte-array> ] keep memory>struct ; inline
-
-: <struct> ( class -- struct )
- dup "prototype" word-prop
- [ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline
-
-MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
- [
- [ <wrapper> \ (struct) [ ] 2sequence ]
- [
- struct-slots
- [ length \ ndip ]
- [ [ name>> setter-word 1quotation ] map \ spread ] bi
- ] bi
- ] [ ] output>sequence ;
-
-: pad-struct-slots ( values class -- values' class )
- [ struct-slots [ initial>> ] map over length tail append ] keep ;
-
-: (reader-quot) ( slot -- quot )
- [ c-type>> c-type-getter-boxer ]
- [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
-
-: (writer-quot) ( slot -- quot )
- [ c-type>> c-setter ]
- [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
-
-: (boxer-quot) ( class -- quot )
- '[ _ memory>struct ] ;
-
-: (unboxer-quot) ( class -- quot )
- drop [ >c-ptr ] ;
-
-M: struct-class boa>object
- swap pad-struct-slots
- [ (struct) ] [ struct-slots ] bi
- [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
-
-! Struct slot accessors
-
-GENERIC: struct-slot-values ( struct -- sequence )
-
-M: struct-class reader-quot
- nip (reader-quot) ;
-
-M: struct-class writer-quot
- nip (writer-quot) ;
-
-: struct-slot-values-quot ( class -- quot )
- struct-slots
- [ name>> reader-word 1quotation ] map
- \ cleave [ ] 2sequence
- \ output>array [ ] 2sequence ;
-
-: (define-struct-slot-values-method) ( class -- )
- [ \ struct-slot-values create-method-in ]
- [ struct-slot-values-quot ] bi define ;
-
-: (define-byte-length-method) ( class -- )
- [ \ byte-length create-method-in ]
- [ heap-size \ drop swap [ ] 2sequence ] bi define ;
-
-! Struct as c-type
-
-: slot>field ( slot -- field )
- field-spec new swap {
- [ name>> >>name ]
- [ offset>> >>offset ]
- [ c-type>> >>type ]
- [ name>> reader-word >>reader ]
- [ name>> writer-word >>writer ]
- } cleave ;
-
-: define-struct-for-class ( class -- )
- [
- {
- [ name>> ]
- [ "struct-size" word-prop ]
- [ "struct-align" word-prop ]
- [ struct-slots [ slot>field ] map ]
- } cleave
- struct-type (define-struct)
- ] [
- {
- [ name>> c-type ]
- [ (unboxer-quot) >>unboxer-quot ]
- [ (boxer-quot) >>boxer-quot ]
- [ >>boxed-class ]
- } cleave drop
- ] bi ;
-
-: align-offset ( offset class -- offset' )
- c-type-align align ;
-
-: struct-offsets ( slots -- size )
- 0 [
- [ c-type>> align-offset ] keep
- [ (>>offset) ] [ c-type>> heap-size + ] 2bi
- ] reduce ;
-
-: union-struct-offsets ( slots -- size )
- [ 0 >>offset c-type>> heap-size ] [ max ] map-reduce ;
-
-: struct-align ( slots -- align )
- [ c-type>> c-type-align ] [ max ] map-reduce ;
-
-M: struct-class c-type
- name>> c-type ;
-
-M: struct-class c-type-align
- "struct-align" word-prop ;
-
-M: struct-class c-type-getter
- drop [ swap <displaced-alien> ] ;
-
-M: struct-class c-type-setter
- [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
- '[ @ swap @ _ memcpy ] ;
-
-M: struct-class c-type-boxer-quot
- (boxer-quot) ;
-
-M: struct-class c-type-unboxer-quot
- (unboxer-quot) ;
-
-M: struct-class heap-size
- "struct-size" word-prop ;
-
-! class definition
-
-: struct-prototype ( class -- prototype )
- [ heap-size <byte-array> ]
- [ memory>struct ]
- [ struct-slots ] tri
- [
- [ initial>> ]
- [ (writer-quot) ] bi
- over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
- ] each ;
-
-: (struct-methods) ( class -- )
- [ (define-struct-slot-values-method) ]
- [ (define-byte-length-method) ] bi ;
-
-: (struct-word-props) ( class slots size align -- )
- [
- [ "struct-slots" set-word-prop ]
- [ define-accessors ] 2bi
- ]
- [ "struct-size" set-word-prop ]
- [ "struct-align" set-word-prop ] tri-curry*
- [ tri ] 3curry
- [ dup 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 ]
- swap '[
- make-slots dup
- [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
- (struct-word-props)
- ]
- [ drop define-struct-for-class ] 2tri ; inline
-
-: define-struct-class ( class slots -- )
- [ struct-offsets ] (define-struct-class) ;
-
-: define-union-struct-class ( class slots -- )
- [ union-struct-offsets ] (define-struct-class) ;
-
-ERROR: invalid-struct-slot token ;
-
-: struct-slot-class ( c-type -- class' )
- c-type c-type-boxed-class
- dup \ byte-array = [ drop \ c-ptr ] when ;
-
-: parse-struct-slot ( -- slot )
- struct-slot-spec new
- scan >>name
- scan [ >>c-type ] [ struct-slot-class >>class ] bi
- \ } parse-until [ dup empty? ] [ peel-off-attributes ] until drop ;
-
-: parse-struct-slots ( slots -- slots' more? )
- scan {
- { ";" [ f ] }
- { "{" [ parse-struct-slot over push t ] }
- [ invalid-struct-slot ]
- } case ;
-
-: parse-struct-definition ( -- class slots )
- CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
-
-SYNTAX: STRUCT:
- parse-struct-definition define-struct-class ;
-SYNTAX: UNION-STRUCT:
- parse-struct-definition define-union-struct-class ;
-
-USING: vocabs vocabs.loader ;
-
-"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
-
-SYNTAX: S{
- scan-word dup struct-slots parse-tuple-literal-slots parsed ;
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
: 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 ;
: 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 ;
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 ;
[ [ 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
--- /dev/null
+! 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 ;
! 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 ;
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
include vm/Config.macosx
include vm/Config.x86.32
+CFLAGS += -m32
-#include <ucontext.h>
+#include <sys/ucontext.h>
namespace factor
{
-#include <ucontext.h>
+#include <sys/ucontext.h>
namespace factor
{
-#include <ucontext.h>
+#include <sys/ucontext.h>
namespace factor
{
projects / factor.git / commitdiff