basis/alien/c-types/c-types.factor

   1 ! Copyright (C) 2004, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: byte-arrays arrays assocs delegate kernel kernel.private math
   4 math.order math.parser namespaces make parser sequences strings
   5 words splitting cpu.architecture alien alien.accessors
   6 alien.strings quotations layouts system compiler.units io
   7 io.files io.encodings.binary io.streams.memory accessors
   8 combinators effects continuations fry classes vocabs
   9 vocabs.loader words.symbol macros ;
  10 QUALIFIED: math
  11 IN: alien.c-types
  12
  13 SYMBOLS:
  14     char uchar
  15     short ushort
  16     int uint
  17     long ulong
  18     longlong ulonglong
  19     float double
  20     void* bool ;
  21
  22 SINGLETON: void
  23
  24 DEFER: <int>
  25 DEFER: *char
  26
  27 TUPLE: abstract-c-type
  28 { class class initial: object }
  29 { boxed-class class initial: object }
  30 { boxer-quot callable }
  31 { unboxer-quot callable }
  32 { getter callable }
  33 { setter callable }
  34 { size integer }
  35 { align integer }
  36 { align-first integer } ;
  37
  38 TUPLE: c-type < abstract-c-type
  39 boxer
  40 unboxer
  41 { rep initial: int-rep } ;
  42
  43 : <c-type> ( -- c-type )
  44     \ c-type new ; inline
  45
  46 ERROR: no-c-type name ;
  47
  48 ! C type protocol
  49 GENERIC: c-type ( name -- c-type ) foldable
  50
  51 PREDICATE: c-type-word < word
  52     "c-type" word-prop ;
  53
  54 TUPLE: pointer { to initial: void read-only } ;
  55 C: <pointer> pointer
  56
  57 UNION: c-type-name
  58     c-type-word pointer ;
  59
  60 : resolve-typedef ( name -- c-type )
  61     dup void? [ no-c-type ] when
  62     dup c-type-name? [ c-type ] when ;
  63
  64 M: word c-type
  65     dup "c-type" word-prop resolve-typedef
  66     [ ] [ no-c-type ] ?if ;
  67
  68 GENERIC: c-type-class ( name -- class )
  69
  70 M: abstract-c-type c-type-class class>> ;
  71
  72 GENERIC: c-type-boxed-class ( name -- class )
  73
  74 M: abstract-c-type c-type-boxed-class boxed-class>> ;
  75
  76 GENERIC: c-type-boxer-quot ( name -- quot )
  77
  78 M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
  79
  80 GENERIC: c-type-unboxer-quot ( name -- quot )
  81
  82 M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
  83
  84 GENERIC: c-type-rep ( name -- rep )
  85
  86 M: c-type c-type-rep rep>> ;
  87
  88 GENERIC: c-type-getter ( name -- quot )
  89
  90 M: c-type c-type-getter getter>> ;
  91
  92 GENERIC: c-type-copier ( name -- quot )
  93
  94 M: c-type c-type-copier drop [ ] ;
  95
  96 GENERIC: c-type-setter ( name -- quot )
  97
  98 M: c-type c-type-setter setter>> ;
  99
 100 GENERIC: c-type-align ( name -- n ) foldable
 101
 102 M: abstract-c-type c-type-align align>> ;
 103
 104 GENERIC: c-type-align-first ( name -- n )
 105
 106 M: abstract-c-type c-type-align-first align-first>> ;
 107
 108 GENERIC: base-type ( c-type -- c-type )
 109
 110 M: c-type-name base-type c-type ;
 111
 112 M: c-type base-type ;
 113
 114 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
 115
 116 GENERIC: heap-size ( name -- size )
 117
 118 M: abstract-c-type heap-size size>> ;
 119
 120 MIXIN: value-type
 121
 122 MACRO: alien-value ( c-type -- quot: ( c-ptr offset -- value ) )
 123     [ c-type-getter ] [ c-type-boxer-quot ] bi append ;
 124
 125 MACRO: alien-copy-value ( c-type -- quot: ( c-ptr offset -- value ) )
 126     [ c-type-getter ] [ c-type-copier ] [ c-type-boxer-quot ] tri 3append ;
 127
 128 MACRO: set-alien-value ( c-type -- quot: ( value c-ptr offset -- ) )
 129     [ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
 130     [ c-type-setter ]
 131     bi append ;
 132
 133 : array-accessor ( n c-ptr c-type -- c-ptr offset c-type )
 134     [ swapd heap-size * >fixnum ] keep ; inline
 135
 136 : alien-element ( n c-ptr c-type -- value )
 137     array-accessor alien-value ; inline
 138
 139 : set-alien-element ( value n c-ptr c-type -- )
 140     array-accessor set-alien-value ; inline
 141
 142 PROTOCOL: c-type-protocol
 143     c-type-class
 144     c-type-boxed-class
 145     c-type-boxer-quot
 146     c-type-unboxer-quot
 147     c-type-rep
 148     c-type-getter
 149     c-type-copier
 150     c-type-setter
 151     c-type-align
 152     c-type-align-first
 153     base-type
 154     heap-size ;
 155
 156 CONSULT: c-type-protocol c-type-name
 157     c-type ;
 158
 159 PREDICATE: typedef-word < c-type-word
 160     "c-type" word-prop [ c-type-name? ] [ array? ] bi or ;
 161
 162 : typedef ( old new -- )
 163     {
 164         [ nip define-symbol ]
 165         [ swap "c-type" set-word-prop ]
 166     } 2cleave ;
 167
 168 TUPLE: long-long-type < c-type ;
 169
 170 : <long-long-type> ( -- c-type )
 171     long-long-type new ;
 172
 173 : define-deref ( c-type -- )
 174     [ name>> CHAR: * prefix "alien.c-types" create ]
 175     [ '[ 0 _ alien-value ] ]
 176     bi (( c-ptr -- value )) define-inline ;
 177
 178 : define-out ( c-type -- )
 179     [ name>> "alien.c-types" constructor-word ]
 180     [ dup '[ _ heap-size (byte-array) [ 0 _ set-alien-value ] keep ] ] bi
 181     (( value -- c-ptr )) define-inline ;
 182
 183 : define-primitive-type ( c-type name -- )
 184     [ typedef ] [ define-deref ] [ define-out ] tri ;
 185
 186 : if-void ( c-type true false -- )
 187     pick void? [ drop nip call ] [ nip call ] if ; inline
 188
 189 SYMBOLS:
 190     ptrdiff_t intptr_t uintptr_t size_t
 191     c-string ;
 192
 193 CONSTANT: primitive-types
 194     {
 195         char uchar
 196         short ushort
 197         int uint
 198         long ulong
 199         longlong ulonglong
 200         float double
 201         void* bool
 202         c-string
 203     }
 204
 205 : >c-bool ( ? -- int ) 1 0 ? ; inline
 206
 207 : c-bool> ( int -- ? ) 0 = not ; inline
 208
 209 <PRIVATE
 210
 211 : 8-byte-alignment ( c-type -- c-type )
 212     {
 213         { [ cpu ppc? os macosx? and ] [ 4 >>align 8 >>align-first ] }
 214         { [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] }
 215         [ 8 >>align 8 >>align-first ]
 216     } cond ;
 217
 218 : resolve-pointer-typedef ( type -- base-type )
 219     dup "c-type" word-prop dup word?
 220     [ nip resolve-pointer-typedef ] [
 221         pointer? [ drop void* ] when
 222     ] if ;
 223
 224 : primitive-pointer-type? ( type -- ? )
 225     dup c-type-word? [
 226         resolve-pointer-typedef [ void? ] [ primitive-types member? ] bi or
 227     ] [ drop t ] if ;
 228
 229 : (pointer-c-type) ( void* type -- void*' )
 230     [ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ;
 231
 232 PRIVATE>
 233
 234 M: pointer c-type
 235     [ \ void* c-type ] dip
 236     to>> dup primitive-pointer-type? [ drop ] [ (pointer-c-type) ] if ;
 237
 238 [
 239     <c-type>
 240         c-ptr >>class
 241         c-ptr >>boxed-class
 242         [ alien-cell ] >>getter
 243         [ set-alien-cell ] >>setter
 244         bootstrap-cell >>size
 245         bootstrap-cell >>align
 246         bootstrap-cell >>align-first
 247         [ >c-ptr ] >>unboxer-quot
 248         "allot_alien" >>boxer
 249         "alien_offset" >>unboxer
 250     \ void* define-primitive-type
 251
 252     <c-type>
 253         fixnum >>class
 254         fixnum >>boxed-class
 255         [ alien-signed-2 ] >>getter
 256         [ set-alien-signed-2 ] >>setter
 257         2 >>size
 258         2 >>align
 259         2 >>align-first
 260         "from_signed_2" >>boxer
 261         "to_signed_2" >>unboxer
 262         [ >fixnum ] >>unboxer-quot
 263     \ short define-primitive-type
 264
 265     <c-type>
 266         fixnum >>class
 267         fixnum >>boxed-class
 268         [ alien-unsigned-2 ] >>getter
 269         [ set-alien-unsigned-2 ] >>setter
 270         2 >>size
 271         2 >>align
 272         2 >>align-first
 273         "from_unsigned_2" >>boxer
 274         "to_unsigned_2" >>unboxer
 275         [ >fixnum ] >>unboxer-quot
 276     \ ushort define-primitive-type
 277
 278     <c-type>
 279         fixnum >>class
 280         fixnum >>boxed-class
 281         [ alien-signed-1 ] >>getter
 282         [ set-alien-signed-1 ] >>setter
 283         1 >>size
 284         1 >>align
 285         1 >>align-first
 286         "from_signed_1" >>boxer
 287         "to_signed_1" >>unboxer
 288         [ >fixnum ] >>unboxer-quot
 289     \ char define-primitive-type
 290
 291     <c-type>
 292         fixnum >>class
 293         fixnum >>boxed-class
 294         [ alien-unsigned-1 ] >>getter
 295         [ set-alien-unsigned-1 ] >>setter
 296         1 >>size
 297         1 >>align
 298         1 >>align-first
 299         "from_unsigned_1" >>boxer
 300         "to_unsigned_1" >>unboxer
 301         [ >fixnum ] >>unboxer-quot
 302     \ uchar define-primitive-type
 303
 304     <c-type>
 305         math:float >>class
 306         math:float >>boxed-class
 307         [ alien-float ] >>getter
 308         [ set-alien-float ] >>setter
 309         4 >>size
 310         4 >>align
 311         4 >>align-first
 312         "from_float" >>boxer
 313         "to_float" >>unboxer
 314         float-rep >>rep
 315         [ >float ] >>unboxer-quot
 316     \ float define-primitive-type
 317
 318     <c-type>
 319         math:float >>class
 320         math:float >>boxed-class
 321         [ alien-double ] >>getter
 322         [ set-alien-double ] >>setter
 323         8 >>size
 324         8-byte-alignment
 325         "from_double" >>boxer
 326         "to_double" >>unboxer
 327         double-rep >>rep
 328         [ >float ] >>unboxer-quot
 329     \ double define-primitive-type
 330
 331     cell 8 = [
 332         <c-type>
 333             fixnum >>class
 334             fixnum >>boxed-class
 335             [ alien-signed-4 ] >>getter
 336             [ set-alien-signed-4 ] >>setter
 337             4 >>size
 338             4 >>align
 339             4 >>align-first
 340             "from_signed_4" >>boxer
 341             "to_signed_4" >>unboxer
 342             [ >fixnum ] >>unboxer-quot
 343         \ int define-primitive-type
 344
 345         <c-type>
 346             fixnum >>class
 347             fixnum >>boxed-class
 348             [ alien-unsigned-4 ] >>getter
 349             [ set-alien-unsigned-4 ] >>setter
 350             4 >>size
 351             4 >>align
 352             4 >>align-first
 353             "from_unsigned_4" >>boxer
 354             "to_unsigned_4" >>unboxer
 355             [ >fixnum ] >>unboxer-quot
 356         \ uint define-primitive-type
 357
 358         <c-type>
 359             integer >>class
 360             integer >>boxed-class
 361             [ alien-signed-cell ] >>getter
 362             [ set-alien-signed-cell ] >>setter
 363             8 >>size
 364             8 >>align
 365             8 >>align-first
 366             "from_signed_cell" >>boxer
 367             "to_fixnum" >>unboxer
 368             [ >integer ] >>unboxer-quot
 369         \ longlong define-primitive-type
 370
 371         <c-type>
 372             integer >>class
 373             integer >>boxed-class
 374             [ alien-unsigned-cell ] >>getter
 375             [ set-alien-unsigned-cell ] >>setter
 376             8 >>size
 377             8 >>align
 378             8 >>align-first
 379             "from_unsigned_cell" >>boxer
 380             "to_cell" >>unboxer
 381             [ >integer ] >>unboxer-quot
 382         \ ulonglong define-primitive-type
 383
 384         os windows? [
 385             \ int c-type \ long define-primitive-type
 386             \ uint c-type \ ulong define-primitive-type
 387         ] [
 388             \ longlong c-type \ long define-primitive-type
 389             \ ulonglong c-type \ ulong define-primitive-type
 390         ] if
 391
 392         \ longlong c-type \ ptrdiff_t typedef
 393         \ longlong c-type \ intptr_t typedef
 394
 395         \ ulonglong c-type \ uintptr_t typedef
 396         \ ulonglong c-type \ size_t typedef
 397     ] [
 398         <c-type>
 399             integer >>class
 400             integer >>boxed-class
 401             [ alien-signed-cell ] >>getter
 402             [ set-alien-signed-cell ] >>setter
 403             4 >>size
 404             4 >>align
 405             4 >>align-first
 406             "from_signed_cell" >>boxer
 407             "to_fixnum" >>unboxer
 408             [ >integer ] >>unboxer-quot
 409         \ int define-primitive-type
 410
 411         <c-type>
 412             integer >>class
 413             integer >>boxed-class
 414             [ alien-unsigned-cell ] >>getter
 415             [ set-alien-unsigned-cell ] >>setter
 416             4 >>size
 417             4 >>align
 418             4 >>align-first
 419             "from_unsigned_cell" >>boxer
 420             "to_cell" >>unboxer
 421             [ >integer ] >>unboxer-quot
 422         \ uint define-primitive-type
 423
 424         <long-long-type>
 425             integer >>class
 426             integer >>boxed-class
 427             [ alien-signed-8 ] >>getter
 428             [ set-alien-signed-8 ] >>setter
 429             8 >>size
 430             8-byte-alignment
 431             "from_signed_8" >>boxer
 432             "to_signed_8" >>unboxer
 433             [ >integer ] >>unboxer-quot
 434         \ longlong define-primitive-type
 435
 436         <long-long-type>
 437             integer >>class
 438             integer >>boxed-class
 439             [ alien-unsigned-8 ] >>getter
 440             [ set-alien-unsigned-8 ] >>setter
 441             8 >>size
 442             8-byte-alignment
 443             "from_unsigned_8" >>boxer
 444             "to_unsigned_8" >>unboxer
 445             [ >integer ] >>unboxer-quot
 446         \ ulonglong define-primitive-type
 447
 448         \ int c-type \ long define-primitive-type
 449         \ uint c-type \ ulong define-primitive-type
 450
 451         \ int c-type \ ptrdiff_t typedef
 452         \ int c-type \ intptr_t typedef
 453
 454         \ uint c-type \ uintptr_t typedef
 455         \ uint c-type \ size_t typedef
 456     ] if
 457
 458     cpu ppc? \ uint \ uchar ? c-type clone
 459         [ >c-bool ] >>unboxer-quot
 460         [ c-bool> ] >>boxer-quot
 461         object >>boxed-class
 462     \ bool define-primitive-type
 463
 464 ] with-compilation-unit
 465
 466 M: char-16-rep rep-component-type drop char ;
 467 M: uchar-16-rep rep-component-type drop uchar ;
 468 M: short-8-rep rep-component-type drop short ;
 469 M: ushort-8-rep rep-component-type drop ushort ;
 470 M: int-4-rep rep-component-type drop int ;
 471 M: uint-4-rep rep-component-type drop uint ;
 472 M: longlong-2-rep rep-component-type drop longlong ;
 473 M: ulonglong-2-rep rep-component-type drop ulonglong ;
 474 M: float-4-rep rep-component-type drop float ;
 475 M: double-2-rep rep-component-type drop double ;
 476
 477 : (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
 478 : unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
 479 : (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable
 480 : signed-interval ( c-type -- from to ) heap-size (signed-interval) ; foldable
 481
 482 : c-type-interval ( c-type -- from to )
 483     {
 484         { [ dup { float double } member-eq? ] [ drop -1/0. 1/0. ] }
 485         { [ dup { char short int long longlong } member-eq? ] [ signed-interval ] }
 486         { [ dup { uchar ushort uint ulong ulonglong } member-eq? ] [ unsigned-interval ] }
 487     } cond ; foldable
 488
 489 : c-type-clamp ( value c-type -- value' )
 490     dup { float double } member-eq?
 491     [ drop ] [ c-type-interval clamp ] if ; inline