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

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