alien.c-types: cleanup

diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index ff3c9b8dde0130a96e52459999b6c50a0082bc69..6ded9f4e0d545d140bb6fee6bfbdf6455fe98174 100644 (file)
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -164,17 +164,12 @@ M: c-type stack-size size>> cell align ;
 MIXIN: value-type
 
 : c-getter ( name -- quot )
-    c-type-getter [
-        [ "Cannot read struct fields with this type" throw ]
-    ] unless* ;
-
-: c-type-getter-boxer ( name -- quot )
-    [ c-getter ] [ c-type-boxer-quot ] bi append ;
+    [ c-type-getter ] [ c-type-boxer-quot ] bi append ;
 
 : c-setter ( name -- quot )
-    c-type-setter [
-        [ "Cannot write struct fields with this type" throw ]
-    ] unless* ;
+    [ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
+    [ c-type-setter ]
+    bi append ;
 
 : array-accessor ( c-type quot -- def )
     [
@@ -295,7 +290,7 @@ M: pointer c-type
         c-ptr >>class
         c-ptr >>boxed-class
         [ alien-cell ] >>getter
-        [ [ >c-ptr ] 2dip set-alien-cell ] >>setter
+        [ set-alien-cell ] >>setter
         bootstrap-cell >>size
         bootstrap-cell >>align
         bootstrap-cell >>align-first
@@ -304,30 +299,6 @@ M: pointer c-type
         "alien_offset" >>unboxer
     \ void* define-primitive-type
 
-    <c-type>
-        integer >>class
-        integer >>boxed-class
-        [ alien-signed-4 ] >>getter
-        [ set-alien-signed-4 ] >>setter
-        4 >>size
-        4 >>align
-        4 >>align-first
-        "from_signed_4" >>boxer
-        "to_fixnum" >>unboxer
-    \ int define-primitive-type
-
-    <c-type>
-        integer >>class
-        integer >>boxed-class
-        [ alien-unsigned-4 ] >>getter
-        [ set-alien-unsigned-4 ] >>setter
-        4 >>size
-        4 >>align
-        4 >>align-first
-        "from_unsigned_4" >>boxer
-        "to_cell" >>unboxer
-    \ uint define-primitive-type
-
     <c-type>
         fixnum >>class
         fixnum >>boxed-class
@@ -338,6 +309,7 @@ M: pointer c-type
         2 >>align-first
         "from_signed_2" >>boxer
         "to_fixnum" >>unboxer
+        [ >fixnum ] >>unboxer-quot
     \ short define-primitive-type
 
     <c-type>
@@ -350,6 +322,7 @@ M: pointer c-type
         2 >>align-first
         "from_unsigned_2" >>boxer
         "to_cell" >>unboxer
+        [ >fixnum ] >>unboxer-quot
     \ ushort define-primitive-type
 
     <c-type>
@@ -362,6 +335,7 @@ M: pointer c-type
         1 >>align-first
         "from_signed_1" >>boxer
         "to_fixnum" >>unboxer
+        [ >fixnum ] >>unboxer-quot
     \ char define-primitive-type
 
     <c-type>
@@ -374,34 +348,14 @@ M: pointer c-type
         1 >>align-first
         "from_unsigned_1" >>boxer
         "to_cell" >>unboxer
+        [ >fixnum ] >>unboxer-quot
     \ uchar define-primitive-type
 
-    cpu ppc? [
-        <c-type>
-            [ alien-unsigned-4 c-bool> ] >>getter
-            [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
-            4 >>size
-            4 >>align
-            4 >>align-first
-            "from_boolean" >>boxer
-            "to_boolean" >>unboxer
-    ] [
-        <c-type>
-            [ alien-unsigned-1 c-bool> ] >>getter
-            [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
-            1 >>size
-            1 >>align
-            1 >>align-first
-            "from_boolean" >>boxer
-            "to_boolean" >>unboxer
-    ] if
-    \ bool define-primitive-type
-
     <c-type>
         math:float >>class
         math:float >>boxed-class
         [ alien-float ] >>getter
-        [ [ >float ] 2dip set-alien-float ] >>setter
+        [ set-alien-float ] >>setter
         4 >>size
         4 >>align
         4 >>align-first
@@ -415,7 +369,7 @@ M: pointer c-type
         math:float >>class
         math:float >>boxed-class
         [ alien-double ] >>getter
-        [ [ >float ] 2dip set-alien-double ] >>setter
+        [ set-alien-double ] >>setter
         8 >>size
         8-byte-alignment
         "from_double" >>boxer
@@ -425,14 +379,40 @@ M: pointer c-type
     \ double define-primitive-type
 
     cell 8 = [
+        <c-type>
+            fixnum >>class
+            fixnum >>boxed-class
+            [ alien-signed-4 ] >>getter
+            [ set-alien-signed-4 ] >>setter
+            4 >>size
+            4 >>align
+            4 >>align-first
+            "from_signed_4" >>boxer
+            "to_fixnum" >>unboxer
+            [ >fixnum ] >>unboxer-quot
+        \ int define-primitive-type
+    
+        <c-type>
+            fixnum >>class
+            fixnum >>boxed-class
+            [ alien-unsigned-4 ] >>getter
+            [ set-alien-unsigned-4 ] >>setter
+            4 >>size
+            4 >>align
+            4 >>align-first
+            "from_unsigned_4" >>boxer
+            "to_cell" >>unboxer
+            [ >fixnum ] >>unboxer-quot
+        \ uint define-primitive-type
+
         <c-type>
             integer >>class
             integer >>boxed-class
             [ alien-signed-cell ] >>getter
             [ set-alien-signed-cell ] >>setter
-            bootstrap-cell >>size
-            bootstrap-cell >>align
-            bootstrap-cell >>align-first
+            8 >>size
+            8 >>align
+            8 >>align-first
             "from_signed_cell" >>boxer
             "to_fixnum" >>unboxer
         \ longlong define-primitive-type
@@ -442,9 +422,9 @@ M: pointer c-type
             integer >>boxed-class
             [ alien-unsigned-cell ] >>getter
             [ set-alien-unsigned-cell ] >>setter
-            bootstrap-cell >>size
-            bootstrap-cell >>align
-            bootstrap-cell >>align-first
+            8 >>size
+            8 >>align
+            8 >>align-first
             "from_unsigned_cell" >>boxer
             "to_cell" >>unboxer
         \ ulonglong define-primitive-type
@@ -463,6 +443,30 @@ M: pointer c-type
         \ ulonglong c-type \ uintptr_t typedef
         \ ulonglong c-type \ size_t typedef
     ] [
+        <c-type>
+            integer >>class
+            integer >>boxed-class
+            [ alien-signed-cell ] >>getter
+            [ set-alien-signed-cell ] >>setter
+            4 >>size
+            4 >>align
+            4 >>align-first
+            "from_signed_cell" >>boxer
+            "to_fixnum" >>unboxer
+        \ int define-primitive-type
+    
+        <c-type>
+            integer >>class
+            integer >>boxed-class
+            [ alien-unsigned-cell ] >>getter
+            [ set-alien-unsigned-cell ] >>setter
+            4 >>size
+            4 >>align
+            4 >>align-first
+            "from_unsigned_cell" >>boxer
+            "to_cell" >>unboxer
+        \ uint define-primitive-type
+
         <long-long-type>
             integer >>class
             integer >>boxed-class
@@ -495,6 +499,12 @@ M: pointer c-type
         \ uint c-type \ size_t typedef
     ] if
 
+    cpu ppc? \ uint \ uchar ? c-type clone
+        [ >c-bool ] >>unboxer-quot
+        [ c-bool> ] >>boxer-quot
+        object >>boxed-class
+    \ bool define-primitive-type
+
 ] with-compilation-unit
 
 M: char-16-rep rep-component-type drop char ;

diff --git a/basis/alien/data/data.factor b/basis/alien/data/data.factor
index af1ed246632805e84c0db6f4fc903960d18a1182..9922463b3333d4bf5a887472002bd2498c44175d 100644 (file)
--- a/basis/alien/data/data.factor
+++ b/basis/alien/data/data.factor
@@ -68,8 +68,7 @@ M: value-type c-type-getter
     drop [ swap <displaced-alien> ] ;
 
 M: value-type c-type-setter ( type -- quot )
-    [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
-    '[ @ swap @ _ memcpy ] ;
+    [ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ;
 
 M: array c-type-boxer-quot
     unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;

diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor
index 166c29bef509ec6f0ecb7a7d1265c37a96735f56..dea96279708693113f9e6bdbe2d6311c9d0c61ac 100755 (executable)
--- a/basis/alien/parser/parser.factor
+++ b/basis/alien/parser/parser.factor
@@ -169,7 +169,7 @@ PREDICATE: alien-callback-type-word < typedef-word
 
 : global-quot ( type word -- quot )
     name>> current-library get '[ _ _ address-of 0 ]
-    swap c-type-getter-boxer append ;
+    swap c-getter append ;
 
 : define-global ( type word -- )
     [ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;

diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor
index 13088e146925f248b1378edb79fe2cb2e9c7431a..e841881d28190257f38862e3780646be3470958b 100644 (file)
--- a/basis/classes/struct/struct-tests.factor
+++ b/basis/classes/struct/struct-tests.factor
@@ -211,7 +211,7 @@ UNION-STRUCT: struct-test-float-and-bits
         { name "y" }
         { offset 4 }
         { initial 123 }
-        { class integer }
+        { class $[ cell 4 = integer fixnum ? ] }
         { type int }
     }
     T{ struct-slot-spec
@@ -235,7 +235,7 @@ UNION-STRUCT: struct-test-float-and-bits
         { name "bits" }
         { offset 0 }
         { type uint }
-        { class integer }
+        { class $[ cell 4 = integer fixnum ? ] }
         { initial 0 }
     }
 } ] [ struct-test-float-and-bits c-type fields>> ] unit-test

diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor
index 605ee573f5a4eb236538f98295d1156623367006..60ef7930639283b799624a240d81cab900c81e1c 100644 (file)
--- a/basis/classes/struct/struct.factor
+++ b/basis/classes/struct/struct.factor
@@ -101,7 +101,7 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
 GENERIC: (reader-quot) ( slot -- quot )
 
 M: struct-slot-spec (reader-quot)
-    [ type>> c-type-getter-boxer ]
+    [ type>> c-getter ]
     [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
 
 M: struct-bit-slot-spec (reader-quot)

diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor
index 38f97303ba45c31c31bdf669536ef08f130d5e01..35448a501c5694365b0aec9f5ffd35eb3108fee8 100644 (file)
--- a/basis/specialized-arrays/specialized-arrays.factor
+++ b/basis/specialized-arrays/specialized-arrays.factor
@@ -45,7 +45,7 @@ byte-array>A DEFINES byte-array>${A}
 A{           DEFINES ${A}{
 A@           DEFINES ${A}@
 
-NTH          [ T dup c-type-getter-boxer array-accessor ]
+NTH          [ T dup c-getter array-accessor ]
 SET-NTH      [ T dup c-setter array-accessor ]
 
 WHERE