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