-! (c)Joe Groff, Daniel Ehrenberg bsd license
+! Copyright (C) 2010, 2011 Joe Groff, Daniel Ehrenberg,
+! John Benediktsson, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license
USING: accessors alien alien.c-types alien.data alien.parser
-arrays byte-arrays classes classes.private classes.parser
-classes.tuple classes.tuple.parser classes.tuple.private
-combinators combinators.short-circuit combinators.smart
-cpu.architecture definitions functors.backend fry
-generalizations generic.parser kernel kernel.private lexer libc
-locals macros make math math.order parser quotations sequences
-slots slots.private specialized-arrays vectors words summary
-namespaces assocs vocabs.parser math.functions
-classes.struct.bit-accessors bit-arrays
-stack-checker.dependencies ;
+arrays byte-arrays classes classes.parser classes.private
+classes.struct.bit-accessors classes.tuple classes.tuple.parser
+combinators combinators.smart cpu.architecture definitions fry
+functors.backend generalizations generic generic.parser io kernel
+kernel.private lexer libc locals macros math math.order parser
+quotations sequences slots slots.private specialized-arrays
+stack-checker.dependencies summary vectors vocabs.loader
+vocabs.parser words ;
+FROM: delegate.private => group-words slot-group-words ;
QUALIFIED: math
IN: classes.struct
TUPLE: struct
{ (underlying) c-ptr read-only } ;
+! We hijack the core slots vocab's slot-spec type for struct
+! fields. Note that 'offset' is in bits, not bytes, to support
+! bitfields.
TUPLE: struct-slot-spec < slot-spec
- type ;
+ type packed? ;
! For a struct-bit-slot-spec, offset is in bits, not bytes
TUPLE: struct-bit-slot-spec < struct-slot-spec
: struct-slots ( struct-class -- slots )
"c-type" word-prop fields>> ;
+M: struct-class group-words
+ struct-slots slot-group-words ;
+
! 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&& ; inline
+ over struct? [
+ 2dup [ class-of ] same? [
+ 2dup [ >c-ptr ] both?
+ [ [ >c-ptr ] [ binary-object ] bi* memory= ]
+ [ [ >c-ptr not ] both? ]
+ if
+ ] [ 2drop f ] if
+ ] [ 2drop f ] if ; inline
M: struct hashcode*
- [ >c-ptr ] [ byte-length ] bi <direct-uchar-array> hashcode* ; inline
+ binary-object over
+ [ uchar <c-direct-array> hashcode* ] [ 3drop 0 ] if ; inline
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
! optimized down to efficient code if it is.
'[ _ boa ] call( ptr -- struct ) ; inline
+: read-struct ( class -- struct )
+ [ heap-size read ] [ memory>struct ] bi ;
+
<PRIVATE
: (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )
'[ dup struct-prototype _ _ ?if ] keep memory>struct ; inline
GENERIC: (reader-quot) ( slot -- quot )
M: struct-slot-spec (reader-quot)
- [ type>> c-type-getter-boxer ]
- [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+ [ offset>> ] [ type>> ] bi '[ >c-ptr _ _ alien-value ] ;
M: struct-bit-slot-spec (reader-quot)
[ [ offset>> ] [ bits>> ] bi bit-reader ]
GENERIC: (writer-quot) ( slot -- quot )
M: struct-slot-spec (writer-quot)
- [ type>> c-setter ]
- [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+ [ offset>> ] [ type>> ] bi '[ >c-ptr _ _ set-alien-value ] ;
M: struct-bit-slot-spec (writer-quot)
- [ offset>> ] [ bits>> ] bi bit-writer
- [ >c-ptr ] prepose ;
+ [ offset>> ] [ bits>> ] bi bit-writer [ >c-ptr ] prepose ;
: (boxer-quot) ( class -- quot )
'[ _ memory>struct ] ;
drop [ >c-ptr ] ;
MACRO: read-struct-slot ( slot -- )
- dup type>> depends-on-c-type
+ dup type>> add-depends-on-c-type
(reader-quot) ;
MACRO: write-struct-slot ( slot -- )
- dup type>> depends-on-c-type
+ dup type>> add-depends-on-c-type
(writer-quot) ;
PRIVATE>
M: struct-class boa>object
swap pad-struct-slots
- [ <struct> ] [ struct-slots ] bi
+ [ <struct> ] [ struct-slots ] bi
[ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
-M: struct-class initial-value* <struct> ; inline
+M: struct-class initial-value* <struct> t ; inline
! Struct slot accessors
GENERIC: struct-slot-values ( struct -- sequence )
M: struct-class reader-quot
- dup array? [ dup first define-array-vocab drop ] when
+ dup type>> array? [ dup type>> first define-array-vocab drop ] when
nip '[ _ read-struct-slot ] ;
M: struct-class writer-quot
INSTANCE: struct-c-type value-type
-M: struct-c-type c-type ;
-
-M: struct-c-type c-type-stack-align? drop f ;
-
-: if-value-struct ( ctype true false -- )
- [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
-
-M: struct-c-type unbox-parameter
- [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
-
-M: struct-c-type box-parameter
- [ %box-large-struct ] [ box-parameter ] if-value-struct ;
+M: struct-c-type lookup-c-type ;
-: if-small-struct ( c-type true false -- ? )
- [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
+M: struct-c-type base-type ;
-M: struct-c-type unbox-return
- [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
-
-M: struct-c-type box-return
- [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
-
-M: struct-c-type stack-size
- [ heap-size ] [ stack-size ] if-value-struct ;
-
-M: struct-c-type c-struct? drop t ;
+: large-struct? ( type -- ? )
+ {
+ { [ dup void? ] [ drop f ] }
+ { [ dup base-type struct-c-type? not ] [ drop f ] }
+ [ return-struct-in-registers? not ]
+ } cond ;
<PRIVATE
: struct-slot-values-quot ( class -- quot )
[ \ struct-slot-values ] [ struct-slot-values-quot ] bi
define-inline-method ;
+: forget-struct-slot-values-method ( class -- )
+ \ struct-slot-values ?lookup-method forget ;
+
: clone-underlying ( struct -- byte-array )
- [ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline
+ binary-object memory>byte-array ; inline
: (define-clone-method) ( class -- )
[ \ clone ]
[ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi
define-inline-method ;
+: forget-clone-method ( class -- )
+ \ clone ?lookup-method forget ;
+
:: c-type-for-class ( class slots size align -- c-type )
struct-c-type new
byte-array >>class
GENERIC: compute-slot-offset ( offset class -- offset' )
-: c-type-align-at ( class offset -- n )
- 0 = [ c-type-align-first ] [ c-type-align ] if ;
+: c-type-align-at ( slot-spec offset -- n )
+ over packed?>> [ 2drop 1 ] [
+ [ type>> ] dip
+ 0 = [ c-type-align-first ] [ c-type-align ] if
+ ] if ;
M: struct-slot-spec compute-slot-offset
- [ type>> over c-type-align-at 8 * align ] keep
- [ [ 8 /i ] dip (>>offset) ] [ type>> heap-size 8 * + ] 2bi ;
+ [ over c-type-align-at 8 * align ] keep
+ [ [ 8 /i ] dip offset<< ] [ type>> heap-size 8 * + ] 2bi ;
M: struct-bit-slot-spec compute-slot-offset
- [ (>>offset) ] [ bits>> + ] 2bi ;
+ [ offset<< ] [ bits>> + ] 2bi ;
: compute-struct-offsets ( slots -- size )
0 [ compute-slot-offset ] reduce 8 align 8 /i ;
1 [ 0 >>offset type>> heap-size max ] reduce ;
: struct-alignment ( slots -- align )
- [ struct-bit-slot-spec? not ] filter
- 1 [ [ type>> ] [ offset>> ] bi c-type-align-at max ] reduce ;
+ [ struct-bit-slot-spec? ] reject
+ 1 [ dup offset>> c-type-align-at max ] reduce ;
PRIVATE>
-M: struct byte-length class "struct-size" word-prop ; foldable
+: struct-size ( class -- n ) "struct-size" word-prop ; inline
+
+M: struct byte-length class-of struct-size ; inline foldable
+M: struct binary-zero? binary-object uchar <c-direct-array> [ 0 = ] all? ; inline
! class definition
<PRIVATE
-GENERIC: binary-zero? ( value -- ? )
-
-M: object binary-zero? drop f ;
-M: f binary-zero? drop t ;
-M: number binary-zero? 0 = ;
-M: struct binary-zero? >c-ptr [ 0 = ] all? ;
-
: struct-needs-prototype? ( class -- ? )
struct-slots [ initial>> binary-zero? ] all? not ;
bi ;
: check-struct-slots ( slots -- )
- [ type>> c-type drop ] each ;
+ [ type>> lookup-c-type drop ] each ;
: redefine-struct-tuple-class ( class -- )
[ struct f define-tuple-class ] [ make-final ] bi ;
-:: (define-struct-class) ( class slots offsets-quot -- )
- slots empty? [ struct-must-have-slots ] when
+:: (define-struct-class) ( class slot-specs offsets-quot alignment-quot -- )
+ slot-specs check-struct-slots
+ slot-specs empty? [ struct-must-have-slots ] when
class redefine-struct-tuple-class
- slots make-slots dup check-struct-slots :> slot-specs
slot-specs offsets-quot call :> unaligned-size
- slot-specs struct-alignment :> alignment
+ slot-specs alignment-quot call :> alignment
unaligned-size alignment align :> size
- class slot-specs size alignment c-type-for-class :> c-type
+ class slot-specs size alignment c-type-for-class :> c-type
c-type class typedef
class slot-specs define-accessors
class size "struct-size" set-word-prop
class dup make-struct-prototype "prototype" set-word-prop
class (struct-methods) ; inline
+
+: make-packed-slots ( slots -- slot-specs )
+ make-slots [ t >>packed? ] map! ;
+
PRIVATE>
: define-struct-class ( class slots -- )
- [ compute-struct-offsets ] (define-struct-class) ;
+ make-slots
+ [ compute-struct-offsets ] [ struct-alignment ]
+ (define-struct-class) ;
+
+: define-packed-struct-class ( class slots -- )
+ make-packed-slots
+ [ compute-struct-offsets ] [ drop 1 ]
+ (define-struct-class) ;
: define-union-struct-class ( class slots -- )
- [ compute-union-offsets ] (define-struct-class) ;
+ make-slots
+ [ compute-union-offsets ] [ struct-alignment ]
+ (define-struct-class) ;
ERROR: invalid-struct-slot token ;
: struct-slot-class ( c-type -- class' )
- c-type c-type-boxed-class
+ lookup-c-type c-type-boxed-class
dup \ byte-array = [ drop \ c-ptr ] when ;
+M: struct-class reset-class
+ {
+ [ dup "c-type" word-prop fields>> forget-slot-accessors ]
+ [
+ [ forget-struct-slot-values-method ]
+ [ forget-clone-method ] bi
+ ]
+ [ { "c-type" "layout" "struct-size" } reset-props ]
+ [ call-next-method ]
+ } cleave ;
+
SYMBOL: bits:
<PRIVATE
-ERROR: bad-type-for-bits type ;
-
:: set-bits ( slot-spec n -- slot-spec )
struct-bit-slot-spec new
n >>bits
- slot-spec type>> {
- { int [ t ] }
- { uint [ f ] }
- [ bad-type-for-bits ]
- } case >>signed?
+ slot-spec type>> c-type-signed >>signed?
slot-spec name>> >>name
slot-spec class>> >>class
slot-spec type>> >>type
: <struct-slot-spec> ( name c-type attributes -- slot-spec )
[ struct-slot-spec new ] 3dip
[ >>name ]
- [ [ >>type ] [ struct-slot-class >>class ] bi ]
+ [ [ >>type ] [ struct-slot-class init-slot-class ] bi ]
[ [ dup empty? ] [ peel-off-struct-attributes ] until drop ] tri* ;
<PRIVATE
: parse-struct-slot ( -- slot )
- scan scan-c-type \ } parse-until <struct-slot-spec> ;
-
+ scan-token scan-c-type \ } parse-until <struct-slot-spec> ;
+
: parse-struct-slots ( slots -- slots' more? )
- scan {
+ scan-token {
{ ";" [ f ] }
{ "{" [ parse-struct-slot suffix! t ] }
- { f [ unexpected-eof ] }
[ invalid-struct-slot ]
} case ;
: parse-struct-definition ( -- class slots )
- CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
+ scan-new-class 8 <vector> [ parse-struct-slots ] [ ] while >array
+ dup [ name>> ] map check-duplicate-slots ;
PRIVATE>
SYNTAX: STRUCT:
parse-struct-definition define-struct-class ;
+
+SYNTAX: PACKED-STRUCT:
+ parse-struct-definition define-packed-struct-class ;
+
SYNTAX: UNION-STRUCT:
parse-struct-definition define-union-struct-class ;
<PRIVATE
: scan-c-type` ( -- c-type/param )
- scan dup "{" = [ drop \ } parse-until >array ] [ search ] if ;
+ scan-token dup "{" = [ drop \ } parse-until >array ] [ search ] if ;
: parse-struct-slot` ( accum -- accum )
scan-string-param scan-c-type` \ } parse-until
[ <struct-slot-spec> suffix! ] 3curry append! ;
: parse-struct-slots` ( accum -- accum more? )
- scan {
+ scan-token {
{ ";" [ f ] }
{ "{" [ parse-struct-slot` t ] }
[ invalid-struct-slot ]
} case ;
+
PRIVATE>
FUNCTOR-SYNTAX: STRUCT:
[ parse-struct-slots` ] [ ] while
[ >array define-struct-class ] append! ;
-USING: vocabs vocabs.loader ;
-
-"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
+{ "classes.struct" "prettyprint" } "classes.struct.prettyprint" require-when
projects / factor.git / blobdiff