move some allocation words that don't really have much to do with c types out of...

[factor.git] / basis / alien / c-types / c-types.factor

diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index 6d63987265f3fcddc91fd4a22571b6c4e8e043b5..fa27e29c0419a401a5bc36f3374ac2a83d799782 100755 (executable)
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: byte-arrays arrays assocs kernel kernel.private libc math
+USING: byte-arrays arrays assocs kernel kernel.private math
 namespaces make parser sequences strings words splitting math.parser
 cpu.architecture alien alien.accessors alien.strings quotations
 layouts system compiler.units io io.files io.encodings.binary
@@ -22,8 +22,6 @@ SYMBOLS:
 DEFER: <int>
 DEFER: *char
 
-: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
-
 TUPLE: abstract-c-type
 { class class initial: object }
 { boxed-class class initial: object }
@@ -104,43 +102,6 @@ M: c-type-name c-struct?
 ! These words being foldable means that words need to be
 ! recompiled if a C type is redefined. Even so, folding the
 ! size facilitates some optimizations.
-GENERIC: heap-size ( type -- size ) foldable
-
-M: c-type-name heap-size c-type heap-size ;
-
-M: abstract-c-type heap-size size>> ;
-
-GENERIC: require-c-array ( c-type -- )
-
-M: array require-c-array first require-c-array ;
-
-GENERIC: c-array-constructor ( c-type -- word )
-
-GENERIC: c-(array)-constructor ( c-type -- word )
-
-GENERIC: c-direct-array-constructor ( c-type -- word )
-
-GENERIC: <c-array> ( len c-type -- array )
-
-M: c-type-name <c-array>
-    c-array-constructor execute( len -- array ) ; inline
-
-GENERIC: (c-array) ( len c-type -- array )
-
-M: c-type-name (c-array)
-    c-(array)-constructor execute( len -- array ) ; inline
-
-GENERIC: <c-direct-array> ( alien len c-type -- array )
-
-M: c-type-name <c-direct-array>
-    c-direct-array-constructor execute( alien len -- array ) ; inline
-
-: malloc-array ( n type -- alien )
-    [ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
-
-: (malloc-array) ( n type -- alien )
-    [ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
-
 GENERIC: c-type-class ( name -- class )
 
 M: abstract-c-type c-type-class class>> ;
@@ -239,22 +200,19 @@ M: c-type unbox-return f swap c-type-unbox ;
 
 M: c-type-name unbox-return c-type unbox-return ;
 
-GENERIC: stack-size ( type -- size ) foldable
+: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
 
-M: c-type-name stack-size c-type stack-size ;
+GENERIC: heap-size ( type -- size ) foldable
 
-M: c-type stack-size size>> cell align ;
+M: c-type-name heap-size c-type heap-size ;
 
-MIXIN: value-type
+M: abstract-c-type heap-size size>> ;
 
-M: value-type c-type-rep drop int-rep ;
+GENERIC: stack-size ( type -- size ) foldable
 
-M: value-type c-type-getter
-    drop [ swap <displaced-alien> ] ;
+M: c-type-name stack-size c-type stack-size ;
 
-M: value-type c-type-setter ( type -- quot )
-    [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
-    '[ @ swap @ _ memcpy ] ;
+M: c-type stack-size size>> cell align ;
 
 GENERIC: byte-length ( seq -- n ) flushable
 
@@ -262,6 +220,8 @@ M: byte-array byte-length length ; inline
 
 M: f byte-length drop 0 ; inline
 
+MIXIN: value-type
+
 : c-getter ( name -- quot )
     c-type-getter [
         [ "Cannot read struct fields with this type" throw ]
@@ -275,36 +235,6 @@ M: f byte-length drop 0 ; inline
         [ "Cannot write struct fields with this type" throw ]
     ] unless* ;
 
-: <c-object> ( type -- array )
-    heap-size <byte-array> ; inline
-
-: (c-object) ( type -- array )
-    heap-size (byte-array) ; inline
-
-: malloc-object ( type -- alien )
-    1 swap heap-size calloc ; inline
-
-: (malloc-object) ( type -- alien )
-    heap-size malloc ; inline
-
-: malloc-byte-array ( byte-array -- alien )
-    dup byte-length [ nip malloc dup ] 2keep memcpy ;
-
-: memory>byte-array ( alien len -- byte-array )
-    [ nip (byte-array) dup ] 2keep memcpy ;
-
-: malloc-string ( string encoding -- alien )
-    string>alien malloc-byte-array ;
-
-M: memory-stream stream-read
-    [
-        [ index>> ] [ alien>> ] bi <displaced-alien>
-        swap memory>byte-array
-    ] [ [ + ] change-index drop ] 2bi ;
-
-: byte-array>memory ( byte-array base -- )
-    swap dup byte-length memcpy ; inline
-
 : array-accessor ( type quot -- def )
     [
         \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
@@ -352,22 +282,15 @@ M: long-long-type box-return ( type -- )
 
 : define-out ( name -- )
     [ "alien.c-types" constructor-word ]
-    [ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ] bi
+    [ dup c-setter '[ _ heap-size <byte-array> [ 0 @ ] keep ] ] bi
     (( value -- c-ptr )) define-inline ;
 
-: >c-bool ( ? -- int ) 1 0 ? ; inline
-
-: c-bool> ( int -- ? ) 0 = not ; inline
-
 : define-primitive-type ( type name -- )
     [ typedef ]
     [ name>> define-deref ]
     [ name>> define-out ]
     tri ;
 
-: malloc-file-contents ( path -- alien len )
-    binary file-contents [ malloc-byte-array ] [ length ] bi ;
-
 : if-void ( type true false -- )
     pick void? [ drop nip call ] [ nip call ] if ; inline
 
@@ -510,8 +433,8 @@ SYMBOLS:
     \ uchar define-primitive-type
 
     <c-type>
-        [ alien-unsigned-1 c-bool> ] >>getter
-        [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
+        [ alien-unsigned-1 0 = not ] >>getter
+        [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
         1 >>size
         1 >>align
         "box_boolean" >>boxer