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