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