! 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.parser
+arrays byte-arrays classes classes.parser classes.private
classes.struct.bit-accessors classes.tuple classes.tuple.parser
-combinators combinators.smart cpu.architecture fry
-functors.backend generalizations generic.parser kernel
+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 vocabs.loader
+stack-checker.dependencies summary vectors vocabs.loader
vocabs.parser words ;
FROM: delegate.private => group-words slot-group-words ;
QUALIFIED: math
M: struct equal?
over struct? [
- 2dup [ class ] bi@ = [
+ 2dup [ class-of ] same? [
2dup [ >c-ptr ] both?
[ [ >c-ptr ] [ binary-object ] bi* memory= ]
[ [ >c-ptr not ] both? ]
! 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
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>
[ <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
INSTANCE: struct-c-type value-type
-M: struct-c-type c-type ;
+M: struct-c-type lookup-c-type ;
M: struct-c-type base-type ;
[ \ 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 )
binary-object memory>byte-array ; inline
[ \ 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
1 [ 0 >>offset type>> heap-size max ] reduce ;
: struct-alignment ( slots -- align )
- [ struct-bit-slot-spec? not ] filter
+ [ 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
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 ;
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-token {
} 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>
<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 ]
[ parse-struct-slots` ] [ ] while
[ >array define-struct-class ] append! ;
-USING: vocabs vocabs.loader ;
-
{ "classes.struct" "prettyprint" } "classes.struct.prettyprint" require-when