]> gitweb.factorcode.org Git - factor.git/blobdiff - basis/classes/struct/struct.factor
use reject instead of [ ... not ] filter.
[factor.git] / basis / classes / struct / struct.factor
index 9ee463db98f8ef566e2e1a8e31a611f1da164ddd..5ea31bc7d33c119495fc27cdbe687c9974b821b6 100644 (file)
@@ -2,13 +2,13 @@
 ! 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
@@ -52,7 +52,7 @@ M: struct >c-ptr
 
 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? ]
@@ -71,6 +71,9 @@ M: struct hashcode*
     ! 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
@@ -136,11 +139,11 @@ M: struct-bit-slot-spec (writer-quot)
     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>
 
@@ -149,7 +152,7 @@ M: struct-class boa>object
     [ <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> ; inline
 
 ! Struct slot accessors
 
@@ -173,7 +176,7 @@ TUPLE: struct-c-type < abstract-c-type
 
 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 ;
 
@@ -195,6 +198,9 @@ 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
 
@@ -203,6 +209,9 @@ M: struct-c-type base-type ;
     [ \ 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
@@ -236,12 +245,14 @@ M: struct-bit-slot-spec compute-slot-offset
     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
@@ -268,7 +279,7 @@ M: struct binary-zero? binary-object uchar <c-direct-array> [ 0 = ] all? ; inlin
     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 ;
@@ -312,23 +323,28 @@ PRIVATE>
 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
@@ -350,12 +366,12 @@ PRIVATE>
 : <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 {
@@ -365,7 +381,7 @@ PRIVATE>
     } 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>
 
@@ -388,14 +404,14 @@ SYNTAX: S@
 
 <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 ]
@@ -409,6 +425,4 @@ FUNCTOR-SYNTAX: STRUCT:
     [ parse-struct-slots` ] [ ] while
     [ >array define-struct-class ] append! ;
 
-USING: vocabs vocabs.loader ;
-
 { "classes.struct" "prettyprint" } "classes.struct.prettyprint" require-when