basis/bootstrap/image/primitives/primitives.factor

   1 USING: alien alien.strings arrays assocs byte-arrays
   2 io.encodings.ascii kernel kernel.private 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             { "(file-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                 "callstack-bounds" ( -- start end ) "callstack_bounds"
 318                 { } { alien alien } make-flushable
 319             }
 320             {
 321                 "check-datastack" ( array in# out# -- ? ) "check_datastack"
 322                 { array integer integer } { object } make-flushable
 323             }
 324             {
 325                 "compute-identity-hashcode" ( obj -- ) "compute_identity_hashcode"
 326                 { object } { } f
 327             }
 328             {
 329                 "context-object" ( n -- obj ) "context_object"
 330                 { fixnum } { object } make-flushable
 331             }
 332             {
 333                 "innermost-frame-executing" ( callstack -- obj )
 334                 "innermost_stack_frame_executing"
 335                 { callstack } { object } f
 336             }
 337             {
 338                 "innermost-frame-scan" ( callstack -- n ) "innermost_stack_frame_scan"
 339                 { callstack } { fixnum } f
 340             }
 341             {
 342                 "set-context-object" ( obj n -- ) "set_context_object"
 343                 { object fixnum } { } f
 344             }
 345             { "set-datastack" ( array -- ) "set_datastack" f f f }
 346             {
 347                 "set-innermost-frame-quotation" ( n callstack -- )
 348                 "set_innermost_stack_frame_quotation"
 349                 { quotation callstack } { } f
 350             }
 351             { "set-retainstack" ( array -- ) "set_retainstack" f f f }
 352             {
 353                 "set-special-object" ( obj n -- ) "set_special_object"
 354                 { object fixnum } { } f
 355             }
 356             {
 357                 "special-object" ( n -- obj ) "special_object"
 358                 { fixnum } { object } make-flushable
 359             }
 360             {
 361                 "strip-stack-traces" ( -- ) "strip_stack_traces"
 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             {
 411                 "both-fixnums?" ( x y -- ? ) f
 412                 { object object } { object } make-foldable
 413             }
 414             {
 415                 "fixnum+fast" ( x y -- z ) f
 416                 { fixnum fixnum } { fixnum } make-foldable
 417             }
 418             {
 419                 "fixnum-fast" ( x y -- z ) f
 420                 { fixnum fixnum } { fixnum } make-foldable
 421             }
 422             {
 423                 "fixnum*fast" ( x y -- z ) f
 424                 { fixnum fixnum } { fixnum } make-foldable
 425             }
 426             {
 427                 "fixnum-bitand" ( x y -- z ) f
 428                 { fixnum fixnum } { fixnum } make-foldable
 429             }
 430             {
 431                 "fixnum-bitor" ( x y -- z ) f
 432                 { fixnum fixnum } { fixnum } make-foldable
 433             }
 434             {
 435                 "fixnum-bitxor" ( x y -- z ) f
 436                 { fixnum fixnum } { fixnum } make-foldable
 437             }
 438             {
 439                 "fixnum-bitnot" ( x -- y ) f
 440                 { fixnum } { fixnum } make-foldable
 441             }
 442             {
 443                 "fixnum-mod" ( x y -- z ) f
 444                 { fixnum fixnum } { fixnum } make-foldable
 445             }
 446             {
 447                 "fixnum-shift" ( x y -- z ) "fixnum_shift"
 448                 { fixnum fixnum } { integer } make-foldable
 449             }
 450             {
 451                 "fixnum-shift-fast" ( x y -- z ) f
 452                 { fixnum fixnum } { fixnum } make-foldable
 453             }
 454             {
 455                 "fixnum/i-fast" ( x y -- z ) f
 456                 { fixnum fixnum } { fixnum } make-foldable
 457             }
 458             {
 459                 "fixnum/mod" ( x y -- z w ) "fixnum_divmod"
 460                 { fixnum fixnum } { integer fixnum } make-foldable
 461             }
 462             {
 463                 "fixnum/mod-fast" ( x y -- z w ) f
 464                 { fixnum fixnum } { fixnum fixnum } make-foldable
 465             }
 466             {
 467                 "fixnum+" ( x y -- z ) f
 468                 { fixnum fixnum } { integer } make-foldable
 469             }
 470             {
 471                 "fixnum-" ( x y -- z ) f
 472                 { fixnum fixnum } { integer } make-foldable
 473             }
 474             {
 475                 "fixnum*" ( x y -- z ) f
 476                 { fixnum fixnum } { integer } make-foldable
 477             }
 478             {
 479                 "fixnum<" ( x y -- ? ) f
 480                 { fixnum fixnum } { object } make-foldable
 481             }
 482             {
 483                 "fixnum<=" ( x y -- z ) f
 484                 { fixnum fixnum } { object } make-foldable
 485             }
 486             {
 487                 "fixnum>" ( x y -- ? ) f
 488                 { fixnum fixnum } { object } make-foldable
 489             }
 490             {
 491                 "fixnum>=" ( x y -- ? ) f
 492                 { fixnum fixnum } { object } make-foldable
 493             }
 494             {
 495                 "bignum*" ( x y -- z ) "bignum_multiply"
 496                 { bignum bignum } { bignum } make-foldable
 497             }
 498             {
 499                 "bignum+" ( x y -- z ) "bignum_add"
 500                 { bignum bignum } { bignum } make-foldable
 501             }
 502             {
 503                 "bignum-" ( x y -- z ) "bignum_subtract"
 504                 { bignum bignum } { bignum } make-foldable
 505             }
 506             {
 507                 "bignum-bit?" ( x n -- ? ) "bignum_bitp"
 508                 { bignum integer } { object } make-foldable
 509             }
 510             {
 511                 "bignum-bitand" ( x y -- z ) "bignum_and"
 512                 { bignum bignum } { bignum } make-foldable
 513             }
 514             {
 515                 "bignum-bitnot" ( x -- y ) "bignum_not"
 516                 { bignum } { bignum } make-foldable
 517             }
 518             {
 519                 "bignum-bitor" ( x y -- z ) "bignum_or"
 520                 { bignum bignum } { bignum } make-foldable
 521             }
 522             {
 523                 "bignum-bitxor" ( x y -- z ) "bignum_xor"
 524                 { bignum bignum } { bignum } make-foldable
 525             }
 526             {
 527                 "bignum-log2" ( x -- n ) "bignum_log2"
 528                 { bignum } { bignum } make-foldable
 529             }
 530             {
 531                 "bignum-mod" ( x y -- z ) "bignum_mod"
 532                 { bignum bignum } { integer } make-foldable
 533             }
 534             {
 535                 "bignum-gcd" ( x y -- z ) "bignum_gcd"
 536                 { bignum bignum } { bignum } make-foldable
 537             }
 538             {
 539                 "bignum-shift" ( x y -- z ) "bignum_shift"
 540                 { bignum fixnum } { bignum } make-foldable
 541             }
 542             {
 543                 "bignum/i" ( x y -- z ) "bignum_divint"
 544                 { bignum bignum } { bignum } make-foldable
 545             }
 546             {
 547                 "bignum/mod" ( x y -- z w ) "bignum_divmod"
 548                 { bignum bignum } { bignum integer } make-foldable
 549             }
 550             {
 551                 "bignum<" ( x y -- ? ) "bignum_less"
 552                 { bignum bignum } { object } make-foldable
 553             }
 554             {
 555                 "bignum<=" ( x y -- ? ) "bignum_lesseq"
 556                 { bignum bignum } { object } make-foldable
 557             }
 558             {
 559                 "bignum=" ( x y -- ? ) "bignum_eq"
 560                 { bignum bignum } { object } make-foldable
 561             }
 562             {
 563                 "bignum>" ( x y -- ? ) "bignum_greater"
 564                 { bignum bignum } { object } make-foldable
 565             }
 566             {
 567                 "bignum>=" ( x y -- ? ) "bignum_greatereq"
 568                 { bignum bignum } { object } make-foldable
 569             }
 570             {
 571                 "bignum>fixnum" ( x -- y ) "bignum_to_fixnum"
 572                 { bignum } { fixnum } make-foldable
 573             }
 574             {
 575                 "bignum>fixnum-strict" ( x -- y ) "bignum_to_fixnum_strict"
 576                 { bignum } { fixnum } make-foldable
 577             }
 578             {
 579                 "fixnum/i" ( x y -- z ) "fixnum_divint"
 580                 { fixnum fixnum } { integer } make-foldable
 581             }
 582             {
 583                 "fixnum>bignum" ( x -- y ) "fixnum_to_bignum"
 584                 { fixnum } { bignum } make-foldable
 585             }
 586             {
 587                 "fixnum>float" ( x -- y ) "fixnum_to_float"
 588                 { fixnum } { float } make-foldable
 589             }
 590             {
 591                 "float*" ( x y -- z ) "float_multiply"
 592                 { float float } { float } make-foldable
 593             }
 594             {
 595                 "float+" ( x y -- z ) "float_add"
 596                 { float float } { float } make-foldable
 597             }
 598             {
 599                 "float-" ( x y -- z ) "float_subtract"
 600                 { float float } { float } make-foldable
 601             }
 602             ! -u ones redundant?
 603             {
 604                 "float-u<" ( x y -- ? ) "float_less"
 605                 { float float } { object } make-foldable
 606             }
 607             {
 608                 "float-u<=" ( x y -- ? ) "float_lesseq"
 609                 { float float } { object } make-foldable
 610             }
 611             {
 612                 "float-u>" ( x y -- ? ) "float_greater"
 613                 { float float } { object } make-foldable
 614             }
 615             {
 616                 "float-u>=" ( x y -- ? ) "float_greatereq"
 617                 { float float } { object } make-foldable
 618             }
 619             {
 620                 "float/f" ( x y -- z ) "float_divfloat"
 621                 { float float } { float } make-foldable
 622             }
 623             {
 624                 "float<" ( x y -- ? ) "float_less"
 625                 { float float } { object } make-foldable
 626             }
 627             {
 628                 "float<=" ( x y -- ? ) "float_lesseq"
 629                 { float float } { object } make-foldable
 630             }
 631             {
 632                 "float=" ( x y -- ? ) "float_eq"
 633                 { float float } { object } make-foldable
 634             }
 635             {
 636                 "float>" ( x y -- ? ) "float_greater"
 637                 { float float } { object } make-foldable
 638             }
 639             {
 640                 "float>=" ( x y -- ? ) "float_greatereq"
 641                 { float float } { object } make-foldable
 642             }
 643             {
 644                 "float>bignum" ( x -- y ) "float_to_bignum"
 645                 { float } { bignum } make-foldable
 646             }
 647             {
 648                 "float>fixnum" ( x -- y ) "float_to_fixnum"
 649                 { float } { fixnum } make-foldable
 650             }
 651         }
 652     }
 653     {
 654         "memory"
 655         {
 656             { "all-instances" ( -- array ) "all_instances" { } { array } f }
 657             { "compact-gc" ( -- ) "compact_gc" { } { } f }
 658             { "gc" ( -- ) "full_gc" { } { } f }
 659             { "minor-gc" ( -- ) "minor_gc" { } { } f }
 660             { "size" ( obj -- n ) "size" { object } { fixnum } make-flushable }
 661         }
 662     }
 663     {
 664         "memory.private"
 665         {
 666             {
 667                 "(save-image)" ( path1 path2 then-die? -- ) "save_image"
 668                 { byte-array byte-array object } { } f
 669             }
 670         }
 671     }
 672     {
 673         "quotations"
 674         {
 675             { "jit-compile" ( quot -- ) "jit_compile" { quotation } { } f }
 676             {
 677                 "quotation-code" ( quot -- start end ) "quotation_code"
 678                 { quotation } { integer integer } make-flushable
 679             }
 680             {
 681                 "quotation-compiled?" ( quot -- ? ) "quotation_compiled_p"
 682                 { quotation } { object } f
 683             }
 684         }
 685     }
 686     {
 687         "quotations.private"
 688         {
 689             {
 690                 "array>quotation" ( array -- quot ) "array_to_quotation"
 691                 { array } { quotation } make-flushable
 692             }
 693         }
 694     }
 695     {
 696         "slots.private"
 697         {
 698             { "set-slot" ( value obj n -- ) "set_slot" { object object fixnum } { } f }
 699             { "slot" ( obj m -- value ) f { object fixnum } { object } make-flushable }
 700         }
 701     }
 702     {
 703         "strings"
 704         {
 705             {
 706                 "<string>" ( n ch -- string ) "string"
 707                 { integer-array-capacity integer } { string } make-flushable
 708             }
 709             {
 710                 "resize-string" ( n str -- newstr ) "resize_string"
 711                 { integer string } { string } f
 712             }
 713         }
 714     }
 715     {
 716         "strings.private"
 717         {
 718             {
 719                 "set-string-nth-fast" ( ch n string -- ) "set_string_nth_fast"
 720                 { fixnum fixnum string } { } f
 721             }
 722             {
 723                 "string-nth-fast" ( n string -- ch ) f
 724                 { fixnum string } { fixnum } make-flushable
 725             }
 726         }
 727     }
 728     {
 729         "system"
 730         {
 731             { "(exit)" ( n -- * ) "exit" { integer } { } f }
 732             { "disable-ctrl-break" ( -- ) "disable_ctrl_break" { } { } f }
 733             { "enable-ctrl-break" ( -- ) "enable_ctrl_break" { } { } f }
 734             { "nano-count" ( -- ns ) "nano_count" { } { integer } make-flushable }
 735         }
 736     }
 737     {
 738         "threads.private"
 739         {
 740             { "(sleep)" ( nanos -- ) "sleep" { integer } { } f }
 741             { "(set-context)" ( obj context -- obj' ) f { object alien } { object } f }
 742             { "(set-context-and-delete)" ( obj context -- * ) f { object alien } { } f }
 743             { "(start-context)" ( obj quot -- obj' ) f { object quotation } { object } f }
 744             { "(start-context-and-delete)" ( obj quot -- * ) f { object quotation } { } f }
 745             {
 746                 "context-object-for" ( n context -- obj ) "context_object_for"
 747                 { fixnum c-ptr } { object } make-flushable
 748             }
 749         }
 750     }
 751     {
 752         "tools.dispatch.private"
 753         {
 754             { "dispatch-stats" ( -- stats ) "dispatch_stats" { } { byte-array } f }
 755             { "reset-dispatch-stats" ( -- ) "reset_dispatch_stats" { } { } f }
 756         }
 757     }
 758     {
 759         "tools.memory.private"
 760         {
 761             {
 762                 "(callback-room)" ( -- allocator-room ) "callback_room"
 763                 { } { byte-array } make-flushable
 764             }
 765             {
 766                 "(code-blocks)" ( -- array ) "code_blocks"
 767                 { } { array } make-flushable
 768             }
 769             {
 770                 "(code-room)" ( -- allocator-room ) "code_room"
 771                 { } { byte-array } make-flushable
 772             }
 773             {
 774                 "(data-room)" ( -- data-room ) "data_room"
 775                 { } { byte-array } make-flushable
 776             }
 777             { "disable-gc-events" ( -- events ) "disable_gc_events" { } { object } f }
 778             { "enable-gc-events" ( -- ) "enable_gc_events" { } { } f }
 779         }
 780     }
 781     {
 782         "tools.profiler.sampling.private"
 783         {
 784             { "set-profiling" ( n -- ) "set_profiling" { object } { } f }
 785             { "get-samples" ( -- samples/f ) "get_samples" { } { object } f }
 786         }
 787     }
 788     {
 789         "words"
 790         {
 791             {
 792                 "word-code" ( word -- start end ) "word_code"
 793                 { word } { integer integer } make-flushable
 794             }
 795             { "word-optimized?" ( word -- ? ) "word_optimized_p" { word } { object } f }
 796         }
 797     }
 798     {
 799         "words.private"
 800         {
 801             {
 802                 "(word)" ( name vocab hashcode -- word ) "word"
 803                 { object object object } { word } make-flushable
 804             }
 805         }
 806     }
 807 }
 808
 809 : primitive-quot ( word vm-func -- quot )
 810     [
 811         nip "primitive_" prepend ascii string>alien [ do-primitive ] curry
 812     ] [ 1quotation ] if* ;
 813
 814 : primitive-word ( name vocab -- word )
 815     create-word dup t "primitive" set-word-prop ;
 816
 817 : set-extra-props ( word extra-props -- )
 818     [ rot set-word-prop ] with assoc-each ;
 819
 820 :: create-primitive ( vocab word effect vm-func inputs outputs extra-word -- )
 821     word vocab primitive-word :> word
 822     word vm-func primitive-quot :> quot
 823     word quot effect define-declared
 824     word inputs "input-classes" set-word-prop
 825     word outputs "default-output-classes" set-word-prop
 826     word extra-word [ execute( x -- ) ] [ drop ] if* ;
 827
 828 : create-primitives ( assoc -- )
 829     [
 830         [ 6 firstn create-primitive ] with each
 831     ] assoc-each ;