"predicate" word-prop [ dupd call assure ] curry ;
: slot-readers ( class -- quot )
- all-slots [ name>> reader-word 1quotation ] map [ cleave ] curry ;
+ class-slots [ name>> reader-word 1quotation ] map [ cleave ] curry ;
: ?wrapped ( object -- wrapped )
dup wrapper? [ wrapped>> ] when ;
] if ; inline
: tuple>assoc ( tuple -- assoc )
- [ class all-slots ] [ tuple-slots ] bi zip
+ [ class class-slots ] [ object-slots ] bi zip
[ [ initial>> ] dip = not ] assoc-filter
[ [ name>> ] dip ] assoc-map ;
boa-tuples? get [ pprint-object ] [
[
<flow
- \ T{ pprint-word
+ dup pprint-delims drop pprint-word
dup class pprint-word
t <inset
- tuple>assoc [ pprint-slot-value ] assoc-each
+ dup tuple>assoc [ pprint-slot-value ] assoc-each
block>
- \ } pprint-word
+ pprint-delims nip pprint-word
block>
] check-recursion
] if ;
M: object >pprint-sequence ;
M: vector >pprint-sequence ;
M: byte-vector >pprint-sequence ;
-M: curry >pprint-sequence ;
-M: compose >pprint-sequence ;
+M: callable >pprint-sequence ;
M: hashtable >pprint-sequence >alist ;
M: wrapper >pprint-sequence wrapped>> 1array ;
M: callstack >pprint-sequence callstack>array ;
-M: tuple >pprint-sequence
- [ class ] [ tuple-slots ] bi
+: class-slot-sequence ( class slots -- sequence )
[ 1array ] [ [ f 2array ] dip append ] if-empty ;
+M: tuple >pprint-sequence
+ [ class ] [ object-slots ] bi class-slot-sequence ;
+
M: object pprint-narrow? drop f ;
M: byte-vector pprint-narrow? drop f ;
M: array pprint-narrow? drop t ;
! See http://factorcode.org/license.txt for BSD license.
USING: functors sequences sequences.private kernel words classes
math alien alien.c-types byte-arrays accessors
-specialized-arrays ;
+specialized-arrays prettyprint.custom ;
IN: specialized-arrays.direct.functor
FUNCTOR: define-direct-array ( T -- )
A' IS ${T}-array
>A' IS >${T}-array
<A'> IS <${A'}>
+A'{ IS ${A'}{
A DEFINES-CLASS direct-${T}-array
<A> DEFINES <${A}>
M: A like drop dup A instance? [ >A' ] unless ;
M: A new-sequence drop <A'> ;
+M: A pprint-delims drop \ A'{ \ } ;
+
+M: A >pprint-sequence ;
+
+M: A pprint* pprint-object ;
+
INSTANCE: A sequence
;FUNCTOR
: parse-slot-values ( -- values )
[ (parse-slot-values) ] { } make ;
-: boa>tuple ( class slots -- tuple )
+GENERIC# boa>object 1 ( class slots -- tuple )
+
+M: tuple-class boa>object
swap prefix >tuple ;
-: assoc>tuple ( class slots -- tuple )
- [ [ ] [ initial-values ] [ all-slots ] tri ] dip
- swap [ [ slot-named offset>> 2 - ] curry dip ] curry assoc-map
- [ dup <enum> ] dip update boa>tuple ;
+: assoc>object ( class slots -- tuple )
+ [ [ ] [ initial-values ] [ class-slots ] tri ] dip
+ swap [ [ slot-named* drop ] curry dip ] curry assoc-map
+ [ dup <enum> ] dip update boa>object ;
: parse-tuple-literal-slots ( class -- tuple )
scan {
{ f [ unexpected-eof ] }
- { "f" [ \ } parse-until boa>tuple ] }
- { "{" [ parse-slot-values assoc>tuple ] }
+ { "f" [ \ } parse-until boa>object ] }
+ { "{" [ parse-slot-values assoc>object ] }
{ "}" [ new ] }
[ bad-literal-tuple ]
} case ;
: all-slots ( class -- slots )
superclasses [ "slots" word-prop ] map concat ;
+GENERIC: class-slots ( class -- slots )
+
+M: tuple-class class-slots
+ all-slots ;
+
PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
all-slots [ read-only>> ] all? ;
PRIVATE>
-: initial-values ( class -- slots )
+: tuple-initial-values ( class -- slots )
all-slots [ initial>> ] map ;
+: initial-values ( class -- slots )
+ class-slots [ initial>> ] map ;
+
: pad-slots ( slots class -- slots' class )
- [ initial-values over length tail append ] keep ; inline
+ [ tuple-initial-values over length tail append ] keep ; inline
: tuple>array ( tuple -- array )
prepare-tuple>array
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
+GENERIC: object-slots ( object -- seq )
+M: tuple object-slots
+ tuple-slots ;
+
GENERIC: slots>tuple ( seq class -- tuple )
M: tuple-class slots>tuple ( seq class -- tuple )
dup boa-check-quot "boa-check" set-word-prop ;
: tuple-prototype ( class -- prototype )
- [ initial-values ] keep over [ ] any?
+ [ tuple-initial-values ] keep over [ ] any?
[ slots>tuple ] [ 2drop f ] if ;
: define-tuple-prototype ( class -- )
[ "e" string>number ]
unit-test
+[ 100000 ]
+[ "100,000" string>number ]
+unit-test
+
+[ 100000.0 ]
+[ "100,000.0" string>number ]
+unit-test
+
[ "100.0" ]
[ "1.0e2" string>number number>string ]
unit-test
{ CHAR: d 13 }
{ CHAR: e 14 }
{ CHAR: f 15 }
- } at 255 or ; inline
+ { CHAR: , f }
+ } at* [ drop 255 ] unless ; inline
: string>digits ( str -- digits )
[ digit> ] B{ } map-as ; inline
: (digits>integer) ( valid? accum digit radix -- valid? accum )
- 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline
+ over [
+ 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if
+ ] [ 2drop ] if ; inline
: each-digit ( seq radix quot -- n/f )
[ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
] if ; inline
: string>float ( str -- n/f )
+ [ CHAR: , eq? not ] filter
>byte-array 0 suffix (string>float) ;
PRIVATE>
{
{ [ \ f bootstrap-word over class<= ] [ f ] }
{ [ \ array-capacity bootstrap-word over class<= ] [ 0 ] }
+ { [ dup \ integer bootstrap-word class<= ] [ 0 ] }
{ [ float bootstrap-word over class<= ] [ 0.0 ] }
{ [ string bootstrap-word over class<= ] [ "" ] }
{ [ array bootstrap-word over class<= ] [ { } ] }
: finalize-slots ( specs base -- specs )
over length iota [ + ] with map [ >>offset ] 2map ;
+: slot-named* ( name specs -- offset spec/f )
+ [ name>> = ] with find ;
+
: slot-named ( name specs -- spec/f )
- [ name>> = ] with find nip ;
+ slot-named* nip ;
--- /dev/null
+! (c)Joe Groff bsd license
+USING: alien arrays classes help.markup help.syntax kernel math
+specialized-arrays.direct ;
+IN: classes.c-types
+
+HELP: c-type-class
+{ $class-description "This metaclass encompasses the " { $link "classes.c-types" } "." } ;
+
+HELP: char
+{ $class-description "A signed one-byte integer quantity." } ;
+
+HELP: direct-array-of
+{ $values
+ { "alien" c-ptr } { "len" integer } { "class" c-type-class }
+ { "array" "a direct array" }
+}
+{ $description "Constructs one of the " { $link "specialized-arrays.direct" } " over " { $snippet "len" } " elements of type " { $snippet "class" } " located at the referenced location in raw memory." } ;
+
+HELP: int
+{ $class-description "A signed four-byte integer quantity." } ;
+
+HELP: long
+{ $class-description "A signed integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ;
+
+HELP: longlong
+{ $class-description "A signed eight-byte integer quantity." } ;
+
+HELP: short
+{ $class-description "A signed two-byte integer quantity." } ;
+
+HELP: single-complex
+{ $class-description "A single-precision complex floating point quantity." } ;
+
+HELP: single-float
+{ $class-description "A single-precision floating point quantity." } ;
+
+HELP: uchar
+{ $class-description "An unsigned one-byte integer quantity." } ;
+
+HELP: uint
+{ $class-description "An unsigned four-byte integer quantity." } ;
+
+HELP: ulong
+{ $class-description "An unsigned integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ;
+
+HELP: ulonglong
+{ $class-description "An unsigned eight-byte integer quantity." } ;
+
+HELP: ushort
+{ $class-description "An unsigned two-byte integer quantity." } ;
+
+ARTICLE: "classes.c-types" "C type classes"
+"The " { $vocab-link "classes.c-types" } " vocabulary defines Factor classes that correspond to C types in the FFI."
+{ $subsection char }
+{ $subsection uchar }
+{ $subsection short }
+{ $subsection ushort }
+{ $subsection int }
+{ $subsection uint }
+{ $subsection long }
+{ $subsection ulong }
+{ $subsection longlong }
+{ $subsection ulonglong }
+{ $subsection single-float }
+{ $subsection float }
+{ $subsection single-complex }
+{ $subsection complex }
+{ $subsection pinned-c-ptr }
+"The vocabulary also provides a word for constructing " { $link "specialized-arrays.direct" } " of C types over raw memory:"
+{ $subsection direct-array-of } ;
+
+ABOUT: "classes.c-types"
--- /dev/null
+! (c)Joe Groff bsd license
+USING: alien alien.c-types classes classes.predicate kernel
+math math.bitwise math.order namespaces sequences words
+specialized-arrays.direct.alien
+specialized-arrays.direct.bool
+specialized-arrays.direct.char
+specialized-arrays.direct.complex-double
+specialized-arrays.direct.complex-float
+specialized-arrays.direct.double
+specialized-arrays.direct.float
+specialized-arrays.direct.int
+specialized-arrays.direct.long
+specialized-arrays.direct.longlong
+specialized-arrays.direct.short
+specialized-arrays.direct.uchar
+specialized-arrays.direct.uint
+specialized-arrays.direct.ulong
+specialized-arrays.direct.ulonglong
+specialized-arrays.direct.ushort ;
+IN: classes.c-types
+
+PREDICATE: char < fixnum
+ HEX: -80 HEX: 7f between? ;
+
+PREDICATE: uchar < fixnum
+ HEX: 0 HEX: ff between? ;
+
+PREDICATE: short < fixnum
+ HEX: -8000 HEX: 7fff between? ;
+
+PREDICATE: ushort < fixnum
+ HEX: 0 HEX: ffff between? ;
+
+PREDICATE: int < integer
+ HEX: -8000,0000 HEX: 7fff,ffff between? ;
+
+PREDICATE: uint < integer
+ HEX: 0 HEX: ffff,ffff between? ;
+
+PREDICATE: longlong < integer
+ HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ;
+
+PREDICATE: ulonglong < integer
+ HEX: 0 HEX: ffff,ffff,ffff,ffff between? ;
+
+UNION: single-float float ;
+UNION: single-complex complex ;
+
+SYMBOLS: long ulong long-bits ;
+
+<<
+ "long" heap-size 8 =
+ [
+ \ long integer [ HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ] define-predicate-class
+ \ ulong integer [ HEX: 0 HEX: ffff,ffff,ffff,ffff between? ] define-predicate-class
+ 64 \ long-bits set-global
+ ] [
+ \ long integer [ HEX: -8000,0000 HEX: 7fff,ffff between? ] define-predicate-class
+ \ ulong integer [ HEX: 0 HEX: ffff,ffff between? ] define-predicate-class
+ 32 \ long-bits set-global
+ ] if
+>>
+
+: set-class-c-type ( class c-type <direct-array> -- )
+ [ "class-c-type" set-word-prop ]
+ [ "class-direct-array" set-word-prop ] bi-curry* bi ;
+
+: class-c-type ( class -- c-type )
+ "class-c-type" word-prop ;
+: class-direct-array ( class -- <direct-array> )
+ "class-direct-array" word-prop ;
+
+alien "void*" \ <direct-void*-array> set-class-c-type
+\ f "void*" \ <direct-void*-array> set-class-c-type
+pinned-c-ptr "void*" \ <direct-void*-array> set-class-c-type
+boolean "bool" \ <direct-bool-array> set-class-c-type
+char "char" \ <direct-char-array> set-class-c-type
+uchar "uchar" \ <direct-uchar-array> set-class-c-type
+short "short" \ <direct-short-array> set-class-c-type
+ushort "ushort" \ <direct-ushort-array> set-class-c-type
+int "int" \ <direct-int-array> set-class-c-type
+uint "uint" \ <direct-uint-array> set-class-c-type
+long "long" \ <direct-long-array> set-class-c-type
+ulong "ulong" \ <direct-ulong-array> set-class-c-type
+longlong "longlong" \ <direct-longlong-array> set-class-c-type
+ulonglong "ulonglong" \ <direct-ulonglong-array> set-class-c-type
+float "double" \ <direct-double-array> set-class-c-type
+single-float "float" \ <direct-float-array> set-class-c-type
+complex "complex-double" \ <direct-complex-double-array> set-class-c-type
+single-complex "complex-float" \ <direct-complex-float-array> set-class-c-type
+
+char [ 8 bits 8 >signed ] "coercer" set-word-prop
+uchar [ 8 bits ] "coercer" set-word-prop
+short [ 16 bits 16 >signed ] "coercer" set-word-prop
+ushort [ 16 bits ] "coercer" set-word-prop
+int [ 32 bits 32 >signed ] "coercer" set-word-prop
+uint [ 32 bits ] "coercer" set-word-prop
+long [ [ bits ] [ >signed ] ] long-bits get-global prefix "coercer" set-word-prop
+ulong [ bits ] long-bits get-global prefix "coercer" set-word-prop
+longlong [ 64 bits 64 >signed ] "coercer" set-word-prop
+ulonglong [ 64 bits ] "coercer" set-word-prop
+
+PREDICATE: c-type-class < class
+ "class-c-type" word-prop ;
+
+GENERIC: direct-array-of ( alien len class -- array )
+
+M: c-type-class direct-array-of
+ class-direct-array execute( alien len -- array ) ; inline
+
+M: c-type-class c-type class-c-type c-type ;
+M: c-type-class c-type-align class-c-type c-type-align ;
+M: c-type-class c-type-getter class-c-type c-type-getter ;
+M: c-type-class c-type-setter class-c-type c-type-setter ;
+M: c-type-class c-type-boxer-quot class-c-type c-type-boxer-quot ;
+M: c-type-class c-type-unboxer-quot class-c-type c-type-unboxer-quot ;
+M: c-type-class heap-size class-c-type heap-size ;
+
--- /dev/null
+! (c)Joe Groff bsd license
+USING: classes.struct kernel prettyprint.backend prettyprint.custom
+prettyprint.sections see.private sequences words ;
+IN: classes.struct.prettyprint
+
+M: struct-class see-class*
+ <colon \ STRUCT: pprint-word dup pprint-word
+ <block "struct-slots" word-prop [ pprint-slot ] each
+ block> pprint-; block> ;
+
+M: struct pprint-delims
+ drop \ S{ \ } ;
+
--- /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 either another struct class, or one of the " { $link "classes.c-types" } "." }
+{ { $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 " }" } "; in fact, " { $snippet "T{" } " and " { $snippet "S{" } " can be used interchangeably. Structs will always be printed with " { $snippet "S{" } "." } ;
+
+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 classes.c-types classes.struct
+combinators inverse kernel math tools.test ;
+IN: classes.struct.tests
+
+STRUCT: foo
+ { x char }
+ { y int initial: 123 }
+ { z boolean } ;
+
+STRUCT: bar
+ { w ushort initial: HEX: ffff }
+ { foo foo } ;
+
+[ 12 ] [ foo heap-size ] unit-test
+[ 16 ] [ bar heap-size ] unit-test
+[ 123 ] [ foo <struct> y>> ] unit-test
+[ 123 ] [ bar <struct> foo>> y>> ] unit-test
+
+[ 1 2 3 t ] [
+ 1 2 3 t foo <struct-boa> bar <struct-boa>
+ {
+ [ w>> ]
+ [ foo>> x>> ]
+ [ foo>> y>> ]
+ [ foo>> z>> ]
+ } cleave
+] unit-test
+
+[ 7654 ] [ S{ foo f 98 7654 f } y>> ] unit-test
+[ 7654 ] [ S{ foo { y 7654 } } y>> ] unit-test
+
+[ 98 7654 t ] [ S{ foo f 98 7654 t } [ foo <struct-boa> ] undo ] unit-test
+
+UNION-STRUCT: float-and-bits
+ { f single-float }
+ { bits uint } ;
+
+[ 1.0 ] [ float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
+
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors alien alien.c-types byte-arrays classes
+classes.c-types classes.parser classes.tuple
+classes.tuple.parser classes.tuple.private combinators
+combinators.smart fry generalizations generic.parser kernel
+kernel.private libc macros make math math.order quotations
+sequences slots slots.private struct-arrays words ;
+IN: classes.struct
+
+! struct class
+
+TUPLE: struct
+ { (underlying) c-ptr read-only } ;
+
+PREDICATE: struct-class < tuple-class
+ \ struct subclass-of? ;
+
+! 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" word-prop
+ [ length \ ndip ]
+ [ [ name>> setter-word 1quotation ] map \ spread ] bi
+ ] bi
+ ] [ ] output>sequence ;
+
+: pad-struct-slots ( slots class -- slots' class )
+ [ class-slots [ initial>> ] map over length tail append ] keep ;
+
+M: struct-class boa>object
+ swap pad-struct-slots
+ [ (struct) swap ] [ "struct-slots" word-prop ] bi
+ [ name>> setter-word execute( struct value -- struct ) ] 2each ;
+
+! Struct slot accessors
+
+M: struct-class reader-quot
+ nip
+ [ class>> c-type-getter-boxer ]
+ [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+
+: (writer-quot) ( slot -- quot )
+ [ class>> c-setter ]
+ [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+
+M: struct-class writer-quot
+ nip (writer-quot) ;
+
+M: struct-class class-slots
+ "struct-slots" word-prop ;
+
+: object-slots-quot ( class -- quot )
+ "struct-slots" word-prop
+ [ name>> reader-word 1quotation ] map
+ \ cleave [ ] 2sequence
+ \ output>array [ ] 2sequence ;
+
+: (define-object-slots-method) ( class -- )
+ [ \ object-slots create-method-in ]
+ [ object-slots-quot ] bi define ;
+
+! Struct as c-type
+
+: align-offset ( offset class -- offset' )
+ c-type-align align ;
+
+: struct-offsets ( slots -- size )
+ 0 [
+ [ class>> align-offset ] keep
+ [ (>>offset) ] [ class>> heap-size + ] 2bi
+ ] reduce ;
+
+: union-struct-offsets ( slots -- size )
+ [ 0 >>offset class>> heap-size ] [ max ] map-reduce ;
+
+: struct-align ( slots -- align )
+ [ class>> c-type-align ] [ max ] map-reduce ;
+
+M: struct-class 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
+ '[ _ memory>struct ] ;
+
+M: struct-class c-type-unboxer-quot
+ drop [ >c-ptr ] ;
+
+M: struct-class heap-size
+ "struct-size" word-prop ;
+
+M: struct-class direct-array-of
+ <direct-struct-array> ;
+
+! class definition
+
+: struct-prototype ( class -- prototype )
+ [ heap-size <byte-array> ]
+ [ memory>struct ]
+ [ "struct-slots" word-prop ] tri
+ [
+ [ initial>> ]
+ [ (writer-quot) ] bi
+ over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
+ ] each ;
+
+: (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 ]
+ [ (define-object-slots-method) ] tri ;
+
+: check-struct-slots ( slots -- )
+ [ class>> 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)
+ ] 2bi ; inline
+
+: define-struct-class ( class slots -- )
+ [ struct-offsets ] (define-struct-class) ;
+
+: define-union-struct-class ( class slots -- )
+ [ union-struct-offsets ] (define-struct-class) ;
+
+: parse-struct-definition ( -- class slots )
+ CREATE-CLASS [ parse-tuple-slots ] { } make ;
+
+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{
+ POSTPONE: T{ ;
+
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: alien destructors help.markup help.syntax kernel math ;
+IN: memory.piles
+
+HELP: <pile>
+{ $values
+ { "size" integer }
+ { "pile" pile }
+}
+{ $description "Allocates " { $snippet "size" } " bytes of raw memory for a new " { $link pile } ". The pile should be " { $link dispose } "d when it is no longer needed." } ;
+
+HELP: not-enough-pile-space
+{ $values
+ { "pile" pile }
+}
+{ $description "This error is thrown by " { $link pile-alloc } " when the " { $link pile } " does not have enough remaining space for the requested allocation." } ;
+
+HELP: pile
+{ $class-description "A " { $snippet "pile" } " is a block of raw memory that can be apportioned out in constant time. A pile is allocated using the " { $link <pile> } " word. Blocks of memory can be requested from the pile using " { $link pile-alloc } ", and all the pile's memory can be reclaimed with " { $link pile-empty } "." } ;
+
+HELP: pile-align
+{ $values
+ { "pile" pile } { "align" "a power of two" }
+ { "pile" pile }
+}
+{ $description "Adjusts a " { $link pile } "'s internal state so that the next call to " { $link pile-alloc } " will return a pointer aligned to " { $snippet "align" } " bytes relative to the pile's initial offset." } ;
+
+HELP: pile-alloc
+{ $values
+ { "pile" pile } { "size" integer }
+ { "alien" alien }
+}
+{ $description "Requests " { $snippet "size" } " bytes from a " { $link pile } ". If the pile does not have enough space to satisfy the request, a " { $link not-enough-pile-space } " error is thrown." } ;
+
+HELP: pile-empty
+{ $values
+ { "pile" pile }
+}
+{ $description "Reclaims all the memory allocated out of a " { $link pile } ". Allocations will resume from the beginning of the pile." } ;
+
+ARTICLE: "memory.piles" "Piles"
+"A " { $link pile } " is a block of raw memory. Portions of its memory can be allocated from the beginning of the pile in constant time, and the pile can be emptied and its pointer reset to the beginning."
+{ $subsection <pile> }
+{ $subsection pile-alloc }
+{ $subsection pile-align }
+{ $subsection pile-empty }
+"An example of the utility of piles is in video games. For example, the game Abuse was scripted with a Lisp dialect. In order to avoid stalls from traditional GC or heap-based allocators, the Abuse Lisp VM would allocate values from a preallocated pile over the course of a frame, and release the entire pile at the end of the frame." ;
+
+ABOUT: "memory.piles"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors alien destructors kernel math
+memory.piles tools.test ;
+IN: memory.piles.tests
+
+[ 25 ] [
+ [
+ 100 <pile> &dispose
+ [ 25 pile-alloc ] [ 50 pile-alloc ] bi
+ swap [ alien-address ] bi@ -
+ ] with-destructors
+] unit-test
+
+[ 32 ] [
+ [
+ 100 <pile> &dispose
+ [ 25 pile-alloc ] [ 8 pile-align 50 pile-alloc ] bi
+ swap [ alien-address ] bi@ -
+ ] with-destructors
+] unit-test
+
+[ 75 ] [
+ [
+ 100 <pile> &dispose
+ dup 25 pile-alloc drop
+ dup 50 pile-alloc drop
+ offset>>
+ ] with-destructors
+] unit-test
+
+[ 100 ] [
+ [
+ 100 <pile> &dispose
+ dup 25 pile-alloc drop
+ dup 75 pile-alloc drop
+ offset>>
+ ] with-destructors
+] unit-test
+
+[
+ [
+ 100 <pile> &dispose
+ dup 25 pile-alloc drop
+ dup 76 pile-alloc drop
+ ] with-destructors
+] [ not-enough-pile-space? ] must-fail-with
+
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors alien destructors kernel libc math ;
+IN: memory.piles
+
+TUPLE: pile
+ { underlying c-ptr }
+ { size integer }
+ { offset integer } ;
+
+ERROR: not-enough-pile-space pile ;
+
+M: pile dispose
+ [ [ free ] when* f ] change-underlying drop ;
+
+: <pile> ( size -- pile )
+ [ malloc ] keep 0 pile boa ;
+
+: pile-empty ( pile -- )
+ 0 >>offset drop ;
+
+: pile-alloc ( pile size -- alien )
+ [
+ [ [ ] [ size>> ] [ offset>> ] tri ] dip +
+ < [ not-enough-pile-space ] [ drop ] if
+ ] [
+ drop [ offset>> ] [ underlying>> ] bi <displaced-alien>
+ ] [
+ [ + ] curry change-offset drop
+ ] 2tri ;
+
+: pile-align ( pile align -- pile )
+ [ align ] curry change-offset ;
+
--- /dev/null
+Preallocated raw memory blocks
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: classes help.markup help.syntax kernel math ;
+IN: memory.pools
+
+HELP: <pool>
+{ $values
+ { "size" integer } { "class" class }
+ { "pool" pool }
+}
+{ $description "Creates a " { $link pool } " of " { $snippet "size" } " objects of " { $snippet "class" } "." } ;
+
+HELP: POOL:
+{ $syntax "POOL: class size" }
+{ $description "Creates a " { $link pool } " of " { $snippet "size" } " objects of " { $snippet "class" } ", and associates it with the class using " { $link set-class-pool } "." } ;
+
+HELP: class-pool
+{ $values
+ { "class" class }
+ { "pool" pool }
+}
+{ $description "Returns the " { $link pool } " associated with " { $snippet "class" } ", or " { $link f } " if no pool is associated." } ;
+
+HELP: free-to-pool
+{ $values
+ { "object" object }
+}
+{ $description "Frees an object from the " { $link pool } " it was allocated from. The object must have been allocated by " { $link new-from-pool } "." } ;
+
+HELP: new-from-pool
+{ $values
+ { "class" class }
+ { "object" object }
+}
+{ $description "Allocates an object from the " { $link pool } " associated with " { $snippet "class" } ". If the pool is exhausted, " { $link f } " is returned." } ;
+
+{ POSTPONE: POOL: class-pool set-class-pool new-from-pool free-to-pool } related-words
+
+HELP: pool
+{ $class-description "A " { $snippet "pool" } " contains a fixed-size set of preallocated tuple objects. Once the pool has been allocated, its objects can be allocated with " { $link pool-new } " and freed with " { $link pool-free } " in constant time. A pool can also be associated with its class with the " { $link POSTPONE: POOL: } " syntax or the " { $link set-class-pool } " word, after which the words " { $link new-from-pool } " and " { $link free-to-pool } " can be used with the class name to allocate and free objects." } ;
+
+HELP: pool-free
+{ $values
+ { "object" object } { "pool" pool }
+}
+{ $description "Frees an object back into " { $link pool } "." } ;
+
+HELP: pool-size
+{ $values
+ { "pool" pool }
+ { "size" integer }
+}
+{ $description "Returns the number of unallocated objects inside a " { $link pool } "." } ;
+
+HELP: pool-new
+{ $values
+ { "pool" pool }
+ { "object" object }
+}
+{ $description "Returns an unallocated object out of a " { $link pool } ". If the pool is exhausted, " { $link f } " is returned." } ;
+
+{ pool <pool> pool-new pool-free pool-size } related-words
+
+HELP: set-class-pool
+{ $values
+ { "class" class } { "pool" pool }
+}
+{ $description "Associates a " { $link pool } " with " { $snippet "class" } "." } ;
+
+ARTICLE: "memory.pools" "Pools"
+"The " { $vocab-link "memory.pools" } " vocabulary provides " { $link pool } " objects which manage preallocated collections of objects."
+{ $subsection pool }
+{ $subsection POSTPONE: POOL: }
+{ $subsection new-from-pool }
+{ $subsection free-to-pool } ;
+
+ABOUT: "memory.pools"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: kernel memory.pools tools.test ;
+IN: memory.pools.tests
+
+TUPLE: foo x ;
+
+[ 1 ] [
+ foo 2 foo <pool> set-class-pool
+
+ foo new-from-pool drop
+ foo class-pool pool-size
+] unit-test
+
+[ T{ foo } T{ foo } f ] [
+ foo 2 foo <pool> set-class-pool
+
+ foo new-from-pool
+ foo new-from-pool
+ foo new-from-pool
+] unit-test
+
+[ f ] [
+ foo 2 foo <pool> set-class-pool
+
+ foo new-from-pool
+ foo new-from-pool
+ eq?
+] unit-test
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays bit-arrays classes
+classes.tuple.private fry kernel locals parser
+sequences sequences.private vectors words ;
+IN: memory.pools
+
+TUPLE: pool
+ prototype
+ { objects vector } ;
+
+: <pool> ( size class -- pool )
+ [ nip new ]
+ [ [ iota ] dip '[ _ new ] V{ } replicate-as ] 2bi
+ pool boa ;
+
+: pool-size ( pool -- size )
+ objects>> length ;
+
+<PRIVATE
+
+:: copy-tuple ( from to -- to )
+ from tuple-size :> size
+ size [| n | n from array-nth n to set-array-nth ] each
+ to ; inline
+
+: (pool-new) ( pool -- object )
+ objects>> [ f ] [ pop ] if-empty ;
+
+: (pool-init) ( pool object -- object )
+ [ prototype>> ] dip copy-tuple ; inline
+
+PRIVATE>
+
+: pool-new ( pool -- object )
+ dup (pool-new) [ (pool-init) ] [ drop f ] if* ; inline
+
+: pool-free ( object pool -- )
+ objects>> push ;
+
+: class-pool ( class -- pool )
+ "pool" word-prop ;
+
+: set-class-pool ( class pool -- )
+ "pool" set-word-prop ;
+
+: new-from-pool ( class -- object )
+ class-pool pool-new ;
+
+: free-to-pool ( object -- )
+ dup class class-pool pool-free ;
+
+SYNTAX: POOL:
+ scan-word scan-word '[ _ swap <pool> ] [ swap set-class-pool ] bi ;
+
--- /dev/null
+Preallocated pools of tuple objects
--- /dev/null
+USING: help help.markup help.syntax kernel quotations ;
+IN: prettyprint.callables
+
+HELP: simplify-callable
+{ $values { "quot" callable } { "quot'" callable } }
+{ $description "Converts " { $snippet "quot" } " into an equivalent quotation by simplifying usages of " { $link dip } ", " { $link call } ", " { $link curry } ", and " { $link compose } " with literal parameters. This word is used when callable objects are prettyprinted." } ;
--- /dev/null
+! (c) 2009 Joe Groff bsd license
+USING: kernel math prettyprint prettyprint.callables
+tools.test ;
+IN: prettyprint.callables.tests
+
+[ [ dip ] ] [ [ dip ] simplify-callable ] unit-test
+[ [ [ + ] dip ] ] [ [ [ + ] dip ] simplify-callable ] unit-test
+[ [ + 5 ] ] [ [ 5 [ + ] dip ] simplify-callable ] unit-test
+[ [ + ] ] [ [ [ + ] call ] simplify-callable ] unit-test
+[ [ call ] ] [ [ call ] simplify-callable ] unit-test
+[ [ 5 + ] ] [ [ 5 [ + ] curry call ] simplify-callable ] unit-test
+[ [ 4 5 + ] ] [ [ 4 5 [ + ] 2curry call ] simplify-callable ] unit-test
+[ [ 4 5 6 + ] ] [ [ 4 5 6 [ + ] 3curry call ] simplify-callable ] unit-test
+[ [ + . ] ] [ [ [ + ] [ . ] compose call ] simplify-callable ] unit-test
+[ [ . + ] ] [ [ [ + ] [ . ] prepose call ] simplify-callable ] unit-test
--- /dev/null
+! (c) 2009 Joe Groff bsd license
+USING: combinators combinators.short-circuit generalizations
+kernel macros math math.ranges prettyprint.custom quotations
+sequences words ;
+IN: prettyprint.callables
+
+<PRIVATE
+
+CONSTANT: simple-combinators { dip call curry 2curry 3curry compose prepose }
+
+: literal? ( obj -- ? ) word? not ;
+
+MACRO: slice-match? ( quots -- quot: ( seq end -- ? ) )
+ dup length
+ [ 0 [a,b) [ [ - swap nth ] swap prefix prepend ] 2map ]
+ [ nip \ nip swap \ >= [ ] 3sequence ] 2bi
+ prefix \ 2&& [ ] 2sequence ;
+
+: end-len>from-to ( seq end len -- from to seq )
+ [ - ] [ drop 1 + ] 2bi rot ;
+
+: slice-change ( seq end len quot -- seq' )
+ [ end-len>from-to ] dip
+ [ [ subseq ] dip call ] curry
+ [ replace-slice ] 3bi ; inline
+
+: when-slice-match ( seq i criteria quot -- seq' )
+ [ [ 2dup ] dip slice-match? ] dip [ drop ] if ; inline
+
+: simplify-dip ( quot i -- quot' )
+ { [ literal? ] [ callable? ] }
+ [ 2 [ first2 swap suffix ] slice-change ] when-slice-match ;
+
+: simplify-call ( quot i -- quot' )
+ { [ callable? ] }
+ [ 1 [ first ] slice-change ] when-slice-match ;
+
+: simplify-curry ( quot i -- quot' )
+ { [ literal? ] [ callable? ] }
+ [ 2 [ first2 swap prefix 1quotation ] slice-change ] when-slice-match ;
+
+: simplify-2curry ( quot i -- quot' )
+ { [ literal? ] [ literal? ] [ callable? ] }
+ [ 3 [ [ 2 head ] [ third ] bi append 1quotation ] slice-change ] when-slice-match ;
+
+: simplify-3curry ( quot i -- quot' )
+ { [ literal? ] [ literal? ] [ literal? ] [ callable? ] }
+ [ 4 [ [ 3 head ] [ fourth ] bi append 1quotation ] slice-change ] when-slice-match ;
+
+: simplify-compose ( quot i -- quot' )
+ { [ callable? ] [ callable? ] }
+ [ 2 [ first2 append 1quotation ] slice-change ] when-slice-match ;
+
+: simplify-prepose ( quot i -- quot' )
+ { [ callable? ] [ callable? ] }
+ [ 2 [ first2 swap append 1quotation ] slice-change ] when-slice-match ;
+
+: (simplify-callable) ( quot -- quot' )
+ dup [ simple-combinators member? ] find {
+ { \ dip [ simplify-dip ] }
+ { \ call [ simplify-call ] }
+ { \ curry [ simplify-curry ] }
+ { \ 2curry [ simplify-2curry ] }
+ { \ 3curry [ simplify-3curry ] }
+ { \ compose [ simplify-compose ] }
+ { \ prepose [ simplify-prepose ] }
+ [ 2drop ]
+ } case ;
+
+PRIVATE>
+
+: simplify-callable ( quot -- quot' )
+ [ (simplify-callable) ] to-fixed-point ;
+
+M: callable >pprint-sequence simplify-callable ;
--- /dev/null
+Quotation simplification for prettyprinting automatically-constructed callable objects
projects / factor.git / commitdiff