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