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