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

   1 ! Copyright (C) 2004, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.accessors arrays classes
   4 combinators compiler.units cpu.architecture delegate kernel
   5 layouts math math.order math.parser quotations sequences summary
   6 system words words.symbol ;
   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 SYMBOLS:
 181     isize usize
 182     s8 u8 s16 u16 s32 u32 s64 u64
 183     f32 f64 ;
 184
 185 CONSTANT: primitive-types
 186     {
 187         char uchar
 188         short ushort
 189         int uint
 190         long ulong
 191         longlong ulonglong
 192         float double
 193         void* bool
 194         c-string
 195     }
 196
 197 : >c-bool ( ? -- int ) 1 0 ? ; inline
 198
 199 : c-bool> ( int -- ? ) 0 = not ; inline
 200
 201 <PRIVATE
 202
 203 : 8-byte-alignment ( c-type -- c-type )
 204     {
 205         { [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] }
 206         [ 8 >>align 8 >>align-first ]
 207     } cond ;
 208
 209 : resolve-pointer-typedef ( type -- base-type )
 210     dup "c-type" word-prop dup word?
 211     [ nip resolve-pointer-typedef ] [
 212         pointer? [ drop void* ] when
 213     ] if ;
 214
 215 : primitive-pointer-type? ( type -- ? )
 216     dup c-type-word? [
 217         resolve-pointer-typedef [ void? ] [ primitive-types member? ] bi or
 218     ] [ drop t ] if ;
 219
 220 : (pointer-c-type) ( void* type -- void*' )
 221     [ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ;
 222
 223 PRIVATE>
 224
 225 M: pointer lookup-c-type
 226     [ \ void* lookup-c-type ] dip
 227     to>> dup primitive-pointer-type? [ drop ] [ (pointer-c-type) ] if ;
 228
 229 [
 230     <c-type>
 231         c-ptr >>class
 232         c-ptr >>boxed-class
 233         [ alien-cell ] >>getter
 234         [ set-alien-cell ] >>setter
 235         bootstrap-cell >>size
 236         bootstrap-cell >>align
 237         bootstrap-cell >>align-first
 238         [ >c-ptr ] >>unboxer-quot
 239         "allot_alien" >>boxer
 240         "alien_offset" >>unboxer
 241     \ void* typedef
 242
 243     <c-type>
 244         fixnum >>class
 245         fixnum >>boxed-class
 246         [ alien-signed-2 ] >>getter
 247         [ set-alien-signed-2 ] >>setter
 248         2 >>size
 249         t >>signed
 250         2 >>align
 251         2 >>align-first
 252         "from_signed_2" >>boxer
 253         "to_signed_2" >>unboxer
 254         [ >fixnum ] >>unboxer-quot
 255     \ short typedef
 256
 257     <c-type>
 258         fixnum >>class
 259         fixnum >>boxed-class
 260         [ alien-unsigned-2 ] >>getter
 261         [ set-alien-unsigned-2 ] >>setter
 262         2 >>size
 263         2 >>align
 264         2 >>align-first
 265         "from_unsigned_2" >>boxer
 266         "to_unsigned_2" >>unboxer
 267         [ >fixnum ] >>unboxer-quot
 268     \ ushort typedef
 269
 270     <c-type>
 271         fixnum >>class
 272         fixnum >>boxed-class
 273         [ alien-signed-1 ] >>getter
 274         [ set-alien-signed-1 ] >>setter
 275         1 >>size
 276         t >>signed
 277         1 >>align
 278         1 >>align-first
 279         "from_signed_1" >>boxer
 280         "to_signed_1" >>unboxer
 281         [ >fixnum ] >>unboxer-quot
 282     \ char typedef
 283
 284     <c-type>
 285         fixnum >>class
 286         fixnum >>boxed-class
 287         [ alien-unsigned-1 ] >>getter
 288         [ set-alien-unsigned-1 ] >>setter
 289         1 >>size
 290         1 >>align
 291         1 >>align-first
 292         "from_unsigned_1" >>boxer
 293         "to_unsigned_1" >>unboxer
 294         [ >fixnum ] >>unboxer-quot
 295     \ uchar typedef
 296
 297     <c-type>
 298         math:float >>class
 299         math:float >>boxed-class
 300         [ alien-float ] >>getter
 301         [ set-alien-float ] >>setter
 302         4 >>size
 303         4 >>align
 304         4 >>align-first
 305         "from_float" >>boxer
 306         "to_float" >>unboxer
 307         float-rep >>rep
 308         [ >float ] >>unboxer-quot
 309     \ float typedef
 310
 311     <c-type>
 312         math:float >>class
 313         math:float >>boxed-class
 314         [ alien-double ] >>getter
 315         [ set-alien-double ] >>setter
 316         8 >>size
 317         8-byte-alignment
 318         "from_double" >>boxer
 319         "to_double" >>unboxer
 320         double-rep >>rep
 321         [ >float ] >>unboxer-quot
 322     \ double typedef
 323
 324     cell 8 = [
 325         ! 64bit-vm int
 326         <c-type>
 327             fixnum >>class
 328             fixnum >>boxed-class
 329             [ alien-signed-4 ] >>getter
 330             [ set-alien-signed-4 ] >>setter
 331             4 >>size
 332             t >>signed
 333             4 >>align
 334             4 >>align-first
 335             "from_signed_4" >>boxer
 336             "to_signed_4" >>unboxer
 337             [ >fixnum ] >>unboxer-quot
 338         \ int typedef
 339
 340         ! 64bit-vm uint
 341         <c-type>
 342             fixnum >>class
 343             fixnum >>boxed-class
 344             [ alien-unsigned-4 ] >>getter
 345             [ set-alien-unsigned-4 ] >>setter
 346             4 >>size
 347             4 >>align
 348             4 >>align-first
 349             "from_unsigned_4" >>boxer
 350             "to_unsigned_4" >>unboxer
 351             [ >fixnum ] >>unboxer-quot
 352         \ uint typedef
 353
 354         ! 64bit-vm longlong
 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             t >>signed
 362             8 >>align
 363             8 >>align-first
 364             "from_signed_cell" >>boxer
 365             "to_signed_8" >>unboxer
 366             [ >integer ] >>unboxer-quot
 367         \ longlong typedef
 368
 369         ! 64bit-vm ulonglong
 370         <c-type>
 371             integer >>class
 372             integer >>boxed-class
 373             [ alien-unsigned-cell ] >>getter
 374             [ set-alien-unsigned-cell ] >>setter
 375             8 >>size
 376             8 >>align
 377             8 >>align-first
 378             "from_unsigned_cell" >>boxer
 379             "to_cell" >>unboxer
 380             [ >integer ] >>unboxer-quot
 381         \ ulonglong typedef
 382
 383         os windows? [
 384             \ int lookup-c-type \ long typedef
 385             \ uint lookup-c-type \ ulong typedef
 386         ] [
 387             \ longlong lookup-c-type \ long typedef
 388             \ ulonglong lookup-c-type \ ulong typedef
 389         ] if
 390
 391         \ longlong lookup-c-type \ ptrdiff_t typedef
 392         \ longlong lookup-c-type \ intptr_t typedef
 393
 394         \ ulonglong lookup-c-type \ uintptr_t typedef
 395         \ ulonglong lookup-c-type \ size_t typedef
 396
 397         \ longlong lookup-c-type \ isize typedef
 398         \ ulonglong lookup-c-type \ usize typedef
 399     ] [
 400         ! 32bit-vm int
 401         <c-type>
 402             integer >>class
 403             integer >>boxed-class
 404             [ alien-signed-cell ] >>getter
 405             [ set-alien-signed-cell ] >>setter
 406             4 >>size
 407             t >>signed
 408             4 >>align
 409             4 >>align-first
 410             "from_signed_cell" >>boxer
 411             "to_fixnum" >>unboxer
 412             [ >integer ] >>unboxer-quot
 413         \ int typedef
 414
 415         ! 32bit-vm uint
 416         <c-type>
 417             integer >>class
 418             integer >>boxed-class
 419             [ alien-unsigned-cell ] >>getter
 420             [ set-alien-unsigned-cell ] >>setter
 421             4 >>size
 422             4 >>align
 423             4 >>align-first
 424             "from_unsigned_cell" >>boxer
 425             "to_cell" >>unboxer
 426             [ >integer ] >>unboxer-quot
 427         \ uint typedef
 428
 429         ! 32bit-vm longlong
 430         <long-long-type>
 431             integer >>class
 432             integer >>boxed-class
 433             [ alien-signed-8 ] >>getter
 434             [ set-alien-signed-8 ] >>setter
 435             8 >>size
 436             t >>signed
 437             8-byte-alignment
 438             "from_signed_8" >>boxer
 439             "to_signed_8" >>unboxer
 440             [ >integer ] >>unboxer-quot
 441         \ longlong typedef
 442
 443         ! 32bit-vm ulonglong
 444         <long-long-type>
 445             integer >>class
 446             integer >>boxed-class
 447             [ alien-unsigned-8 ] >>getter
 448             [ set-alien-unsigned-8 ] >>setter
 449             8 >>size
 450             8-byte-alignment
 451             "from_unsigned_8" >>boxer
 452             "to_unsigned_8" >>unboxer
 453             [ >integer ] >>unboxer-quot
 454         \ ulonglong typedef
 455
 456         \ int lookup-c-type \ long typedef
 457         \ uint lookup-c-type \ ulong typedef
 458
 459         \ int lookup-c-type \ ptrdiff_t typedef
 460         \ int lookup-c-type \ intptr_t typedef
 461
 462         \ uint lookup-c-type \ uintptr_t typedef
 463         \ uint lookup-c-type \ size_t typedef
 464
 465         \ int lookup-c-type \ isize typedef
 466         \ uint lookup-c-type \ usize typedef
 467     ] if
 468
 469     \ uchar lookup-c-type clone
 470         [ >c-bool ] >>unboxer-quot
 471         [ c-bool> ] >>boxer-quot
 472         object >>boxed-class
 473     \ bool typedef
 474
 475     \ char lookup-c-type int8_t typedef
 476     \ short lookup-c-type int16_t typedef
 477     \ int lookup-c-type int32_t typedef
 478     \ longlong lookup-c-type int64_t typedef
 479
 480     \ uchar lookup-c-type uint8_t typedef
 481     \ ushort lookup-c-type uint16_t typedef
 482     \ uint lookup-c-type uint32_t typedef
 483     \ ulonglong lookup-c-type uint64_t typedef
 484
 485     \ char lookup-c-type s8 typedef
 486     \ short lookup-c-type s16 typedef
 487     \ int lookup-c-type s32 typedef
 488     \ longlong lookup-c-type s64 typedef
 489
 490     \ uchar lookup-c-type u8 typedef
 491     \ ushort lookup-c-type u16 typedef
 492     \ uint lookup-c-type u32 typedef
 493     \ ulonglong lookup-c-type u64 typedef
 494
 495     \ float lookup-c-type f32 typedef
 496     \ double lookup-c-type f64 typedef
 497 ] with-compilation-unit
 498
 499 M: char-16-rep rep-component-type drop char ;
 500 M: uchar-16-rep rep-component-type drop uchar ;
 501 M: short-8-rep rep-component-type drop short ;
 502 M: ushort-8-rep rep-component-type drop ushort ;
 503 M: int-4-rep rep-component-type drop int ;
 504 M: uint-4-rep rep-component-type drop uint ;
 505 M: longlong-2-rep rep-component-type drop longlong ;
 506 M: ulonglong-2-rep rep-component-type drop ulonglong ;
 507 M: float-4-rep rep-component-type drop float ;
 508 M: double-2-rep rep-component-type drop double ;
 509
 510 : (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
 511 : unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
 512 : (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable
 513 : signed-interval ( c-type -- from to ) heap-size (signed-interval) ; foldable
 514
 515 : c-type-interval ( c-type -- from to )
 516     {
 517         { [ dup { float double } member-eq? ] [ drop -1/0. 1/0. ] }
 518         { [ dup c-type-signed ] [ signed-interval ] }
 519         { [ dup c-type-signed not ] [ unsigned-interval ] }
 520     } cond ; foldable
 521
 522 : c-type-clamp ( value c-type -- value' )
 523     dup { float double } member-eq?
 524     [ drop ] [ c-type-interval clamp ] if ; inline
 525
 526 GENERIC: pointer-string ( pointer -- string/f )
 527 M: object pointer-string drop f ;
 528 M: word pointer-string name>> ;
 529 M: pointer pointer-string to>> pointer-string [ CHAR: * suffix ] [ f ] if* ;
 530
 531 GENERIC: c-type-string ( c-type -- string )
 532
 533 M: integer c-type-string number>string ;
 534 M: word c-type-string name>> ;
 535 M: pointer c-type-string pointer-string ;
 536 M: wrapper c-type-string wrapped>> c-type-string ;
 537 M: array c-type-string
 538     unclip
 539     [ [ c-type-string "[" "]" surround ] map ]
 540     [ c-type-string ] bi*
 541     prefix concat ;