basis/bootstrap/image/primitives/primitives.factor

   1 USING: alien alien.strings arrays assocs byte-arrays
   2 io.encodings.ascii kernel kernel.private locals math quotations
   3 sequences sequences.generalizations sequences.private strings words ;
   4 IN: bootstrap.image.primitives
   5
   6 CONSTANT: all-primitives {
   7     {
   8         "alien"
   9         {
  10             {
  11                 "<callback>" ( word return-rewind -- alien ) "callback"
  12                 { word integer } { alien } f
  13             }
  14             {
  15                 "<displaced-alien>" ( displacement c-ptr -- alien ) "displaced_alien"
  16                 { integer c-ptr } { c-ptr } make-flushable
  17             }
  18             {
  19                 "alien-address" ( c-ptr -- addr ) "alien_address"
  20                 { alien } { integer } make-flushable
  21             }
  22             { "free-callback" ( alien -- ) "free_callback" { alien } { } f }
  23         }
  24     }
  25     {
  26         "alien.private"
  27         {
  28             { "current-callback" ( -- n ) "current_callback" { } { fixnum } make-flushable }
  29         }
  30     }
  31     {
  32         "alien.accessors"
  33         {
  34             {
  35                 "alien-cell" ( c-ptr n -- value ) "alien_cell"
  36                 { c-ptr integer } { pinned-c-ptr } make-flushable
  37             }
  38             {
  39                 "alien-double" ( c-ptr n -- value ) "alien_double"
  40                 { c-ptr integer } { float } make-flushable
  41             }
  42             {
  43                 "alien-float" ( c-ptr n -- value ) "alien_float"
  44                 { c-ptr integer } { float } make-flushable
  45             }
  46             {
  47                 "alien-signed-1" ( c-ptr n -- value ) "alien_signed_1"
  48                 { c-ptr integer } { fixnum } make-flushable
  49             }
  50             {
  51                 "alien-signed-2" ( c-ptr n -- value ) "alien_signed_2"
  52                 { c-ptr integer } { fixnum } make-flushable
  53             }
  54             {
  55                 "alien-signed-4" ( c-ptr n -- value ) "alien_signed_4"
  56                 { c-ptr integer } { integer } make-flushable
  57             }
  58             {
  59                 "alien-signed-8" ( c-ptr n -- value ) "alien_signed_8"
  60                 { c-ptr integer } { integer } make-flushable
  61             }
  62             {
  63                 "alien-signed-cell" ( c-ptr n -- value ) "alien_signed_cell"
  64                 { c-ptr integer } { integer } make-flushable
  65             }
  66             {
  67                 "alien-unsigned-1" ( c-ptr n -- value ) "alien_unsigned_1"
  68                 { c-ptr integer } { fixnum } make-flushable
  69             }
  70             {
  71                 "alien-unsigned-2" ( c-ptr n -- value ) "alien_unsigned_2"
  72                 { c-ptr integer } { fixnum } make-flushable
  73             }
  74             {
  75                 "alien-unsigned-4" ( c-ptr n -- value ) "alien_unsigned_4"
  76                 { c-ptr integer } { integer } make-flushable
  77             }
  78             {
  79                 "alien-unsigned-8" ( c-ptr n -- value ) "alien_unsigned_8"
  80                 { c-ptr integer } { integer } make-flushable
  81             }
  82             {
  83                 "alien-unsigned-cell" ( c-ptr n -- value ) "alien_unsigned_cell"
  84                 { c-ptr integer } { integer } make-flushable
  85             }
  86             {
  87                 "set-alien-cell" ( value c-ptr n -- ) "set_alien_cell"
  88                 { c-ptr c-ptr integer } { } f
  89             }
  90             {
  91                 "set-alien-double" ( value c-ptr n -- ) "set_alien_double"
  92                 { float c-ptr integer } { } f
  93             }
  94             {
  95                 "set-alien-float" ( value c-ptr n -- ) "set_alien_float"
  96                 { float c-ptr integer } { } f
  97             }
  98             {
  99                 "set-alien-signed-1" ( value c-ptr n -- ) "set_alien_signed_1"
 100                 { integer c-ptr integer } { } f
 101             }
 102             {
 103                 "set-alien-signed-2" ( value c-ptr n -- ) "set_alien_signed_2"
 104                 { integer c-ptr integer } { } f
 105             }
 106             {
 107                 "set-alien-signed-4" ( value c-ptr n -- ) "set_alien_signed_4"
 108                 { integer c-ptr integer } { } f
 109             }
 110             {
 111                 "set-alien-signed-8" ( value c-ptr n -- ) "set_alien_signed_8"
 112                 { integer c-ptr integer } { } f
 113             }
 114             {
 115                 "set-alien-signed-cell" ( value c-ptr n -- ) "set_alien_signed_cell"
 116                 { integer c-ptr integer } { } f
 117             }
 118             {
 119                 "set-alien-unsigned-1" ( value c-ptr n -- ) "set_alien_unsigned_1"
 120                 { integer c-ptr integer } { } f
 121             }
 122             {
 123                 "set-alien-unsigned-2" ( value c-ptr n -- ) "set_alien_unsigned_2"
 124                 { integer c-ptr integer } { } f
 125             }
 126             {
 127                 "set-alien-unsigned-4" ( value c-ptr n -- ) "set_alien_unsigned_4"
 128                 { integer c-ptr integer } { } f
 129             }
 130             {
 131                 "set-alien-unsigned-8" ( value c-ptr n -- ) "set_alien_unsigned_8"
 132                 { integer c-ptr integer } { } f
 133             }
 134             {
 135                 "set-alien-unsigned-cell" ( value c-ptr n -- ) "set_alien_unsigned_cell"
 136                 { integer c-ptr integer } { } f
 137             }
 138         }
 139     }
 140     {
 141         "alien.libraries"
 142         {
 143             { "(dlopen)" ( path -- dll ) "dlopen" { byte-array } { dll } f }
 144             { "(dlsym)" ( name dll -- alien ) "dlsym" { byte-array object } { c-ptr } f }
 145             {
 146                 "(dlsym-raw)" ( name dll -- alien ) "dlsym_raw"
 147                 { byte-array object } { c-ptr } f
 148             }
 149             { "dlclose" ( dll -- ) "dlclose" { dll } { } f }
 150             { "dll-valid?" ( dll -- ? ) "dll_validp" { object } { object } f }
 151         }
 152     }
 153     {
 154         "arrays"
 155         {
 156             {
 157                 "<array>" ( n elt -- array ) "array"
 158                 { integer-array-capacity object } { array } make-flushable
 159             }
 160             {
 161                 "resize-array" ( n array -- new-array ) "resize_array"
 162                 { integer array } { array } f
 163             }
 164         }
 165     }
 166     {
 167         "byte-arrays"
 168         {
 169             {
 170                 "(byte-array)" ( n -- byte-array ) "uninitialized_byte_array"
 171                 { integer-array-capacity } { byte-array } make-flushable
 172             }
 173             {
 174                 "<byte-array>" ( n -- byte-array ) "byte_array"
 175                 { integer-array-capacity } { byte-array } make-flushable
 176             }
 177             {
 178                 "resize-byte-array" ( n byte-array -- new-byte-array )
 179                 "resize_byte_array"
 180                 { integer-array-capacity byte-array } { byte-array } f
 181             }
 182         }
 183     }
 184     {
 185         "classes.tuple.private"
 186         {
 187             {
 188                 "<tuple-boa>" ( slots... layout -- tuple ) "tuple_boa"
 189                 f f make-flushable
 190             }
 191             {
 192                 "<tuple>" ( layout -- tuple ) "tuple"
 193                 { array } { tuple } make-flushable
 194             }
 195         }
 196     }
 197     {
 198         "compiler.units"
 199         {
 200             {
 201                 "modify-code-heap" ( alist update-existing? reset-pics? -- )
 202                 "modify_code_heap"
 203                 { array object object } { } f
 204             }
 205         }
 206     }
 207     {
 208         "generic.single.private"
 209         {
 210             { "inline-cache-miss" ( generic methods index cache -- ) f f f f }
 211             { "inline-cache-miss-tail" ( generic methods index cache -- ) f f f f }
 212             {
 213                 "lookup-method" ( object methods -- method ) "lookup_method"
 214                 { object array } { word } f
 215             }
 216             { "mega-cache-lookup" ( methods index cache -- ) f f f f }
 217             { "mega-cache-miss" ( methods index cache -- method ) "mega_cache_miss" f f f }
 218         }
 219     }
 220     {
 221         "io.files.private"
 222         {
 223             { "(exists?)" ( path -- ? ) "existsp" { string } { object } f }
 224         }
 225     }
 226     {
 227         "io.streams.c"
 228         {
 229             {
 230                 "(fopen)" ( path mode -- alien ) "fopen"
 231                 { byte-array byte-array } { alien } f
 232             }
 233             { "fclose" ( alien -- ) "fclose" { alien } { } f }
 234             { "fflush" ( alien -- ) "fflush" { alien } { } f }
 235             { "fgetc" ( alien -- byte/f ) "fgetc" { alien } { object } f }
 236             { "fputc" ( byte alien -- ) "fputc" { object alien } { } f }
 237             {
 238                 "fread-unsafe" ( n buf alien -- count ) "fread"
 239                 { integer c-ptr alien } { integer } f
 240             }
 241             {
 242                 "fseek" ( alien offset whence -- ) "fseek"
 243                 { integer integer alien } { } f
 244             }
 245             { "ftell" ( alien -- n ) "ftell" { alien } { integer } f }
 246             { "fwrite" ( data length alien -- ) "fwrite" { c-ptr integer alien } { } f }
 247         }
 248     }
 249     {
 250         "kernel"
 251         {
 252             { "(clone)" ( obj -- newobj ) "clone" { object } { object } make-flushable }
 253             {
 254                 "<wrapper>" ( obj -- wrapper ) "wrapper"
 255                 { object } { wrapper } make-foldable
 256             }
 257             {
 258                 "callstack>array" ( callstack -- array ) "callstack_to_array"
 259                 { callstack } { array } make-flushable
 260             }
 261             { "die" ( -- ) "die" { } { } f }
 262             { "drop" ( x -- ) f f f f }
 263             { "2drop" ( x y -- ) f f f f }
 264             { "3drop" ( x y z -- ) f f f f }
 265             { "4drop" ( w x y z -- ) f f f f }
 266             { "dup" ( x -- x x ) f f f f }
 267             { "2dup" ( x y -- x y x y ) f f f f }
 268             { "3dup" ( x y z -- x y z x y z ) f f f f }
 269             { "4dup" ( w x y z -- w x y z w x y z ) f f f f }
 270             { "rot" ( x y z -- y z x ) f f f f }
 271             { "-rot" ( x y z -- z x y ) f f f f }
 272             { "dupd" ( x y -- x x y ) f f f f }
 273             { "swapd" ( x y z -- y x z ) f f f f }
 274             { "nip" ( x y -- y ) f f f f }
 275             { "2nip" ( x y z -- z ) f f f f }
 276             { "over" ( x y -- x y x ) f f f f }
 277             { "pick" ( x y z -- x y z x ) f f f f }
 278             { "swap" ( x y -- y x ) f f f f }
 279             { "eq?" ( obj1 obj2 -- ? ) f { object object } { object } make-foldable }
 280         }
 281     }
 282     {
 283         "kernel.private"
 284         {
 285             { "(call)" ( quot -- ) f f f f }
 286             { "(execute)" ( word -- ) f f f f }
 287             { "c-to-factor" ( -- ) f f f f }
 288             { "fpu-state" ( -- ) f { } { } f }
 289             { "lazy-jit-compile" ( -- ) f f f f }
 290             { "leaf-signal-handler" ( -- ) f { } { } f }
 291             { "set-callstack" ( callstack -- * ) f f f f }
 292             { "set-fpu-state" ( -- ) f { } { } f }
 293             { "signal-handler" ( -- ) f { } { } f }
 294             {
 295                 "tag" ( object -- n ) f
 296                 { object } { fixnum } make-foldable
 297             }
 298             { "unwind-native-frames" ( -- ) f f f f }
 299             {
 300                 "callstack-for" ( context -- array ) "callstack_for"
 301                 { c-ptr } { callstack } make-flushable
 302             }
 303             {
 304                 "datastack-for" ( context -- array ) "datastack_for"
 305                 { c-ptr } { array } make-flushable
 306             }
 307             {
 308                 "retainstack-for" ( context -- array ) "retainstack_for"
 309                 { c-ptr } { array } make-flushable
 310             }
 311             {
 312                 "(identity-hashcode)" ( obj -- code ) "identity_hashcode"
 313                 { object } { fixnum } f
 314             }
 315             { "become" ( old new -- ) "become" { array array } { } f }
 316             {
 317                 "check-datastack" ( array in# out# -- ? ) "check_datastack"
 318                 { array integer integer } { object } make-flushable
 319             }
 320             {
 321                 "compute-identity-hashcode" ( obj -- ) "compute_identity_hashcode"
 322                 { object } { } f
 323             }
 324             {
 325                 "context-object" ( n -- obj ) "context_object"
 326                 { fixnum } { object } make-flushable
 327             }
 328             {
 329                 "innermost-frame-executing" ( callstack -- obj )
 330                 "innermost_stack_frame_executing"
 331                 { callstack } { object } f
 332             }
 333             {
 334                 "innermost-frame-scan" ( callstack -- n ) "innermost_stack_frame_scan"
 335                 { callstack } { fixnum } f
 336             }
 337             {
 338                 "set-context-object" ( obj n -- ) "set_context_object"
 339                 { object fixnum } { } f
 340             }
 341             { "set-datastack" ( array -- ) "set_datastack" f f f }
 342             {
 343                 "set-innermost-frame-quotation" ( n callstack -- )
 344                 "set_innermost_stack_frame_quotation"
 345                 { quotation callstack } { } f
 346             }
 347             { "set-retainstack" ( array -- ) "set_retainstack" f f f }
 348             {
 349                 "set-special-object" ( obj n -- ) "set_special_object"
 350                 { object fixnum } { } f
 351             }
 352             {
 353                 "special-object" ( n -- obj ) "special_object"
 354                 { fixnum } { object } make-flushable
 355             }
 356             {
 357                 "strip-stack-traces" ( -- ) "strip_stack_traces"
 358                 { } { } f
 359             }
 360             {
 361                 "unimplemented" ( -- * ) "unimplemented"
 362                 { } { } f
 363             }
 364         }
 365     }
 366     {
 367         "locals.backend"
 368         {
 369             { "drop-locals" ( n -- ) f f f f }
 370             { "get-local" ( n -- obj ) f f f f }
 371             { "load-local" ( obj -- ) f f f f }
 372             { "load-locals" ( ... n -- ) "load_locals" f f f }
 373         }
 374     }
 375     {
 376         "math"
 377         {
 378             {
 379                 "bits>double" ( n -- x ) "bits_double"
 380                 { integer } { float } make-foldable
 381             }
 382             {
 383                 "bits>float" ( n -- x ) "bits_float"
 384                 { integer } { float } make-foldable
 385             }
 386             {
 387                 "double>bits" ( x -- n ) "double_bits"
 388                 { real } { integer } make-foldable
 389             }
 390             {
 391                 "float>bits" ( x -- n ) "float_bits"
 392                 { real } { integer } make-foldable
 393             }
 394         }
 395     }
 396     {
 397         "math.parser.private"
 398         {
 399             {
 400                 "(format-float)" ( n fill width precision format locale -- byte-array )
 401                 "format_float"
 402                 { float byte-array fixnum fixnum byte-array byte-array } { byte-array }
 403                 make-flushable
 404             }
 405         }
 406     }
 407     {
 408         "math.private"
 409         {
 410             { "both-fixnums?" ( x y -- ? ) f { object object } { object } f }
 411             {
 412                 "fixnum+fast" ( x y -- z ) f
 413                 { fixnum fixnum } { fixnum } make-foldable
 414             }
 415             {
 416                 "fixnum-fast" ( x y -- z ) f
 417                 { fixnum fixnum } { fixnum } make-foldable
 418             }
 419             {
 420                 "fixnum*fast" ( x y -- z ) f
 421                 { fixnum fixnum } { fixnum } make-foldable
 422             }
 423             {
 424                 "fixnum-bitand" ( x y -- z ) f
 425                 { fixnum fixnum } { fixnum } make-foldable
 426             }
 427             {
 428                 "fixnum-bitor" ( x y -- z ) f
 429                 { fixnum fixnum } { fixnum } make-foldable
 430             }
 431             {
 432                 "fixnum-bitxor" ( x y -- z ) f
 433                 { fixnum fixnum } { fixnum } make-foldable
 434             }
 435             {
 436                 "fixnum-bitnot" ( x -- y ) f
 437                 { fixnum } { fixnum } make-foldable
 438             }
 439             {
 440                 "fixnum-mod" ( x y -- z ) f
 441                 { fixnum fixnum } { fixnum } make-foldable
 442             }
 443             {
 444                 "fixnum-shift" ( x y -- z ) "fixnum_shift"
 445                 { fixnum fixnum } { integer } make-foldable
 446             }
 447             {
 448                 "fixnum-shift-fast" ( x y -- z ) f
 449                 { fixnum fixnum } { fixnum } make-foldable
 450             }
 451             {
 452                 "fixnum/i-fast" ( x y -- z ) f
 453                 { fixnum fixnum } { fixnum } make-foldable
 454             }
 455             {
 456                 "fixnum/mod" ( x y -- z w ) "fixnum_divmod"
 457                 { fixnum fixnum } { integer fixnum } make-foldable
 458             }
 459             {
 460                 "fixnum/mod-fast" ( x y -- z w ) f
 461                 { fixnum fixnum } { fixnum fixnum } make-foldable
 462             }
 463             {
 464                 "fixnum+" ( x y -- z ) f
 465                 { fixnum fixnum } { integer } make-foldable
 466             }
 467             {
 468                 "fixnum-" ( x y -- z ) f
 469                 { fixnum fixnum } { integer } make-foldable
 470             }
 471             {
 472                 "fixnum*" ( x y -- z ) f
 473                 { fixnum fixnum } { integer } make-foldable
 474             }
 475             {
 476                 "fixnum<" ( x y -- ? ) f
 477                 { fixnum fixnum } { object } make-foldable
 478             }
 479             {
 480                 "fixnum<=" ( x y -- z ) f
 481                 { fixnum fixnum } { object } make-foldable
 482             }
 483             {
 484                 "fixnum>" ( x y -- ? ) f
 485                 { fixnum fixnum } { object } make-foldable
 486             }
 487             {
 488                 "fixnum>=" ( x y -- ? ) f
 489                 { fixnum fixnum } { object } make-foldable
 490             }
 491             {
 492                 "bignum*" ( x y -- z ) "bignum_multiply"
 493                 { bignum bignum } { bignum } make-foldable
 494             }
 495             {
 496                 "bignum+" ( x y -- z ) "bignum_add"
 497                 { bignum bignum } { bignum } make-foldable
 498             }
 499             {
 500                 "bignum-" ( x y -- z ) "bignum_subtract"
 501                 { bignum bignum } { bignum } make-foldable
 502             }
 503             {
 504                 "bignum-bit?" ( x n -- ? ) "bignum_bitp"
 505                 { bignum integer } { object } make-foldable
 506             }
 507             {
 508                 "bignum-bitand" ( x y -- z ) "bignum_and"
 509                 { bignum bignum } { bignum } make-foldable
 510             }
 511             {
 512                 "bignum-bitnot" ( x -- y ) "bignum_not"
 513                 { bignum } { bignum } make-foldable
 514             }
 515             {
 516                 "bignum-bitor" ( x y -- z ) "bignum_or"
 517                 { bignum bignum } { bignum } make-foldable
 518             }
 519             {
 520                 "bignum-bitxor" ( x y -- z ) "bignum_xor"
 521                 { bignum bignum } { bignum } make-foldable
 522             }
 523             {
 524                 "bignum-log2" ( x -- n ) "bignum_log2"
 525                 { bignum } { bignum } make-foldable
 526             }
 527             {
 528                 "bignum-mod" ( x y -- z ) "bignum_mod"
 529                 { bignum bignum } { integer } make-foldable
 530             }
 531             {
 532                 "bignum-gcd" ( x y -- z ) "bignum_gcd"
 533                 { bignum bignum } { bignum } make-foldable
 534             }
 535             {
 536                 "bignum-shift" ( x y -- z ) "bignum_shift"
 537                 { bignum fixnum } { bignum } make-foldable
 538             }
 539             {
 540                 "bignum/i" ( x y -- z ) "bignum_divint"
 541                 { bignum bignum } { bignum } make-foldable
 542             }
 543             {
 544                 "bignum/mod" ( x y -- z w ) "bignum_divmod"
 545                 { bignum bignum } { bignum integer } make-foldable
 546             }
 547             {
 548                 "bignum<" ( x y -- ? ) "bignum_less"
 549                 { bignum bignum } { object } make-foldable
 550             }
 551             {
 552                 "bignum<=" ( x y -- ? ) "bignum_lesseq"
 553                 { bignum bignum } { object } make-foldable
 554             }
 555             {
 556                 "bignum=" ( x y -- ? ) "bignum_eq"
 557                 { bignum bignum } { object } make-foldable
 558             }
 559             {
 560                 "bignum>" ( x y -- ? ) "bignum_greater"
 561                 { bignum bignum } { object } make-foldable
 562             }
 563             {
 564                 "bignum>=" ( x y -- ? ) "bignum_greatereq"
 565                 { bignum bignum } { object } make-foldable
 566             }
 567             {
 568                 "bignum>fixnum" ( x -- y ) "bignum_to_fixnum"
 569                 { bignum } { fixnum } make-foldable
 570             }
 571             {
 572                 "bignum>fixnum-strict" ( x -- y ) "bignum_to_fixnum_strict"
 573                 { bignum } { fixnum } make-foldable
 574             }
 575             {
 576                 "fixnum/i" ( x y -- z ) "fixnum_divint"
 577                 { fixnum fixnum } { integer } make-foldable
 578             }
 579             {
 580                 "fixnum>bignum" ( x -- y ) "fixnum_to_bignum"
 581                 { fixnum } { bignum } make-foldable
 582             }
 583             {
 584                 "fixnum>float" ( x -- y ) "fixnum_to_float"
 585                 { fixnum } { float } make-foldable
 586             }
 587             {
 588                 "float*" ( x y -- z ) "float_multiply"
 589                 { float float } { float } make-foldable
 590             }
 591             {
 592                 "float+" ( x y -- z ) "float_add"
 593                 { float float } { float } make-foldable
 594             }
 595             {
 596                 "float-" ( x y -- z ) "float_subtract"
 597                 { float float } { float } make-foldable
 598             }
 599             ! -u ones redundant?
 600             {
 601                 "float-u<" ( x y -- ? ) "float_less"
 602                 { float float } { object } make-foldable
 603             }
 604             {
 605                 "float-u<=" ( x y -- ? ) "float_lesseq"
 606                 { float float } { object } make-foldable
 607             }
 608             {
 609                 "float-u>" ( x y -- ? ) "float_greater"
 610                 { float float } { object } make-foldable
 611             }
 612             {
 613                 "float-u>=" ( x y -- ? ) "float_greatereq"
 614                 { float float } { object } make-foldable
 615             }
 616             {
 617                 "float/f" ( x y -- z ) "float_divfloat"
 618                 { float float } { float } make-foldable
 619             }
 620             {
 621                 "float<" ( x y -- ? ) "float_less"
 622                 { float float } { object } make-foldable
 623             }
 624             {
 625                 "float<=" ( x y -- ? ) "float_lesseq"
 626                 { float float } { object } make-foldable
 627             }
 628             {
 629                 "float=" ( x y -- ? ) "float_eq"
 630                 { float float } { object } make-foldable
 631             }
 632             {
 633                 "float>" ( x y -- ? ) "float_greater"
 634                 { float float } { object } make-foldable
 635             }
 636             {
 637                 "float>=" ( x y -- ? ) "float_greatereq"
 638                 { float float } { object } make-foldable
 639             }
 640             {
 641                 "float>bignum" ( x -- y ) "float_to_bignum"
 642                 { float } { bignum } make-foldable
 643             }
 644             {
 645                 "float>fixnum" ( x -- y ) "float_to_fixnum"
 646                 { float } { fixnum } make-foldable
 647             }
 648         }
 649     }
 650     {
 651         "memory"
 652         {
 653             { "all-instances" ( -- array ) "all_instances" { } { array } f }
 654             { "compact-gc" ( -- ) "compact_gc" { } { } f }
 655             { "gc" ( -- ) "full_gc" { } { } f }
 656             { "minor-gc" ( -- ) "minor_gc" { } { } f }
 657             { "size" ( obj -- n ) "size" { object } { fixnum } make-flushable }
 658         }
 659     }
 660     {
 661         "memory.private"
 662         {
 663             {
 664                 "(save-image)" ( path1 path2 then-die? -- ) "save_image"
 665                 { byte-array byte-array object } { } f
 666             }
 667         }
 668     }
 669     {
 670         "quotations"
 671         {
 672             { "jit-compile" ( quot -- ) "jit_compile" { quotation } { } f }
 673             {
 674                 "quotation-code" ( quot -- start end ) "quotation_code"
 675                 { quotation } { integer integer } make-flushable
 676             }
 677             {
 678                 "quotation-compiled?" ( quot -- ? ) "quotation_compiled_p"
 679                 { quotation } { object } f
 680             }
 681         }
 682     }
 683     {
 684         "quotations.private"
 685         {
 686             {
 687                 "array>quotation" ( array -- quot ) "array_to_quotation"
 688                 { array } { quotation } make-flushable
 689             }
 690         }
 691     }
 692     {
 693         "slots.private"
 694         {
 695             { "set-slot" ( value obj n -- ) "set_slot" { object object fixnum } { } f }
 696             { "slot" ( obj m -- value ) f { object fixnum } { object } make-flushable }
 697         }
 698     }
 699     {
 700         "strings"
 701         {
 702             {
 703                 "<string>" ( n ch -- string ) "string"
 704                 { integer-array-capacity integer } { string } make-flushable
 705             }
 706             {
 707                 "resize-string" ( n str -- newstr ) "resize_string"
 708                 { integer string } { string } f
 709             }
 710         }
 711     }
 712     {
 713         "strings.private"
 714         {
 715             {
 716                 "set-string-nth-fast" ( ch n string -- ) "set_string_nth_fast"
 717                 { fixnum fixnum string } { } f
 718             }
 719             {
 720                 "string-nth-fast" ( n string -- ch ) f
 721                 { fixnum string } { fixnum } make-flushable
 722             }
 723         }
 724     }
 725     {
 726         "system"
 727         {
 728             { "(exit)" ( n -- * ) "exit" { integer } { } f }
 729             { "disable-ctrl-break" ( -- ) "disable_ctrl_break" { } { } f }
 730             { "enable-ctrl-break" ( -- ) "enable_ctrl_break" { } { } f }
 731             { "nano-count" ( -- ns ) "nano_count" { } { integer } make-flushable }
 732         }
 733     }
 734     {
 735         "threads.private"
 736         {
 737             { "(sleep)" ( nanos -- ) "sleep" { integer } { } f }
 738             { "(set-context)" ( obj context -- obj' ) f { object alien } { object } f }
 739             { "(set-context-and-delete)" ( obj context -- * ) f { object alien } { } f }
 740             { "(start-context)" ( obj quot -- obj' ) f { object quotation } { object } f }
 741             { "(start-context-and-delete)" ( obj quot -- * ) f { object quotation } { } f }
 742             {
 743                 "context-object-for" ( n context -- obj ) "context_object_for"
 744                 { fixnum c-ptr } { object } make-flushable
 745             }
 746         }
 747     }
 748     {
 749         "tools.dispatch.private"
 750         {
 751             { "dispatch-stats" ( -- stats ) "dispatch_stats" { } { byte-array } f }
 752             { "reset-dispatch-stats" ( -- ) "reset_dispatch_stats" { } { } f }
 753         }
 754     }
 755     {
 756         "tools.memory.private"
 757         {
 758             {
 759                 "(callback-room)" ( -- allocator-room ) "callback_room"
 760                 { } { byte-array } make-flushable
 761             }
 762             {
 763                 "(code-blocks)" ( -- array ) "code_blocks"
 764                 { } { array } make-flushable
 765             }
 766             {
 767                 "(code-room)" ( -- allocator-room ) "code_room"
 768                 { } { byte-array } make-flushable
 769             }
 770             {
 771                 "(data-room)" ( -- data-room ) "data_room"
 772                 { } { byte-array } make-flushable
 773             }
 774             { "disable-gc-events" ( -- events ) "disable_gc_events" { } { object } f }
 775             { "enable-gc-events" ( -- ) "enable_gc_events" { } { } f }
 776         }
 777     }
 778     {
 779         "tools.profiler.sampling.private"
 780         {
 781             { "profiling" ( n -- ) "sampling_profiler" { object } { } f }
 782             { "(get-samples)" ( -- samples/f ) "get_samples" { } { object } f }
 783         }
 784     }
 785     {
 786         "words"
 787         {
 788             {
 789                 "word-code" ( word -- start end ) "word_code"
 790                 { word } { integer integer } make-flushable
 791             }
 792             { "word-optimized?" ( word -- ? ) "word_optimized_p" { word } { object } f }
 793         }
 794     }
 795     {
 796         "words.private"
 797         {
 798             {
 799                 "(word)" ( name vocab hashcode -- word ) "word"
 800                 { object object object } { word } make-flushable
 801             }
 802         }
 803     }
 804 }
 805
 806 : primitive-quot ( word vm-func -- quot )
 807     [
 808         nip "primitive_" prepend ascii string>alien [ do-primitive ] curry
 809     ] [ 1quotation ] if* ;
 810
 811 : primitive-word ( name vocab -- word )
 812     create-word dup t "primitive" set-word-prop ;
 813
 814 : set-extra-props ( word extra-props -- )
 815     [ rot set-word-prop ] with assoc-each ;
 816
 817 :: create-primitive ( vocab word effect vm-func inputs outputs extra-word -- )
 818     word vocab primitive-word :> word
 819     word vm-func primitive-quot :> quot
 820     word quot effect define-declared
 821     word inputs "input-classes" set-word-prop
 822     word outputs "default-output-classes" set-word-prop
 823     word extra-word [ execute( x -- ) ] [ drop ] if* ;
 824
 825 : create-primitives ( assoc -- )
 826     [
 827         [ 6 firstn create-primitive ] with each
 828     ] assoc-each ;