lib/setup.c

   1 /* File: "setup.c", Time-stamp: <2009-06-07 19:04:22 feeley> */
   2
   3 /* Copyright (c) 1994-2008 by Marc Feeley, All Rights Reserved. */
   4
   5 /*
   6  * This module contains the routines that setup the Scheme program for
   7  * execution.
   8  */
   9
  10 #define ___INCLUDED_FROM_SETUP
  11 #define ___VERSION 404003
  12 #include "gambit.h"
  13
  14 #include "os_base.h"
  15 #include "os_dyn.h"
  16 #include "setup.h"
  17 #include "mem.h"
  18 #include "c_intf.h"
  19
  20
  21 /*---------------------------------------------------------------------------*/
  22
  23 /*
  24  * Global state structure.
  25  */
  26
  27 ___EXP_DATA(___global_state_struct,___gstate);
  28
  29
  30 /*
  31  * Global variables needed by this module.
  32  */
  33
  34 ___NEED_GLO(___G__23__23_kernel_2d_handlers) /* from "_kernel.scm" */
  35 ___NEED_GLO(___G__23__23_dynamic_2d_env_2d_bind)
  36
  37
  38 /*
  39  * Parameters passed to ___setup.
  40  */
  41
  42 ___HIDDEN ___UCS_2 reset_argv0[] = { 0 };
  43 ___HIDDEN ___UCS_2STRING reset_argv[] = { reset_argv0, 0 };
  44
  45 ___setup_params_struct ___setup_params =
  46 { 0, reset_argv, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 };
  47
  48
  49 /*
  50  * Initial length of symbol table and keyword table.
  51  */
  52
  53 #define INIT_SYMKEY_TBL_LENGTH 128
  54
  55
  56 /*---------------------------------------------------------------------------*/
  57
  58 /*
  59  * Interrupt handling.
  60  */
  61
  62 /*
  63  * '___raise_interrupt (code)' is called when an interrupt has
  64  * occured.  At some later point in time, the Gambit kernel will cause
  65  * the Scheme procedure ##interrupt-handler to be called with a single
  66  * integer argument indicating which interrupt has been received.
  67  * Interrupt codes are defined in "gambit.h".  Currently, the
  68  * following codes are defined:
  69  *
  70  *   ___INTR_USER        user has interrupted the program (e.g. ctrl-C)
  71  *   ___INTR_HEARTBEAT   heartbeat time interval has elapsed
  72  *   ___INTR_GC          a garbage collection has finished
  73  */
  74
  75 ___EXP_FUNC(void,___raise_interrupt)
  76    ___P((int code),
  77         (code)
  78 int code;)
  79 {
  80   ___processor_state ___ps = ___PSTATE;
  81
  82   /*
  83    * Note: ___raise_interrupt may be called before the processor state
  84    * is initialized.  As a consequence, the interrupt(s) received
  85    * before the initialization of the processor state will be ignored.
  86    */
  87
  88 #ifdef CALL_GC_FREQUENTLY
  89   if (code != ___INTR_USER)
  90     return;
  91 #endif
  92
  93   ___ps->intr_flag[code] = 1;
  94   if (___ps->intr_enabled)
  95     ___ps->stack_trip = ___ps->stack_start;
  96 }
  97
  98
  99 ___EXP_FUNC(void,___begin_interrupt_service) ___PVOID
 100 {
 101   ___processor_state ___ps = ___PSTATE;
 102
 103   ___ps->stack_trip = ___ps->stack_limit;
 104 }
 105
 106
 107 ___EXP_FUNC(___BOOL,___check_interrupt)
 108    ___P((int code),
 109         (code)
 110 int code;)
 111 {
 112   ___processor_state ___ps = ___PSTATE;
 113
 114   if (___ps->intr_flag[code])
 115     {
 116       ___ps->intr_flag[code] = 0;
 117       return 1;
 118     }
 119
 120   return 0;
 121 }
 122
 123
 124 ___EXP_FUNC(void,___end_interrupt_service)
 125    ___P((int code),
 126         (code)
 127 int code;)
 128 {
 129   ___processor_state ___ps = ___PSTATE;
 130
 131   if (___ps->intr_enabled)
 132     {
 133 #ifdef CALL_HANDLER_AT_EVERY_POLL
 134       ___ps->stack_trip = ___ps->stack_start;
 135 #else
 136       while (code < ___NB_INTRS)
 137         {
 138           if (___ps->intr_flag[code]) /* don't ignore other interrupts */
 139             {
 140               ___ps->stack_trip = ___ps->stack_start;
 141               break;
 142             }
 143           code++;
 144         }
 145 #endif
 146     }
 147 }
 148
 149
 150 ___EXP_FUNC(void,___disable_interrupts) ___PVOID
 151 {
 152   ___processor_state ___ps = ___PSTATE;
 153
 154   ___ps->intr_enabled = 0;
 155
 156   ___begin_interrupt_service ();
 157   ___end_interrupt_service (0);
 158 }
 159
 160
 161 ___EXP_FUNC(void,___enable_interrupts) ___PVOID
 162 {
 163   ___processor_state ___ps = ___PSTATE;
 164
 165   ___ps->intr_enabled = 1;
 166
 167   ___begin_interrupt_service ();
 168   ___end_interrupt_service (0);
 169 }
 170
 171
 172 /*---------------------------------------------------------------------------*/
 173
 174 /*
 175  * Routines to setup symbol table, keyword table and global variable
 176  * table.
 177  */
 178
 179 /*
 180  * The hashing functions 'hash_UTF_8_string (str)' and
 181  * 'hash_scheme_string (str)' must compute the same value as the
 182  * function 'targ-hash' in the file "gsc/_t-c-3.scm".
 183  * A fixnum error code is returned when there is an error.
 184  */
 185
 186 #define HASH_STEP(h,c) ((((h)>>8) + (c)) * 331804471) & ___MAX_FIX32
 187
 188 ___HIDDEN ___SCMOBJ hash_UTF_8_string
 189    ___P((___UTF_8STRING str),
 190         (str)
 191 ___UTF_8STRING str;)
 192 {
 193   ___UM32 h = 0;
 194   ___UTF_8STRING p = str;
 195   ___UCS_4 c;
 196
 197   for (;;)
 198     {
 199       ___UTF_8STRING start = p;
 200       c = ___UTF_8_get (&p);
 201       if (p == start || c > ___MAX_CHR)
 202         return ___FIX(___CTOS_UTF_8STRING_ERR);
 203       if (c == 0)
 204         break;
 205       h = HASH_STEP(h,c);
 206     }
 207
 208   return ___FIX(h);
 209 }
 210
 211
 212 ___HIDDEN ___SCMOBJ hash_scheme_string
 213    ___P((___SCMOBJ str),
 214         (str)
 215 ___SCMOBJ str;)
 216 {
 217   unsigned long i, n = ___INT(___STRINGLENGTH(str));
 218   ___UM32 h = 0;
 219
 220   for (i=0; i<n; i++)
 221     h = HASH_STEP(h,___INT(___STRINGREF(str,___FIX(i))));
 222
 223   return ___FIX(h);
 224 }
 225
 226
 227 ___HIDDEN ___SCMOBJ symkey_table
 228    ___P((unsigned int subtype),
 229         (subtype)
 230 unsigned int subtype;)
 231 {
 232   switch (subtype)
 233     {
 234     case ___sKEYWORD:
 235       return ___GSTATE->keyword_table;
 236     default: /* assume ___sSYMBOL */
 237       return ___GSTATE->symbol_table;
 238     }
 239 }
 240
 241
 242 ___HIDDEN void symkey_table_set
 243    ___P((unsigned int subtype,
 244          ___SCMOBJ new_table),
 245         (subtype,
 246          new_table)
 247 unsigned int subtype;
 248 ___SCMOBJ new_table;)
 249 {
 250   switch (subtype)
 251     {
 252     case ___sKEYWORD:
 253       ___GSTATE->keyword_table = new_table;
 254       break;
 255     default: /* assume ___sSYMBOL */
 256       ___GSTATE->symbol_table = new_table;
 257       break;
 258     }
 259 }
 260
 261
 262 ___HIDDEN ___SCMOBJ symkey_table_alloc
 263    ___P((unsigned int subtype,
 264          long length),
 265         (subtype,
 266          length)
 267 unsigned int subtype;
 268 long length;)
 269 {
 270   ___SCMOBJ tbl = ___make_vector (length+1, ___NUL, ___STILL);
 271
 272   if (!___FIXNUMP(tbl))
 273     ___FIELD(tbl,0) = ___FIX(0);
 274
 275   return tbl;
 276 }
 277
 278
 279 ___HIDDEN void symkey_add
 280    ___P((___SCMOBJ symkey),
 281         (symkey)
 282 ___SCMOBJ symkey;)
 283 {
 284   unsigned int subtype = ___INT(___SUBTYPE(symkey));
 285   ___SCMOBJ tbl = symkey_table (subtype);
 286   int i = ___INT(___FIELD(symkey,___SYMKEY_HASH))
 287           % (___INT(___VECTORLENGTH(tbl)) - 1)
 288           + 1;
 289
 290   ___FIELD(symkey,___SYMKEY_NEXT) = ___FIELD(tbl,i);
 291   ___FIELD(tbl,i) = symkey;
 292
 293   ___FIELD(tbl,0) = ___FIXADD(___FIELD(tbl,0),___FIX(1));
 294
 295   if (___INT(___FIELD(tbl,0)) > ___INT(___VECTORLENGTH(tbl)) * 4)
 296     {
 297       int new_len = (___INT(___VECTORLENGTH(tbl))-1) * 2;
 298       ___SCMOBJ new_tbl = symkey_table_alloc (subtype, new_len);
 299
 300       if (!___FIXNUMP(new_tbl))
 301         {
 302           for (i=___INT(___VECTORLENGTH(tbl))-1; i>0; i--)
 303             {
 304               ___SCMOBJ probe = ___FIELD(tbl,i);
 305
 306               while (probe != ___NUL)
 307                 {
 308                   ___SCMOBJ symkey = probe;
 309                   int j = ___INT(___FIELD(symkey,___SYMKEY_HASH))%new_len + 1;
 310
 311                   probe = ___FIELD(symkey,___SYMKEY_NEXT);
 312                   ___FIELD(symkey,___SYMKEY_NEXT) = ___FIELD(new_tbl,j);
 313                   ___FIELD(new_tbl,j) = symkey;
 314                 }
 315             }
 316
 317           ___FIELD(new_tbl,0) = ___FIELD(tbl,0);
 318
 319           symkey_table_set (subtype, new_tbl);
 320         }
 321     }
 322 }
 323
 324
 325 ___HIDDEN ___SCMOBJ find_symkey_from_UTF_8_string
 326    ___P((char *str,
 327          unsigned int subtype),
 328         (str,
 329          subtype)
 330 char *str;
 331 unsigned int subtype;)
 332 {
 333   ___SCMOBJ tbl;
 334   ___SCMOBJ probe;
 335   ___SCMOBJ h = hash_UTF_8_string (str);
 336
 337   if (h < ___FIX(0))
 338     return h;
 339
 340   tbl = symkey_table (subtype);
 341   probe = ___FIELD(tbl, ___INT(h) % (___INT(___VECTORLENGTH(tbl))-1) + 1);
 342
 343   while (probe != ___NUL)
 344     {
 345       ___SCMOBJ name = ___FIELD(probe,___SYMKEY_NAME);
 346       unsigned long i;
 347       unsigned long n = ___INT(___STRINGLENGTH(name));
 348       ___UTF_8STRING p = str;
 349       for (i=0; i<n; i++)
 350         if (___UTF_8_get (&p) !=
 351             ___CAST(___UCS_4,___INT(___STRINGREF(name,___FIX(i)))))
 352           goto next;
 353       if (___UTF_8_get (&p) == 0)
 354         return probe;
 355     next:
 356       probe = ___FIELD(probe,___SYMKEY_NEXT);
 357     }
 358
 359   return ___FAL;
 360 }
 361
 362
 363 ___SCMOBJ ___find_symkey_from_scheme_string
 364    ___P((___SCMOBJ str,
 365          unsigned int subtype),
 366         (str,
 367          subtype)
 368 ___SCMOBJ str;
 369 unsigned int subtype;)
 370 {
 371   ___SCMOBJ tbl;
 372   ___SCMOBJ probe;
 373   ___SCMOBJ h = hash_scheme_string (str);
 374
 375   tbl = symkey_table (subtype);
 376   probe = ___FIELD(tbl, ___INT(h) % (___INT(___VECTORLENGTH(tbl))-1) + 1);
 377
 378   while (probe != ___NUL)
 379     {
 380       ___SCMOBJ name = ___FIELD(probe,___SYMKEY_NAME);
 381       long i = 0;
 382       long n = ___INT(___STRINGLENGTH(name));
 383       if (___INT(___STRINGLENGTH(str)) == n)
 384         {
 385           for (i=0; i<n; i++)
 386             if (___STRINGREF(str,___FIX(i)) != ___STRINGREF(name,___FIX(i)))
 387               goto next;
 388           return probe;
 389         }
 390     next:
 391       probe = ___FIELD(probe,___SYMKEY_NEXT);
 392     }
 393
 394   return ___FAL;
 395 }
 396
 397
 398 ___SCMOBJ ___new_symkey
 399    ___P((___SCMOBJ name, /* name must be a permanent object */
 400          unsigned int subtype),
 401         (name,
 402          subtype)
 403 ___SCMOBJ name;
 404 unsigned int subtype;)
 405 {
 406   ___SCMOBJ obj;
 407   ___SCMOBJ tbl;
 408
 409   switch (subtype)
 410     {
 411     case ___sKEYWORD:
 412       obj = ___alloc_scmobj (___sKEYWORD, ___KEYWORD_SIZE<<___LWS, ___PERM);
 413       break;
 414     default: /* assume ___sSYMBOL */
 415       obj = ___alloc_scmobj (___sSYMBOL, ___SYMBOL_SIZE<<___LWS, ___PERM);
 416       break;
 417     }
 418
 419   if (___FIXNUMP(obj))
 420     return obj;
 421
 422   tbl = symkey_table (subtype);
 423
 424   /* object layout is same for ___sSYMBOL and ___sKEYWORD */
 425
 426   ___FIELD(obj,___SYMKEY_NAME) = name;
 427   ___FIELD(obj,___SYMKEY_HASH) = hash_scheme_string (name);
 428
 429   if (subtype == ___sSYMBOL)
 430     ___FIELD(obj,___SYMBOL_GLOBAL) = 0;
 431
 432   symkey_add (obj);
 433
 434   return obj;
 435 }
 436
 437
 438 ___HIDDEN ___SCMOBJ make_symkey
 439    ___P((___UTF_8STRING str,
 440          unsigned int subtype),
 441         (str,
 442          subtype)
 443 ___UTF_8STRING str;
 444 unsigned int subtype;)
 445 {
 446   ___SCMOBJ obj = find_symkey_from_UTF_8_string (str, subtype);
 447
 448   if (___FIXNUMP(obj))
 449     return obj;
 450
 451   if (obj == ___FAL)
 452     {
 453       ___SCMOBJ name;
 454       ___SCMOBJ err;
 455
 456       if ((err = ___NONNULLUTF_8STRING_to_SCMOBJ (str, &name, 0))
 457           != ___FIX(___NO_ERR))
 458         return err;
 459
 460       obj = ___new_symkey (name, subtype);
 461     }
 462
 463   return obj;
 464 }
 465
 466
 467 ___HIDDEN ___SCMOBJ make_global
 468    ___P((___UTF_8STRING str,
 469          int supply,
 470          ___glo_struct **glo),
 471         (str,
 472          supply,
 473          glo)
 474 ___UTF_8STRING str;
 475 int supply;
 476 ___glo_struct **glo;)
 477 {
 478   ___SCMOBJ sym;
 479   ___SCMOBJ g;
 480   ___glo_struct *p;
 481
 482   sym = make_symkey (str, ___sSYMBOL);
 483
 484   if (___FIXNUMP(sym))
 485     return sym;
 486
 487   g = ___FIELD(sym,___SYMBOL_GLOBAL);
 488
 489   if (g == ___FIX(0))
 490     {
 491       ___processor_state ___ps = ___PSTATE;
 492       ___SCMOBJ e;
 493       if ((e = ___alloc_global_var (&p)) != ___FIX(___NO_ERR))
 494         return e;
 495       p->val = supply?___UNB2:___UNB1;
 496       p->prm = ___FAL;
 497       p->next = 0;
 498       if (___ps->glo_list_head == 0)
 499         ___ps->glo_list_head = ___CAST(___SCMOBJ,p);
 500       else
 501         ___CAST(___glo_struct*,___ps->glo_list_tail)->next =
 502           ___CAST(___SCMOBJ,p);
 503       ___ps->glo_list_tail = ___CAST(___SCMOBJ,p);
 504       ___FIELD(sym,___SYMBOL_GLOBAL) = ___CAST(___SCMOBJ,p);
 505     }
 506   else
 507     {
 508       p = ___CAST(___glo_struct*,g);
 509       if (supply && p->val == ___UNB1)
 510         p->val = ___UNB2;
 511     }
 512
 513   *glo = p;
 514
 515   return ___FIX(___NO_ERR);
 516 }
 517
 518
 519 void ___for_each_symkey
 520    ___P((unsigned int subtype,
 521          void (*visit) (___SCMOBJ symkey, void *data),
 522          void *data),
 523         (subtype,
 524          visit,
 525          data)
 526 unsigned int subtype;
 527 void (*visit) ();
 528 void *data;)
 529 {
 530   ___SCMOBJ tbl = symkey_table (subtype);
 531   int i;
 532
 533   for (i=___INT(___VECTORLENGTH(tbl))-1; i>0; i--)
 534     {
 535       ___SCMOBJ probe = ___FIELD(tbl, i);
 536
 537       while (probe != ___NUL)
 538         {
 539           visit (probe, data);
 540           probe = ___FIELD(probe,___SYMKEY_NEXT);
 541         }
 542     }
 543 }
 544
 545
 546 /*---------------------------------------------------------------------------*/
 547
 548 /*
 549  * Alignment of objects.
 550  */
 551
 552 ___HIDDEN ___SCMOBJ *align
 553    ___P((___SCMOBJ *from,
 554          long words,
 555          int need_64bit_alignment),
 556         (from,
 557          words,
 558          need_64bit_alignment)
 559 ___SCMOBJ *from;
 560 long words;
 561 int need_64bit_alignment;)
 562 {
 563   ___SCMOBJ *to;
 564
 565 #if ___WS == 4
 566   if (need_64bit_alignment)
 567     to = ___ALIGNUP((from+1), 8) - 1;
 568   else
 569 #endif
 570     to = ___ALIGNUP(from, ___WS);
 571
 572   if (from != to)
 573     {
 574       /* move object up */
 575       int i;
 576       for (i=words-1; i>=0; i--)
 577         to[i] = from[i];
 578     }
 579
 580   return to;
 581 }
 582
 583
 584 ___HIDDEN ___SCMOBJ align_subtyped
 585    ___P((___SCMOBJ *ptr),
 586         (ptr)
 587 ___SCMOBJ *ptr;)
 588 {
 589   ___SCMOBJ head = ptr[0];
 590   int subtype = ___HD_SUBTYPE(head);
 591   int words = ___HD_WORDS(head);
 592   return ___TAG(align (ptr, words+1, subtype>=___sS64VECTOR), ___tSUBTYPED);
 593 }
 594
 595
 596 /*---------------------------------------------------------------------------*/
 597
 598 /*
 599  * Routines to setup a module for execution.
 600  */
 601
 602 ___HIDDEN ___mod_or_lnk linker_to_mod_or_lnk
 603    ___P((___mod_or_lnk (*linker) (___global_state_struct*)),
 604         (linker)
 605 ___mod_or_lnk (*linker) ();)
 606 {
 607   ___mod_or_lnk mol = linker (&___gstate);
 608   if (mol->module.kind == ___LINKFILE_KIND)
 609     {
 610       void **p = mol->linkfile.linker_tbl;
 611       while (*p != 0)
 612         {
 613           *p = linker_to_mod_or_lnk
 614                  (*___CAST(___mod_or_lnk (**) ___P((___global_state_struct*),()),p));
 615           p++;
 616         }
 617     }
 618   return mol;
 619 }
 620
 621
 622 ___HIDDEN ___SCMOBJ for_each_module
 623    ___P((___mod_or_lnk mol,
 624          ___SCMOBJ (*proc) (___module_struct*)),
 625         (mol,
 626          proc)
 627 ___mod_or_lnk mol;
 628 ___SCMOBJ (*proc) ();)
 629 {
 630   if (mol->module.kind == ___LINKFILE_KIND)
 631     {
 632       void **p = mol->linkfile.linker_tbl;
 633       while (*p != 0)
 634         {
 635           ___SCMOBJ e = for_each_module (___CAST(___mod_or_lnk,*p++), proc);
 636           if (e != ___FIX(___NO_ERR))
 637             return e;
 638         }
 639       return ___FIX(___NO_ERR);
 640     }
 641   else
 642     return proc (___CAST(___module_struct*,mol));
 643 }
 644
 645
 646 ___HIDDEN void fixref
 647    ___P((___SCMOBJ *p,
 648          ___SCMOBJ *sym_tbl,
 649          ___SCMOBJ *key_tbl,
 650          ___SCMOBJ *cns_tbl,
 651          ___SCMOBJ *sub_tbl),
 652         (p,
 653          sym_tbl,
 654          key_tbl,
 655          cns_tbl,
 656          sub_tbl)
 657 ___SCMOBJ *p;
 658 ___SCMOBJ *sym_tbl;
 659 ___SCMOBJ *key_tbl;
 660 ___SCMOBJ *cns_tbl;
 661 ___SCMOBJ *sub_tbl;)
 662 {
 663   ___SCMOBJ v = *p;
 664   switch (___TYP(v))
 665     {
 666     case ___tPAIR:
 667       if (___INT(v)<0)
 668         *p = sym_tbl[-1-___INT(v)];
 669       else
 670         *p = ___TAG(___ALIGNUP(&cns_tbl[(___PAIR_SIZE+1)*___INT(v)],___WS),
 671                     ___tPAIR);
 672       break;
 673
 674     case ___tSUBTYPED:
 675       if (___INT(v)<0)
 676         *p = key_tbl[-1-___INT(v)];
 677       else
 678         *p = sub_tbl[___INT(v)];
 679       break;
 680     }
 681 }
 682
 683
 684 ___HIDDEN int module_count;
 685 ___HIDDEN ___SCMOBJ module_descr;
 686
 687
 688 ___HIDDEN ___SCMOBJ setup_module_phase1
 689    ___P((___module_struct *module),
 690         (module)
 691 ___module_struct *module;)
 692 {
 693   int i, j;
 694   ___SCMOBJ *cns = 0;
 695
 696   int flags                 = module->flags;
 697   ___FAKEWORD *glo_tbl      = module->glo_tbl;
 698   int sup_count             = module->sup_count;
 699   ___UTF_8STRING *glo_names = module->glo_names;
 700   ___SCMOBJ *sym_tbl        = ___CAST(___SCMOBJ*,module->sym_tbl);
 701   int sym_count             = module->sym_count;
 702   ___UTF_8STRING *sym_names = module->sym_names;
 703   ___SCMOBJ *key_tbl        = ___CAST(___SCMOBJ*,module->key_tbl);
 704   int key_count             = module->key_count;
 705   ___UTF_8STRING *key_names = module->key_names;
 706   ___SCMOBJ *lp             = module->lp;
 707   ___SCMOBJ *lbl_tbl        = ___CAST(___SCMOBJ*,module->lbl_tbl);
 708   int lbl_count             = module->lbl_count;
 709   ___SCMOBJ *ofd_tbl        = module->ofd_tbl;
 710   int ofd_length            = module->ofd_length;
 711   ___SCMOBJ *cns_tbl        = module->cns_tbl;
 712   int cns_count             = module->cns_count;
 713   ___SCMOBJ *sub_tbl        = ___CAST(___SCMOBJ*,module->sub_tbl);
 714   int sub_count             = module->sub_count;
 715
 716   /*
 717    * Check that the version of the compiler used to compile the module
 718    * is compatible with the compiler used to compile the runtime
 719    * system.
 720    */
 721
 722   if (module->version / 10000 < ___VERSION / 10000)
 723     return ___FIX(___MODULE_VERSION_TOO_OLD_ERR);
 724
 725   if (module->version / 10000 > ___VERSION / 10000)
 726     return ___FIX(___MODULE_VERSION_TOO_NEW_ERR);
 727
 728   /* Align module's pair table */
 729
 730   if (cns_tbl != 0)
 731     cns = align (cns_tbl, (___PAIR_SIZE+1)*cns_count, 0);
 732
 733   /* Setup module's global variable table */
 734
 735   if (glo_names != 0)
 736     {
 737       /*
 738        * Create global variables in reverse order so that global
 739        * variables bound to c-lambdas are created last.
 740        */
 741       i = 0;
 742       while (glo_names[i] != 0)
 743         i++;
 744       while (i-- > 0)
 745         {
 746           ___glo_struct *glo = 0;
 747           ___SCMOBJ e = make_global (glo_names[i], i<sup_count, &glo);
 748           if (e != ___FIX(___NO_ERR))
 749             return e;
 750           glo_tbl[i] = ___CAST(___FAKEWORD,glo);
 751         }
 752     }
 753
 754   /* Setup module's symbol table */
 755
 756   if (sym_names != 0)
 757     {
 758       i = 0;
 759       while (sym_names[i] != 0)
 760         {
 761           ___SCMOBJ sym = make_symkey (sym_names[i], ___sSYMBOL);
 762           if (___FIXNUMP(sym))
 763             return sym;
 764           sym_tbl[i] = sym;
 765           i++;
 766         }
 767     }
 768   else
 769     for (i=sym_count-1; i>=0; i--)
 770       sym_tbl[i] = ___TAG(___ALIGNUP(sym_tbl[i], ___WS), ___tSUBTYPED);
 771
 772   /* Setup module's keyword table */
 773
 774   if (key_names != 0)
 775     {
 776       i = 0;
 777       while (key_names[i] != 0)
 778         {
 779           ___SCMOBJ key = make_symkey (key_names[i], ___sKEYWORD);
 780           if (___FIXNUMP(key))
 781             return key;
 782           key_tbl[i] = key;
 783           i++;
 784         }
 785     }
 786   else
 787     for (i=key_count-1; i>=0; i--)
 788       key_tbl[i] = ___TAG(___ALIGNUP(key_tbl[i], ___WS), ___tSUBTYPED);
 789
 790   /* Setup module's subtyped object table */
 791
 792   for (i=sub_count-1; i>=0; i--)
 793     sub_tbl[i] = align_subtyped (___CAST(___SCMOBJ*,sub_tbl[i]));
 794
 795   /* Fix references in module's pair table */
 796
 797   for (i=cns_count-1; i>=0; i--)
 798   {
 799     fixref (cns+i*(___PAIR_SIZE+1)+1, sym_tbl, key_tbl, cns_tbl, sub_tbl);
 800     fixref (cns+i*(___PAIR_SIZE+1)+2, sym_tbl, key_tbl, cns_tbl, sub_tbl);
 801   }
 802
 803   /* Fix references in module's subtyped object table */
 804
 805   for (j=sub_count-1; j>=0; j--)
 806     {
 807       ___SCMOBJ *p = ___UNTAG_AS(sub_tbl[j],___tSUBTYPED);
 808       ___SCMOBJ head = p[0];
 809       int subtype = ___HD_SUBTYPE(head);
 810       int words = ___HD_WORDS(head);
 811       switch (subtype)
 812         {
 813         case ___sSYMBOL:
 814         case ___sKEYWORD:
 815         case ___sVECTOR:
 816         case ___sSTRUCTURE:
 817         case ___sRATNUM:
 818         case ___sCPXNUM:
 819           for (i=1; i<=words; i++)
 820             fixref (p+i, sym_tbl, key_tbl, cns_tbl, sub_tbl);
 821         }
 822     }
 823
 824   /* Align module's out-of-line frame descriptor table */
 825
 826   if (ofd_tbl != 0)
 827     ofd_tbl = ___CAST(___SCMOBJ*,align (ofd_tbl, ofd_length, 0));
 828
 829   /* Align module's label table */
 830
 831   if (lbl_count > 0)
 832     {
 833       ___host current_host = 0;
 834       void **hlbl_ptr = 0;
 835       ___label_struct *new_lt;
 836       ___SCMOBJ *ofd_alloc;
 837
 838       module_count++;
 839
 840       new_lt = ___CAST(___label_struct*,align (lbl_tbl, lbl_count*___LS, 0));
 841       ofd_alloc = ofd_tbl;
 842
 843       for (i=0; i<lbl_count; i++)
 844         {
 845           ___label_struct *lbl = &new_lt[i];
 846           ___SCMOBJ head = lbl->header;
 847
 848           if (___TESTHEADERTAG(head,___sVECTOR))
 849             {
 850               ___UTF_8STRING name =
 851                 ___CAST(___UTF_8STRING,
 852                         ___CAST_FAKEVOIDSTAR_TO_VOIDSTAR(lbl->host_label));
 853
 854               if (name == 0)
 855                 lbl->host_label = ___CAST(___FAKEVOIDSTAR,___FAL);
 856               else
 857                 {
 858                   ___SCMOBJ sym =
 859                     find_symkey_from_UTF_8_string (name, ___sSYMBOL);
 860
 861                   if (___FIXNUMP(sym))
 862                     return sym;
 863
 864                   if (sym == ___FAL)
 865                     return ___FIX(___UNKNOWN_ERR);
 866
 867                   lbl->host_label = ___CAST(___FAKEVOIDSTAR,sym);
 868                 }
 869
 870               fixref (&lbl->entry_or_descr, sym_tbl, key_tbl, cns_tbl, sub_tbl);
 871
 872               if (hlbl_ptr != 0)
 873                 hlbl_ptr++; /* skip INTRO label */
 874             }
 875           else
 876             {
 877               if (flags & 1) /* module uses gcc's computed goto? */
 878                 {
 879                   if (___CAST_FAKEHOST_TO_HOST(lbl->host) != current_host)
 880                     {
 881                       current_host = ___CAST_FAKEHOST_TO_HOST(lbl->host);
 882                       hlbl_ptr = ___CAST(void**,current_host (0));
 883                       hlbl_ptr++; /* skip INTRO label */
 884                     }
 885                   lbl->host_label = ___CAST_VOIDSTAR_TO_FAKEVOIDSTAR(*hlbl_ptr++);
 886                 }
 887               if (head == ___MAKE_HD((3<<___LWS),___sRETURN,___PERM))
 888                 {
 889                   ___SCMOBJ descr;
 890                   descr = lbl->entry_or_descr;
 891                   if (___IFD_GCMAP(descr) == 0) /* out-of-line descriptor? */
 892                     {
 893                       int fs;
 894                       lbl->entry_or_descr = ___CAST(___SCMOBJ,ofd_alloc);
 895                       fs = ___OFD_FS(*ofd_alloc);
 896                       if (___IFD_KIND(descr) == ___RETI)
 897                         fs = ___RETI_CFS_TO_FS(fs);
 898                       ofd_alloc += 1 + ___CEILING_DIV(fs,___WORD_WIDTH);
 899                     }
 900                 }
 901               else
 902                 lbl->entry_or_descr = ___TAG(&lbl->header,___tSUBTYPED);
 903             }
 904         }
 905       *lp = ___TAG(new_lt,___tSUBTYPED);
 906     }
 907
 908   return ___FIX(___NO_ERR);
 909 }
 910
 911
 912 ___HIDDEN char module_prefix[] = ___MODULE_PREFIX;
 913
 914 #define module_prefix_length (sizeof(module_prefix)-1)
 915
 916
 917 ___HIDDEN ___SCMOBJ setup_module_phase2
 918    ___P((___module_struct *module),
 919         (module)
 920 ___module_struct *module;)
 921 {
 922   ___UTF_8STRING *glo_names = module->glo_names;
 923
 924   if (glo_names != 0)
 925     {
 926       ___UTF_8STRING name = module->name;
 927       ___FAKEWORD *glo_tbl = module->glo_tbl;
 928       int glo_count = module->glo_count;
 929       int sup_count = module->sup_count;
 930       int i;
 931       for (i=sup_count; i<glo_count; i++)
 932         {
 933           /*
 934            * If the global variable is undefined, add it to the list
 935            * of undefined variables in the module descriptor.
 936            */
 937
 938           ___glo_struct *glo = ___CAST(___glo_struct*,glo_tbl[i]);
 939
 940           if (glo->val == ___UNB1)
 941             {
 942               ___SCMOBJ err;
 943               ___SCMOBJ glo_name;
 944               ___SCMOBJ module_name;
 945               ___SCMOBJ pair1;
 946               ___SCMOBJ pair2;
 947
 948               if ((err = ___NONNULLUTF_8STRING_to_SCMOBJ
 949                            (glo_names[i],
 950                             &glo_name,
 951                             0))
 952                   != ___FIX(___NO_ERR))
 953                 return err;
 954
 955               if ((err = ___NONNULLUTF_8STRING_to_SCMOBJ
 956                            (name+module_prefix_length,
 957                             &module_name,
 958                             0))
 959                   != ___FIX(___NO_ERR))
 960                 {
 961                   ___release_scmobj (glo_name);
 962                   return ___FIX(err);
 963                 }
 964
 965               pair1 = ___make_pair (glo_name, module_name, ___STILL);
 966
 967               ___release_scmobj (glo_name);
 968               ___release_scmobj (module_name);
 969
 970               if (___FIXNUMP(pair1))
 971                 return pair1;
 972
 973               pair2 = ___make_pair (pair1, ___FIELD(module_descr,1), ___STILL);
 974
 975               ___release_scmobj (pair1);
 976
 977               if (___FIXNUMP(pair2))
 978                 return pair2;
 979
 980               ___FIELD(module_descr,1) = pair2;
 981
 982               ___release_scmobj (pair2);
 983             }
 984         }
 985     }
 986
 987   return ___FIX(___NO_ERR);
 988 }
 989
 990
 991 ___HIDDEN ___SCMOBJ setup_module_phase3
 992    ___P((___module_struct *module),
 993         (module)
 994 ___module_struct *module;)
 995 {
 996   if (module->lbl_count > 0)
 997     {
 998       ___FIELD(___FIELD(module_descr,0),module_count) =
 999         *module->lp+___LS*___WS;
1000       module_count++;
1001     }
1002   return module->init_proc ();
1003 }
1004
1005
1006 ___HIDDEN ___UTF_8STRING module_script_line;
1007
1008
1009 ___HIDDEN ___SCMOBJ get_script_line_proc
1010    ___P((___module_struct *module),
1011         (module)
1012 ___module_struct *module;)
1013 {
1014   if (module->script_line != 0)
1015     module_script_line = module->script_line;
1016   return ___FIX(___NO_ERR);
1017 }
1018
1019
1020 ___HIDDEN ___UTF_8STRING get_script_line
1021    ___P((___mod_or_lnk mol),
1022         (mol)
1023 ___mod_or_lnk mol;)
1024 {
1025   module_script_line = 0;
1026
1027   if (for_each_module (mol, get_script_line_proc) == ___FIX(___NO_ERR))
1028     return module_script_line;
1029
1030   return 0;
1031 }
1032
1033
1034 ___HIDDEN ___SCMOBJ setup_modules
1035    ___P((___mod_or_lnk mol),
1036         (mol)
1037 ___mod_or_lnk mol;)
1038 {
1039   ___SCMOBJ result;
1040
1041   result = ___make_vector (3, ___NUL, ___STILL);
1042
1043   if (!___FIXNUMP(result))
1044     {
1045       module_count = 0;
1046       module_descr = result;
1047
1048       if ((result = for_each_module (mol, setup_module_phase1))
1049           == ___FIX(___NO_ERR))
1050         {
1051           if ((result = for_each_module (mol, setup_module_phase2))
1052               == ___FIX(___NO_ERR))
1053             {
1054               result = ___make_vector (module_count, ___FAL, ___STILL);
1055
1056               if (!___FIXNUMP(result))
1057                 {
1058                   ___FIELD(module_descr,0) = result;
1059                   ___release_scmobj (result);
1060
1061                   module_count = 0;
1062
1063                   if ((result = for_each_module (mol, setup_module_phase3))
1064                       == ___FIX(___NO_ERR))
1065                     {
1066                       ___SCMOBJ script_line;
1067
1068                       if ((result = ___UTF_8STRING_to_SCMOBJ
1069                                       (get_script_line (mol),
1070                                        &script_line,
1071                                        0))
1072                           == ___FIX(___NO_ERR))
1073                         {
1074                           ___FIELD(module_descr,2) = script_line;
1075                           ___release_scmobj (script_line);
1076                           result = module_descr;
1077                         }
1078                     }
1079                 }
1080             }
1081         }
1082
1083       if (___FIXNUMP(result))
1084         ___release_scmobj (module_descr);
1085     }
1086
1087   return result;
1088 }
1089
1090
1091 ___SCMOBJ ___os_load_object_file
1092    ___P((___SCMOBJ path,
1093          ___SCMOBJ modname),
1094         (path,
1095          modname)
1096 ___SCMOBJ path;
1097 ___SCMOBJ modname;)
1098 {
1099   ___SCMOBJ result;
1100   void *linker;
1101   ___mod_or_lnk mol;
1102
1103   if ((result = ___dynamic_load (path, modname, &linker)) == ___FIX(___NO_ERR))
1104     {
1105       mol = linker_to_mod_or_lnk
1106               (___CAST(___mod_or_lnk (*) ___P((___global_state_struct*),()),
1107                        linker));
1108
1109       if (mol->linkfile.version < 0) /* was it already setup? */
1110         result = ___FIX(___MODULE_ALREADY_LOADED_ERR);
1111       else
1112         {
1113           result = setup_modules (mol);
1114           mol->linkfile.version = -1; /* mark link file as 'setup' */
1115         }
1116     }
1117
1118   ___release_scmobj (result);
1119
1120   return result;
1121 }
1122
1123
1124 /*---------------------------------------------------------------------------*/
1125
1126 /*
1127  * Character operations.
1128  */
1129
1130
1131 ___EXP_FUNC(___BOOL,___iswalpha)
1132    ___P((___UCS_4 x),
1133         (x)
1134 ___UCS_4 x;)
1135 {
1136 #ifdef USE_wctype
1137
1138   return iswalpha (x);
1139
1140 #else
1141
1142   return (x >= 97 && x <= 122) || (x >= 65 && x <= 90);
1143
1144 #endif
1145 }
1146
1147
1148 ___EXP_FUNC(___BOOL,___iswdigit)
1149    ___P((___UCS_4 x),
1150         (x)
1151 ___UCS_4 x;)
1152 {
1153 #ifdef USE_wctype
1154
1155   return iswdigit (x);
1156
1157 #else
1158
1159   return x>= 48 && x <= 57;
1160
1161 #endif
1162 }
1163
1164
1165 ___EXP_FUNC(___BOOL,___iswspace)
1166    ___P((___UCS_4 x),
1167         (x)
1168 ___UCS_4 x;)
1169 {
1170 #ifdef USE_wctype
1171
1172   return iswspace (x);
1173
1174 #else
1175
1176   return (x >= 9 && x <= 13) || (x == 32);
1177
1178 #endif
1179 }
1180
1181
1182 ___EXP_FUNC(___BOOL,___iswupper)
1183    ___P((___UCS_4 x),
1184         (x)
1185 ___UCS_4 x;)
1186 {
1187 #ifdef USE_wctype
1188
1189   return iswupper (x);
1190
1191 #else
1192
1193   return x >= 65 && x <= 90;
1194
1195 #endif
1196 }
1197
1198
1199 ___EXP_FUNC(___BOOL,___iswlower)
1200    ___P((___UCS_4 x),
1201         (x)
1202 ___UCS_4 x;)
1203 {
1204 #ifdef USE_wctype
1205
1206   return iswlower (x);
1207
1208 #else
1209
1210   return x >= 97 && x <= 122;
1211
1212 #endif
1213 }
1214
1215
1216 ___EXP_FUNC(___UCS_4,___towupper)
1217    ___P((___UCS_4 x),
1218         (x)
1219 ___UCS_4 x;)
1220 {
1221 #ifdef USE_wctype
1222
1223   return towupper (x);
1224
1225 #else
1226
1227   return (x >= 97 && x <= 122) ? x-32 : x;
1228
1229 #endif
1230 }
1231
1232
1233 ___EXP_FUNC(___UCS_4,___towlower)
1234    ___P((___UCS_4 x),
1235         (x)
1236 ___UCS_4 x;)
1237 {
1238 #ifdef USE_wctype
1239
1240   return towlower (x);
1241
1242 #else
1243
1244   return (x >= 65 && x <= 90) ? x+32 : x;
1245
1246 #endif
1247 }
1248
1249
1250 #define STRING_COLLATE_BUF_LENGTH 1000
1251
1252
1253 ___EXP_FUNC(___SCMOBJ,___string_collate)
1254    ___P((___SCMOBJ str1,
1255          ___SCMOBJ str2),
1256         (str1,
1257          str2)
1258 ___SCMOBJ str1;
1259 ___SCMOBJ str2;)
1260 {
1261   int len1 = ___INT(___STRINGLENGTH(str1));
1262   int len2 = ___INT(___STRINGLENGTH(str2));
1263
1264 #ifdef USE_wchar
1265
1266   wchar_t buf[STRING_COLLATE_BUF_LENGTH];
1267   wchar_t *b1;
1268   wchar_t *b2;
1269   wchar_t *s1;
1270   wchar_t *s2;
1271   wchar_t *p;
1272   int i;
1273   int result;
1274
1275   if (len1 + len2 + 2 > STRING_COLLATE_BUF_LENGTH)
1276     {
1277       b1 = ___CAST(wchar_t*,___alloc_mem (len1 + 1));
1278
1279       if (b1 == 0)
1280         return ___FIX(___HEAP_OVERFLOW_ERR);
1281
1282       p = b1;
1283
1284       for (i=0; i<len1; i++)
1285         *p++ = ___INT(___STRINGREF(str1,___FIX(i)));
1286
1287       *p = '\0';
1288
1289       b2 = ___CAST(wchar_t*,___alloc_mem (len1 + 1));
1290
1291       if (b2 == 0)
1292         {
1293           ___free_mem (b1);
1294           return ___FIX(___HEAP_OVERFLOW_ERR);
1295         }
1296
1297       p = b2;
1298
1299       for (i=0; i<len2; i++)
1300         *p++ = ___INT(___STRINGREF(str2,___FIX(i)));
1301
1302       *p = '\0';
1303     }
1304   else
1305     {
1306       p = buf;
1307
1308       b1 = p;
1309
1310       for (i=0; i<len1; i++)
1311         *p++ = ___INT(___STRINGREF(str1,___FIX(i)));
1312
1313       *p++ = '\0';
1314
1315       b2 = p;
1316
1317       for (i=0; i<len2; i++)
1318         *p++ = ___INT(___STRINGREF(str2,___FIX(i)));
1319
1320       *p++ = '\0';
1321     }
1322
1323   result = 0;
1324   s1 = b1;
1325   s2 = b2;
1326
1327   while (len1 > 0 && len2 > 0 && result == 0)
1328     {
1329       int l1;
1330       int l2;
1331
1332       result = wcscoll (s1, s2);
1333
1334       l1 = wcslen (s1) + 1;
1335       l2 = wcslen (s2) + 1;
1336
1337       s1 += l1;
1338       s2 += l2;
1339
1340       len1 -= l1;
1341       len2 -= l2;
1342     }
1343
1344   if (len1 + len2 + 2 > STRING_COLLATE_BUF_LENGTH)
1345     {
1346       ___free_mem (b1);
1347       ___free_mem (b2);
1348     }
1349
1350   if (result < 0)
1351     return ___FIX(0);
1352
1353   if (result > 0)
1354     return ___FIX(2);
1355
1356   if (len1 < len2)
1357     return ___FIX(0);
1358
1359   if (len1 > len2)
1360     return ___FIX(2);
1361
1362   return ___FIX(1);
1363
1364 #else
1365
1366   int n;
1367   int i;
1368
1369   n = len1;
1370   if (len2 < n)
1371     n = len2;
1372
1373   for (i=0; i<n; i++)
1374     {
1375       ___SCMOBJ c1 = ___STRINGREF(str1,___FIX(i));
1376       ___SCMOBJ c2 = ___STRINGREF(str2,___FIX(i));
1377
1378       if (___CHARLTP(c1,c2))
1379         return ___FIX(0);
1380
1381       if (___CHARGTP(c1,c2))
1382         return ___FIX(2);
1383     }
1384
1385   if (len1 < len2)
1386     return ___FIX(0);
1387
1388   if (len1 > len2)
1389     return ___FIX(2);
1390
1391   return ___FIX(1);
1392
1393 #endif
1394 }
1395
1396
1397 ___EXP_FUNC(___SCMOBJ,___string_collate_ci)
1398    ___P((___SCMOBJ str1,
1399          ___SCMOBJ str2),
1400         (str1,
1401          str2)
1402 ___SCMOBJ str1;
1403 ___SCMOBJ str2;)
1404 {
1405   int len1 = ___INT(___STRINGLENGTH(str1));
1406   int len2 = ___INT(___STRINGLENGTH(str2));
1407
1408 #ifdef USE_wchar
1409
1410   return ___FIX(0);
1411
1412 #else
1413
1414   int n;
1415   int i;
1416
1417   n = len1;
1418   if (len2 < n)
1419     n = len2;
1420
1421   for (i=0; i<n; i++)
1422     {
1423       ___UCS_4 c1 = ___INT(___STRINGREF(str1,___FIX(i)));
1424       ___UCS_4 c2 = ___INT(___STRINGREF(str2,___FIX(i)));
1425
1426       if (c1 >= 65 && c1 <= 90)
1427         c1 += 32;
1428
1429       if (c2 >= 65 && c2 <= 90)
1430         c2 += 32;
1431
1432       if (c1 < c2)
1433         return ___FIX(0);
1434
1435       if (c1 > c2)
1436         return ___FIX(2);
1437     }
1438
1439   if (len1 < len2)
1440     return ___FIX(0);
1441
1442   if (len1 > len2)
1443     return ___FIX(2);
1444
1445   return ___FIX(1);
1446
1447 #endif
1448 }
1449
1450
1451 /*---------------------------------------------------------------------------*/
1452
1453 /*
1454  * Numerical library routines.
1455  */
1456
1457 #ifdef ___BIG_ENDIAN
1458 #define F64_HI8 0
1459 #define F64_HI16 0
1460 #define F64_HI32 0
1461 #define F64_LO32 1
1462 #else
1463 #define F64_HI8 7
1464 #define F64_HI16 3
1465 #define F64_HI32 1
1466 #define F64_LO32 0
1467 #endif
1468
1469
1470 ___EXP_FUNC(double,___copysign)
1471    ___P((double x,
1472          double y),
1473         (x,
1474          y)
1475 double x;
1476 double y;)
1477 {
1478   ___STORE_U8(&x,
1479               F64_HI8,
1480               (___FETCH_U8(&x,F64_HI8)&0x7f)|(___FETCH_U8(&y,F64_HI8)&0x80));
1481
1482   return x;
1483 }
1484
1485
1486 ___EXP_FUNC(___BOOL,___isfinite)
1487    ___P((double x),
1488         (x)
1489 double x;)
1490 {
1491 #ifdef ___CRAY_FP_FORMAT
1492
1493   return 1;
1494
1495 #else
1496
1497   union
1498     {
1499       ___U16 u16[4];
1500       ___F64 f64;
1501     } y;
1502
1503   y.f64 = x;
1504
1505   return ((y.u16[F64_HI16] ^ 0x7ff0) & 0x7fff) >= 0x10;
1506
1507 #endif
1508 }
1509
1510
1511 ___EXP_FUNC(___BOOL,___isnan)
1512    ___P((double x),
1513         (x)
1514 double x;)
1515 {
1516 #ifdef ___CRAY_FP_FORMAT
1517
1518   return 0;
1519
1520 #else
1521
1522   union
1523     {
1524       ___U32 u32[2];
1525       ___F64 f64;
1526     } y;
1527
1528   y.f64 = x;
1529
1530   ___UM32 tmp = (y.u32[F64_HI32] ^ 0x7ff00000) & 0x7fffffff;
1531
1532   return tmp < 0x100000 && (tmp | y.u32[F64_LO32]) != 0;
1533
1534 #endif
1535 }
1536
1537
1538 ___EXP_FUNC(double,___trunc)
1539    ___P((double x),
1540         (x)
1541 double x;)
1542 {
1543   double f = floor (x);
1544   if (x < 0.0 && x != f)
1545     return f + 1.0;
1546   else
1547     return f;
1548 }
1549
1550
1551 ___EXP_FUNC(double,___round)
1552    ___P((double x),
1553         (x)
1554 double x;)
1555 {
1556   double f, i, t;
1557   if (x < 0.0)
1558     {
1559       f = modf (-x, &i);
1560       if (f > 0.5 || (f == 0.5 && modf (i*0.5, &t) != 0.0))
1561         return -(i+1.0);
1562       else
1563         return -i;
1564     }
1565   else if (x == 0.0) /* so that round (-0.0) = -0.0 */
1566     return x;
1567   else
1568     {
1569       f = modf (x, &i);
1570       if (f > 0.5 || (f == 0.5 && modf (i*0.5, &t) != 0.0))
1571         return i+1.0;
1572       else
1573         return i;
1574     }
1575 }
1576
1577
1578 #ifndef ___GOOD_ATAN2
1579
1580 ___EXP_FUNC(double,___atan2)
1581    ___P((double y,
1582          double x),
1583         (y,
1584          x)
1585 double y;
1586 double x;)
1587 {
1588   if (___isnan (x))
1589     return x;
1590   else if (___isnan (y))
1591     return y;
1592   else if (y == 0.0)
1593     {
1594       if (___copysign (1.0, y) > 0.0)
1595         {
1596           if (___copysign (1.0, x) > 0.0)
1597             return 0.0;
1598           else
1599             return 3.141592653589793; /* from "header.scm" */
1600         }
1601       else
1602         {
1603           if (___copysign (1.0, x) > 0.0)
1604             return -0.0;
1605           else
1606             return -3.141592653589793; /* from "header.scm" */
1607         }
1608     }
1609   else if (___isfinite (x) || ___isfinite (y))
1610     return atan2 (y, x);
1611   else
1612     return ___copysign (x/y, x*y); /* returns NAN with appropriate sign */
1613 }
1614
1615 #endif
1616
1617
1618 #ifndef ___GOOD_POW
1619
1620 ___EXP_FUNC(double,___pow)
1621    ___P((double x,
1622          double y),
1623         (x,
1624          y)
1625 double x;
1626 double y;)
1627 {
1628   if (y == 0.0)
1629     return 1.0;
1630   else if (___isnan (x))
1631     return x;
1632   else if (___isnan (y))
1633     return y;
1634   else
1635     return pow (x, y);
1636 }
1637
1638 #endif
1639
1640
1641 /*---------------------------------------------------------------------------*/
1642
1643 /*
1644  * Initialization of symbol and keyword tables, and global variables.
1645  */
1646
1647 ___HIDDEN void init_symkey_glo1
1648    ___P((___mod_or_lnk mol),
1649         (mol)
1650 ___mod_or_lnk mol;)
1651 {
1652   if (mol->module.kind == ___LINKFILE_KIND)
1653     {
1654       void **p1 = mol->linkfile.linker_tbl;
1655       ___FAKEWORD *p2 = mol->linkfile.sym_list;
1656
1657       while (*p1 != 0)
1658         init_symkey_glo1 (___CAST(___mod_or_lnk,*p1++));
1659
1660       while (p2 != 0)
1661         {
1662           ___SCMOBJ *sym_ptr;
1663           ___glo_struct *glo;
1664
1665           sym_ptr = ___CAST(___SCMOBJ*,p2);
1666
1667           p2 = ___CAST(___FAKEWORD*,sym_ptr[0]);
1668           glo = ___CAST(___glo_struct*,sym_ptr[1+___SYMBOL_GLOBAL]);
1669
1670           sym_ptr[1+___SYMKEY_HASH] = glo->prm; /* move symbol's hash value */
1671         }
1672     }
1673 }
1674
1675
1676 ___HIDDEN void init_symkey_glo2
1677    ___P((___mod_or_lnk mol),
1678         (mol)
1679 ___mod_or_lnk mol;)
1680 {
1681   if (mol->module.kind == ___LINKFILE_KIND)
1682     {
1683       void **p1 = mol->linkfile.linker_tbl;
1684       ___FAKEWORD *p2 = mol->linkfile.sym_list;
1685       ___FAKEWORD *p3 = mol->linkfile.key_list;
1686       ___processor_state ___ps = ___PSTATE;
1687
1688       while (*p1 != 0)
1689         init_symkey_glo2 (___CAST(___mod_or_lnk,*p1++));
1690
1691       while (p2 != 0)
1692         {
1693           ___SCMOBJ sym;
1694           ___SCMOBJ str;
1695           ___SCMOBJ *sym_ptr;
1696           ___glo_struct *glo;
1697
1698           sym_ptr = ___CAST(___SCMOBJ*,p2);
1699
1700           p2 = ___CAST(___FAKEWORD*,sym_ptr[0]);
1701           str = align_subtyped (___CAST(___SCMOBJ*,sym_ptr[1+___SYMKEY_NAME]));
1702           glo = ___CAST(___glo_struct*,sym_ptr[1+___SYMBOL_GLOBAL]);
1703
1704           glo->next = 0;
1705           if (___ps->glo_list_head == 0)
1706             ___ps->glo_list_head = ___CAST(___SCMOBJ,glo);
1707           else
1708             ___CAST(___glo_struct*,___ps->glo_list_tail)->next =
1709               ___CAST(___SCMOBJ,glo);
1710           ___ps->glo_list_tail = ___CAST(___SCMOBJ,glo);
1711
1712           *sym_ptr = ___MAKE_HD((___SYMBOL_SIZE<<___LWS),___sSYMBOL,___PERM);
1713
1714           sym = align_subtyped (sym_ptr);
1715
1716           ___FIELD(sym,___SYMKEY_NAME) = str;
1717           ___FIELD(sym,___SYMBOL_GLOBAL) = ___CAST(___SCMOBJ,glo);
1718
1719           symkey_add (sym);
1720         }
1721
1722       while (p3 != 0)
1723         {
1724           ___SCMOBJ key, str;
1725           ___SCMOBJ *key_ptr;
1726
1727           key_ptr = ___CAST(___SCMOBJ*,p3);
1728
1729           p3 = ___CAST(___FAKEWORD*,key_ptr[0]);
1730           str = align_subtyped (___CAST(___SCMOBJ*,key_ptr[1+___SYMKEY_NAME]));
1731
1732           *key_ptr = ___MAKE_HD((___KEYWORD_SIZE<<___LWS),___sKEYWORD,___PERM);
1733
1734           key = align_subtyped (key_ptr);
1735
1736           ___FIELD(key,___SYMKEY_NAME) = str;
1737           ___FIELD(key,___SYMKEY_HASH) = hash_scheme_string (str);
1738
1739           symkey_add (key);
1740         }
1741     }
1742 }
1743
1744
1745 /*---------------------------------------------------------------------------*/
1746
1747 /*
1748  * C to Scheme call handler.
1749  */
1750
1751 ___EXP_FUNC(___SCMOBJ,___call)
1752    ___P((int nargs,
1753          ___SCMOBJ proc,
1754          ___SCMOBJ stack_marker),
1755         (nargs,
1756          proc,
1757          stack_marker)
1758 int nargs;
1759 ___SCMOBJ proc;
1760 ___SCMOBJ stack_marker;)
1761 {
1762   ___SCMOBJ ___err;
1763   ___processor_state ___ps = ___PSTATE;
1764   ___SCMOBJ *___fp = ___ps->fp;
1765
1766   /*
1767    * The C function which has called ___call() has put the arguments
1768    * of the Scheme procedure on the stack above ___fp as shown in the
1769    * 'on entry' picture below.  The free space under arg1 is for a
1770    * continuation frame that performs the return of control from
1771    * Scheme to C.  This frame is set up by ___call() before the
1772    * destination Scheme procedure is invoked.  The frame is accessed
1773    * by the return_to_c handler (in "_kernel.scm") which is invoked
1774    * when the called procedure returns.  The frame contains a heap
1775    * allocated 'stack marker', allocated by the caller, which
1776    * indicates the destination Scheme procedure and if it is still possible
1777    * to return to the caller (i.e. its activation frame is still on
1778    * the C stack).  The caller will store #f in the stack marker so
1779    * that any subsequent attempt to return to that invocation of the
1780    * caller will be detected and trigger an error.
1781    *
1782    *
1783    *            ON ENTRY:          JUST BEFORE JUMPING TO THE SCHEME PROCEDURE:
1784    *
1785    *              STACK                         STACK             HEAP
1786    *          |     ^      |                |     ^      |
1787    *          |     |      |                |     |      |
1788    *          |            |                |            |
1789    *          |            |                |            |
1790    *          |   arg N    |                |   arg N    |
1791    *          |    ...     |       ___fp -->|    ...     |
1792    *          |   arg 1    |                |   arg 1    |
1793    *          +------------+                +------------+
1794    *          |  RESERVED  |                |  RESERVED  |    stack marker
1795    *          | <PADDING>  |                | <PADDING>  |   +------------+
1796    *          | undefined  |                |     ---------->|    HEAD    |
1797    *          | undefined  |                | return adr |   | procedure  |
1798    *          +------------+                +------------+   +------------+
1799    * ___fp -->|  RESERVED  |                |  RESERVED  |
1800    *          |    ...     |                |    ...     |
1801    *          +------------+                +------------+
1802    *          |            |                |            |
1803    */
1804
1805   ___LD_ARG_REGS /* declare and load GVM argument registers from ___ps */
1806
1807   ___fp[-1] = ___PSR0;      /* create a frame with the same format as the */
1808   ___fp[-2] = stack_marker; /* one created for the return to C handler    */
1809                             /* in "_kernel.scm"                           */
1810
1811   ___fp -= ___FRAME_SPACE(2) + nargs; /* move ___fp to point to last arg */
1812
1813   ___POP_ARGS_IN_REGS(nargs) /* load arguments into appropriate registers */
1814
1815   ___ST_ARG_REGS /* write back GVM argument registers to ___ps */
1816
1817   ___PSR0 = ___GSTATE->handler_return_to_c;
1818
1819   ___ps->fp = ___fp;
1820   ___ps->na = nargs;
1821   ___ps->pc = ___CAST(___label_struct*,proc-___tSUBTYPED)->entry_or_descr;
1822   ___PSSELF = proc;
1823
1824   ___BEGIN_TRY
1825
1826   ___SCMOBJ ___pc = ___ps->pc;
1827
1828   for (;;)
1829     {
1830 #define CALL_STEP \
1831 ___pc = ___CAST_FAKEHOST_TO_HOST(___CAST(___label_struct*,___pc-___tSUBTYPED) \
1832                                  ->host)(___ps)
1833       CALL_STEP;
1834       CALL_STEP;
1835       CALL_STEP;
1836       CALL_STEP;
1837       CALL_STEP;
1838       CALL_STEP;
1839       CALL_STEP;
1840       CALL_STEP;
1841     }
1842
1843   ___END_TRY
1844
1845   if (___err != ___FIX(___UNWIND_C_STACK) ||
1846       stack_marker != ___ps->fp[___FRAME_SPACE(2)-2]) /*need more unwinding?*/
1847     ___THROW(___err);
1848
1849   ___ps->fp += ___FRAME_SPACE(2);
1850   ___PSR0 = ___ps->fp[-1];
1851
1852   return ___FIX(___NO_ERR);
1853 }
1854
1855
1856 ___EXP_FUNC(void,___propagate_error)
1857    ___P((___SCMOBJ err),
1858         (err)
1859 ___SCMOBJ err;)
1860 {
1861   if (err != ___FIX(___NO_ERR))
1862     {
1863       ___processor_state ___ps = ___PSTATE;
1864       ___THROW (err);
1865     }
1866 }
1867
1868
1869 #ifdef ___DEBUG
1870
1871 ___SCMOBJ find_global_var_bound_to
1872    ___P((___SCMOBJ val),
1873         (val)
1874 ___SCMOBJ val;)
1875 {
1876   ___SCMOBJ sym = ___NUL;
1877   int i;
1878
1879   for (i = ___INT(___VECTORLENGTH(___GSTATE->symbol_table)) - 1; i>0; i--)
1880     {
1881       sym = ___FIELD(___GSTATE->symbol_table,i);
1882
1883       while (sym != ___NUL)
1884        {
1885           ___SCMOBJ g = ___FIELD(sym,___SYMBOL_GLOBAL);
1886
1887           if (g != ___FIX(0))
1888             {
1889               ___glo_struct *p = ___CAST(___glo_struct*,g);
1890
1891               if (p->prm == val || p->val == val)
1892                 {
1893                   i = 0;
1894                   break;
1895                 }
1896             }
1897
1898           sym = ___FIELD(sym,___SYMKEY_NEXT);
1899         }
1900     }
1901
1902   return sym;
1903 }
1904
1905 #endif
1906
1907
1908 #ifdef ___DEBUG_HOST_CHANGES
1909
1910 ___EXP_FUNC(void,___register_host_entry)
1911    ___P((___WORD start,
1912          char *module_name),
1913         (start,
1914          module_name)
1915 ___WORD start;
1916 char *module_name;)
1917 {
1918 #ifdef ___DEBUG
1919
1920   ___processor_state ___ps = ___PSTATE;
1921   ___SCMOBJ sym;
1922
1923   ___printf ("*** Entering ");
1924
1925   if ((sym = find_global_var_bound_to (___ps->pc)) != ___NUL ||
1926       (sym = find_global_var_bound_to (start)) != ___NUL)
1927     {
1928       ___SCMOBJ name = ___FIELD(sym,___SYMKEY_NAME);
1929       int i;
1930       for (i=0; i<___INT(___STRINGLENGTH(name)); i++)
1931         ___printf ("%c", ___INT(___STRINGREF(name,___FIX(i))));
1932     }
1933   else
1934     {
1935       ___printf ("|%s| host=0x%08x", module_name, start);
1936     }
1937
1938   if (start == ___ps->pc)
1939     ___printf ("\n");
1940   else
1941     ___printf (" (subprocedure %d)\n",
1942                ___CAST(___label_struct*,___ps->pc) -
1943                ___CAST(___label_struct*,start));
1944
1945 #endif
1946 }
1947
1948 #endif
1949
1950
1951 /*---------------------------------------------------------------------------*/
1952
1953 /*
1954  * Setup program and execute it.
1955  */
1956
1957 ___HIDDEN int setup_state = 0; /* 0=pre-setup, 1=post-setup, 2=post-cleanup */
1958
1959
1960 ___EXP_FUNC(void,___cleanup) ___PVOID
1961 {
1962   /*
1963    * Only do cleanup once after successful setup.
1964    */
1965
1966   if (setup_state != 1)
1967     return;
1968
1969   setup_state = 2;
1970
1971   ___cleanup_mem ();
1972   ___cleanup_os ();
1973 }
1974
1975
1976 ___EXP_FUNC(void,___cleanup_and_exit_process)
1977    ___P((int status),
1978         (status)
1979 int status;)
1980 {
1981   ___cleanup ();
1982   ___exit_process (status);
1983 }
1984
1985
1986 ___EXP_FUNC(void,___setup_params_reset)
1987    ___P((___setup_params_struct *setup_params),
1988         (setup_params)
1989 ___setup_params_struct *setup_params;)
1990 {
1991   setup_params->version           = 0;
1992   setup_params->argv              = reset_argv;
1993   setup_params->min_heap          = 0;
1994   setup_params->max_heap          = 0;
1995   setup_params->live_percent      = 0;
1996   setup_params->gc_hook           = 0;
1997   setup_params->display_error     = 0;
1998   setup_params->fatal_error       = 0;
1999   setup_params->standard_level    = 0;
2000   setup_params->debug_settings    = 0;
2001   setup_params->file_settings     = 0;
2002   setup_params->terminal_settings = 0;
2003   setup_params->stdio_settings    = 0;
2004   setup_params->gambcdir          = 0;
2005   setup_params->gambcdir_map      = 0;
2006   setup_params->remote_dbg_addr   = 0;
2007   setup_params->rpc_server_addr   = 0;
2008   setup_params->linker            = 0;
2009   setup_params->dummy8            = 0;
2010   setup_params->dummy7            = 0;
2011   setup_params->dummy6            = 0;
2012   setup_params->dummy5            = 0;
2013   setup_params->dummy4            = 0;
2014   setup_params->dummy3            = 0;
2015   setup_params->dummy2            = 0;
2016   setup_params->dummy1            = 0;
2017 }
2018
2019
2020 ___EXP_FUNC(unsigned long,___get_min_heap) ___PVOID
2021 {
2022   return ___setup_params.min_heap;
2023 }
2024
2025
2026 ___EXP_FUNC(void,___set_min_heap)
2027    ___P((unsigned long bytes),
2028         (bytes)
2029 unsigned long bytes;)
2030 {
2031   ___setup_params.min_heap = bytes;
2032 }
2033
2034
2035 ___EXP_FUNC(unsigned long,___get_max_heap) ___PVOID
2036 {
2037   return ___setup_params.max_heap;
2038 }
2039
2040
2041 ___EXP_FUNC(void,___set_max_heap)
2042    ___P((unsigned long bytes),
2043         (bytes)
2044 unsigned long bytes;)
2045 {
2046   ___setup_params.max_heap = bytes;
2047 }
2048
2049
2050 ___EXP_FUNC(int,___get_live_percent) ___PVOID
2051 {
2052   return ___setup_params.live_percent;
2053 }
2054
2055
2056 ___EXP_FUNC(void,___set_live_percent)
2057    ___P((int percent),
2058         (percent)
2059 int percent;)
2060 {
2061   ___setup_params.live_percent = percent;
2062 }
2063
2064
2065 ___EXP_FUNC(int,___get_standard_level) ___PVOID
2066 {
2067   return ___setup_params.standard_level;
2068 }
2069
2070
2071 ___EXP_FUNC(void,___set_standard_level)
2072    ___P((int level),
2073         (level)
2074 int level;)
2075 {
2076   ___setup_params.standard_level = level;
2077 }
2078
2079
2080 ___EXP_FUNC(int,___set_debug_settings)
2081    ___P((int mask,
2082          int new_settings),
2083         (mask,
2084          new_settings)
2085 int mask;
2086 int new_settings;)
2087 {
2088   int old_settings = ___setup_params.debug_settings;
2089
2090   ___setup_params.debug_settings =
2091     (old_settings & ~mask) | (new_settings & mask);
2092
2093   return old_settings;
2094 }
2095
2096
2097 ___EXP_FUNC(___program_startup_info_struct*,___get_program_startup_info)
2098    ___PVOID
2099 {
2100   return &___program_startup_info;
2101 }
2102
2103
2104 ___EXP_FUNC(___SCMOBJ,___setup)
2105    ___P((___setup_params_struct *setup_params),
2106         (setup_params)
2107 ___setup_params_struct *setup_params;)
2108 {
2109   ___SCMOBJ ___err;
2110   ___processor_state ___ps;
2111   ___mod_or_lnk mol;
2112   ___SCMOBJ ___start;
2113   ___SCMOBJ marker;
2114   int i;
2115
2116   /*
2117    * Check for valid setup_params structure.
2118    */
2119
2120   if (setup_params == 0 ||
2121       setup_params->version != ___VERSION)
2122     return ___FIX(___UNKNOWN_ERR);
2123
2124   /*
2125    * Only do setup once.
2126    */
2127
2128   if (setup_state != 0)
2129     return ___FIX(___UNKNOWN_ERR);
2130
2131   setup_state = 2; /* disallow cleanup, in case setup fails */
2132
2133   /*
2134    * Remember setup parameters.
2135    */
2136
2137   ___setup_params = *setup_params;
2138
2139   /*
2140    * Setup the operating system module.
2141    */
2142
2143   if ((___err = ___setup_os ()) != ___FIX(___NO_ERR))
2144     return ___err;
2145
2146   /*
2147    * Setup stack and heap.
2148    */
2149
2150   if ((___err = ___setup_mem ()) != ___FIX(___NO_ERR))
2151     {
2152       ___cleanup_os ();
2153       return ___err;
2154     }
2155
2156   setup_state = 1; /* allow cleanup */
2157
2158   /*
2159    * Setup global state to avoid problems on systems that don't
2160    * support the dynamic loading of files that import functions.
2161    */
2162
2163   ___gstate.dummy8 = 0;
2164   ___gstate.dummy7 = 0;
2165   ___gstate.dummy6 = 0;
2166   ___gstate.dummy5 = 0;
2167   ___gstate.dummy4 = 0;
2168   ___gstate.dummy3 = 0;
2169   ___gstate.dummy2 = 0;
2170   ___gstate.dummy1 = 0;
2171
2172 #ifndef ___CAN_IMPORT_CLIB_DYNAMICALLY
2173
2174   ___gstate.fabs  = fabs;
2175   ___gstate.floor = floor;
2176   ___gstate.ceil  = ceil;
2177   ___gstate.exp   = exp;
2178   ___gstate.log   = log;
2179   ___gstate.sin   = sin;
2180   ___gstate.cos   = cos;
2181   ___gstate.tan   = tan;
2182   ___gstate.asin  = asin;
2183   ___gstate.acos  = acos;
2184   ___gstate.atan  = atan;
2185 #ifdef ___GOOD_ATAN2
2186   ___gstate.atan2 = atan2;
2187 #endif
2188 #ifdef ___GOOD_POW
2189   ___gstate.pow = pow;
2190 #endif
2191   ___gstate.sqrt  = sqrt;
2192
2193 #endif
2194
2195 #ifdef ___USE_SETJMP
2196 #ifndef ___CAN_IMPORT_SETJMP_DYNAMICALLY
2197
2198   ___gstate.setjmp = setjmp;
2199
2200 #endif
2201 #endif
2202
2203 #ifndef ___CAN_IMPORT_DYNAMICALLY
2204
2205   ___gstate.___iswalpha
2206     = ___iswalpha;
2207
2208   ___gstate.___iswdigit
2209     = ___iswdigit;
2210
2211   ___gstate.___iswspace
2212     = ___iswspace;
2213
2214   ___gstate.___iswupper
2215     = ___iswupper;
2216
2217   ___gstate.___iswlower
2218     = ___iswlower;
2219
2220   ___gstate.___towupper
2221     = ___towupper;
2222
2223   ___gstate.___towlower
2224     = ___towlower;
2225
2226   ___gstate.___string_collate
2227     = ___string_collate;
2228
2229   ___gstate.___string_collate_ci
2230     = ___string_collate_ci;
2231
2232   ___gstate.___copysign
2233     = ___copysign;
2234
2235   ___gstate.___isfinite
2236     = ___isfinite;
2237
2238   ___gstate.___isnan
2239     = ___isnan;
2240
2241   ___gstate.___trunc
2242     = ___trunc;
2243
2244   ___gstate.___round
2245     = ___round;
2246
2247 #ifndef ___GOOD_ATAN2
2248   ___gstate.___atan2
2249     = ___atan2;
2250 #endif
2251
2252 #ifndef ___GOOD_POW
2253   ___gstate.___pow
2254     = ___pow;
2255 #endif
2256
2257   ___gstate.___S64_from_SM32_fn
2258     = ___S64_from_SM32_fn;
2259
2260   ___gstate.___S64_from_SM32_UM32_fn
2261     = ___S64_from_SM32_UM32_fn;
2262
2263   ___gstate.___S64_from_LONGLONG_fn
2264     = ___S64_from_LONGLONG_fn;
2265
2266   ___gstate.___S64_to_LONGLONG_fn
2267     = ___S64_to_LONGLONG_fn;
2268
2269   ___gstate.___S64_fits_in_width_fn
2270     = ___S64_fits_in_width_fn;
2271
2272   ___gstate.___U64_from_UM32_fn
2273     = ___U64_from_UM32_fn;
2274
2275   ___gstate.___U64_from_UM32_UM32_fn
2276     = ___U64_from_UM32_UM32_fn;
2277
2278   ___gstate.___U64_from_ULONGLONG_fn
2279     = ___U64_from_ULONGLONG_fn;
2280
2281   ___gstate.___U64_to_ULONGLONG_fn
2282     = ___U64_to_ULONGLONG_fn;
2283
2284   ___gstate.___U64_fits_in_width_fn
2285     = ___U64_fits_in_width_fn;
2286
2287   ___gstate.___U64_mul_UM32_UM32_fn
2288     = ___U64_mul_UM32_UM32_fn;
2289
2290   ___gstate.___U64_add_U64_U64_fn
2291     = ___U64_add_U64_U64_fn;
2292
2293   ___gstate.___SCMOBJ_to_S8
2294     = ___SCMOBJ_to_S8;
2295
2296   ___gstate.___SCMOBJ_to_U8
2297     = ___SCMOBJ_to_U8;
2298
2299   ___gstate.___SCMOBJ_to_S16
2300     = ___SCMOBJ_to_S16;
2301
2302   ___gstate.___SCMOBJ_to_U16
2303     = ___SCMOBJ_to_U16;
2304
2305   ___gstate.___SCMOBJ_to_S32
2306     = ___SCMOBJ_to_S32;
2307
2308   ___gstate.___SCMOBJ_to_U32
2309     = ___SCMOBJ_to_U32;
2310
2311   ___gstate.___SCMOBJ_to_S64
2312     = ___SCMOBJ_to_S64;
2313
2314   ___gstate.___SCMOBJ_to_U64
2315     = ___SCMOBJ_to_U64;
2316
2317   ___gstate.___SCMOBJ_to_F32
2318     = ___SCMOBJ_to_F32;
2319
2320   ___gstate.___SCMOBJ_to_F64
2321     = ___SCMOBJ_to_F64;
2322
2323   ___gstate.___SCMOBJ_to_CHAR
2324     = ___SCMOBJ_to_CHAR;
2325
2326   ___gstate.___SCMOBJ_to_SCHAR
2327     = ___SCMOBJ_to_SCHAR;
2328
2329   ___gstate.___SCMOBJ_to_UCHAR
2330     = ___SCMOBJ_to_UCHAR;
2331
2332   ___gstate.___SCMOBJ_to_ISO_8859_1
2333     = ___SCMOBJ_to_ISO_8859_1;
2334
2335   ___gstate.___SCMOBJ_to_UCS_2
2336     = ___SCMOBJ_to_UCS_2;
2337
2338   ___gstate.___SCMOBJ_to_UCS_4
2339     = ___SCMOBJ_to_UCS_4;
2340
2341   ___gstate.___SCMOBJ_to_WCHAR
2342     = ___SCMOBJ_to_WCHAR;
2343
2344   ___gstate.___SCMOBJ_to_SHORT
2345     = ___SCMOBJ_to_SHORT;
2346
2347   ___gstate.___SCMOBJ_to_USHORT
2348     = ___SCMOBJ_to_USHORT;
2349
2350   ___gstate.___SCMOBJ_to_INT
2351     = ___SCMOBJ_to_INT;
2352
2353   ___gstate.___SCMOBJ_to_UINT
2354     = ___SCMOBJ_to_UINT;
2355
2356   ___gstate.___SCMOBJ_to_LONG
2357     = ___SCMOBJ_to_LONG;
2358
2359   ___gstate.___SCMOBJ_to_ULONG
2360     = ___SCMOBJ_to_ULONG;
2361
2362   ___gstate.___SCMOBJ_to_LONGLONG
2363     = ___SCMOBJ_to_LONGLONG;
2364
2365   ___gstate.___SCMOBJ_to_ULONGLONG
2366     = ___SCMOBJ_to_ULONGLONG;
2367
2368   ___gstate.___SCMOBJ_to_FLOAT
2369     = ___SCMOBJ_to_FLOAT;
2370
2371   ___gstate.___SCMOBJ_to_DOUBLE
2372     = ___SCMOBJ_to_DOUBLE;
2373
2374   ___gstate.___SCMOBJ_to_STRUCT
2375     = ___SCMOBJ_to_STRUCT;
2376
2377   ___gstate.___SCMOBJ_to_UNION
2378     = ___SCMOBJ_to_UNION;
2379
2380   ___gstate.___SCMOBJ_to_TYPE
2381     = ___SCMOBJ_to_TYPE;
2382
2383   ___gstate.___SCMOBJ_to_POINTER
2384     = ___SCMOBJ_to_POINTER;
2385
2386   ___gstate.___SCMOBJ_to_NONNULLPOINTER
2387     = ___SCMOBJ_to_NONNULLPOINTER;
2388
2389   ___gstate.___SCMOBJ_to_FUNCTION
2390     = ___SCMOBJ_to_FUNCTION;
2391
2392   ___gstate.___SCMOBJ_to_NONNULLFUNCTION
2393     = ___SCMOBJ_to_NONNULLFUNCTION;
2394
2395   ___gstate.___SCMOBJ_to_BOOL
2396     = ___SCMOBJ_to_BOOL;
2397
2398   ___gstate.___SCMOBJ_to_STRING
2399     = ___SCMOBJ_to_STRING;
2400
2401   ___gstate.___SCMOBJ_to_NONNULLSTRING
2402     = ___SCMOBJ_to_NONNULLSTRING;
2403
2404   ___gstate.___SCMOBJ_to_NONNULLSTRINGLIST
2405     = ___SCMOBJ_to_NONNULLSTRINGLIST;
2406
2407   ___gstate.___SCMOBJ_to_CHARSTRING
2408     = ___SCMOBJ_to_CHARSTRING;
2409
2410   ___gstate.___SCMOBJ_to_NONNULLCHARSTRING
2411     = ___SCMOBJ_to_NONNULLCHARSTRING;
2412
2413   ___gstate.___SCMOBJ_to_NONNULLCHARSTRINGLIST
2414     = ___SCMOBJ_to_NONNULLCHARSTRINGLIST;
2415
2416   ___gstate.___SCMOBJ_to_ISO_8859_1STRING
2417     = ___SCMOBJ_to_ISO_8859_1STRING;
2418
2419   ___gstate.___SCMOBJ_to_NONNULLISO_8859_1STRING
2420     = ___SCMOBJ_to_NONNULLISO_8859_1STRING;
2421
2422   ___gstate.___SCMOBJ_to_NONNULLISO_8859_1STRINGLIST
2423     = ___SCMOBJ_to_NONNULLISO_8859_1STRINGLIST;
2424
2425   ___gstate.___SCMOBJ_to_UTF_8STRING
2426     = ___SCMOBJ_to_UTF_8STRING;
2427
2428   ___gstate.___SCMOBJ_to_NONNULLUTF_8STRING
2429     = ___SCMOBJ_to_NONNULLUTF_8STRING;
2430
2431   ___gstate.___SCMOBJ_to_NONNULLUTF_8STRINGLIST
2432     = ___SCMOBJ_to_NONNULLUTF_8STRINGLIST;
2433
2434   ___gstate.___SCMOBJ_to_UTF_16STRING
2435     = ___SCMOBJ_to_UTF_16STRING;
2436
2437   ___gstate.___SCMOBJ_to_NONNULLUTF_16STRING
2438     = ___SCMOBJ_to_NONNULLUTF_16STRING;
2439
2440   ___gstate.___SCMOBJ_to_NONNULLUTF_16STRINGLIST
2441     = ___SCMOBJ_to_NONNULLUTF_16STRINGLIST;
2442
2443   ___gstate.___SCMOBJ_to_UCS_2STRING
2444     = ___SCMOBJ_to_UCS_2STRING;
2445
2446   ___gstate.___SCMOBJ_to_NONNULLUCS_2STRING
2447     = ___SCMOBJ_to_NONNULLUCS_2STRING;
2448
2449   ___gstate.___SCMOBJ_to_NONNULLUCS_2STRINGLIST
2450     = ___SCMOBJ_to_NONNULLUCS_2STRINGLIST;
2451
2452   ___gstate.___SCMOBJ_to_UCS_4STRING
2453     = ___SCMOBJ_to_UCS_4STRING;
2454
2455   ___gstate.___SCMOBJ_to_NONNULLUCS_4STRING
2456     = ___SCMOBJ_to_NONNULLUCS_4STRING;
2457
2458   ___gstate.___SCMOBJ_to_NONNULLUCS_4STRINGLIST
2459     = ___SCMOBJ_to_NONNULLUCS_4STRINGLIST;
2460
2461   ___gstate.___SCMOBJ_to_WCHARSTRING
2462     = ___SCMOBJ_to_WCHARSTRING;
2463
2464   ___gstate.___SCMOBJ_to_NONNULLWCHARSTRING
2465     = ___SCMOBJ_to_NONNULLWCHARSTRING;
2466
2467   ___gstate.___SCMOBJ_to_NONNULLWCHARSTRINGLIST
2468     = ___SCMOBJ_to_NONNULLWCHARSTRINGLIST;
2469
2470   ___gstate.___SCMOBJ_to_VARIANT
2471     = ___SCMOBJ_to_VARIANT;
2472
2473   ___gstate.___release_foreign
2474     = ___release_foreign;
2475
2476   ___gstate.___release_pointer
2477     = ___release_pointer;
2478
2479   ___gstate.___release_function
2480     = ___release_function;
2481
2482   ___gstate.___addref_function
2483     = ___addref_function;
2484
2485   ___gstate.___release_string
2486     = ___release_string;
2487
2488   ___gstate.___addref_string
2489     = ___addref_string;
2490
2491   ___gstate.___release_string_list
2492     = ___release_string_list;
2493
2494   ___gstate.___addref_string_list
2495     = ___addref_string_list;
2496
2497   ___gstate.___release_variant
2498     = ___release_variant;
2499
2500   ___gstate.___addref_variant
2501     = ___addref_variant;
2502
2503   ___gstate.___S8_to_SCMOBJ
2504     = ___S8_to_SCMOBJ;
2505
2506   ___gstate.___U8_to_SCMOBJ
2507     = ___U8_to_SCMOBJ;
2508
2509   ___gstate.___S16_to_SCMOBJ
2510     = ___S16_to_SCMOBJ;
2511
2512   ___gstate.___U16_to_SCMOBJ
2513     = ___U16_to_SCMOBJ;
2514
2515   ___gstate.___S32_to_SCMOBJ
2516     = ___S32_to_SCMOBJ;
2517
2518   ___gstate.___U32_to_SCMOBJ
2519     = ___U32_to_SCMOBJ;
2520
2521   ___gstate.___S64_to_SCMOBJ
2522     = ___S64_to_SCMOBJ;
2523
2524   ___gstate.___U64_to_SCMOBJ
2525     = ___U64_to_SCMOBJ;
2526
2527   ___gstate.___F32_to_SCMOBJ
2528     = ___F32_to_SCMOBJ;
2529
2530   ___gstate.___F64_to_SCMOBJ
2531     = ___F64_to_SCMOBJ;
2532
2533   ___gstate.___CHAR_to_SCMOBJ
2534     = ___CHAR_to_SCMOBJ;
2535
2536   ___gstate.___SCHAR_to_SCMOBJ
2537     = ___SCHAR_to_SCMOBJ;
2538
2539   ___gstate.___UCHAR_to_SCMOBJ
2540     = ___UCHAR_to_SCMOBJ;
2541
2542   ___gstate.___ISO_8859_1_to_SCMOBJ
2543     = ___ISO_8859_1_to_SCMOBJ;
2544
2545   ___gstate.___UCS_2_to_SCMOBJ
2546     = ___UCS_2_to_SCMOBJ;
2547
2548   ___gstate.___UCS_4_to_SCMOBJ
2549     = ___UCS_4_to_SCMOBJ;
2550
2551   ___gstate.___WCHAR_to_SCMOBJ
2552     = ___WCHAR_to_SCMOBJ;
2553
2554   ___gstate.___SHORT_to_SCMOBJ
2555     = ___SHORT_to_SCMOBJ;
2556
2557   ___gstate.___USHORT_to_SCMOBJ
2558     = ___USHORT_to_SCMOBJ;
2559
2560   ___gstate.___INT_to_SCMOBJ
2561     = ___INT_to_SCMOBJ;
2562
2563   ___gstate.___UINT_to_SCMOBJ
2564     = ___UINT_to_SCMOBJ;
2565
2566   ___gstate.___LONG_to_SCMOBJ
2567     = ___LONG_to_SCMOBJ;
2568
2569   ___gstate.___ULONG_to_SCMOBJ
2570     = ___ULONG_to_SCMOBJ;
2571
2572   ___gstate.___LONGLONG_to_SCMOBJ
2573     = ___LONGLONG_to_SCMOBJ;
2574
2575   ___gstate.___ULONGLONG_to_SCMOBJ
2576     = ___ULONGLONG_to_SCMOBJ;
2577
2578   ___gstate.___FLOAT_to_SCMOBJ
2579     = ___FLOAT_to_SCMOBJ;
2580
2581   ___gstate.___DOUBLE_to_SCMOBJ
2582     = ___DOUBLE_to_SCMOBJ;
2583
2584   ___gstate.___STRUCT_to_SCMOBJ
2585     = ___STRUCT_to_SCMOBJ;
2586
2587   ___gstate.___UNION_to_SCMOBJ
2588     = ___UNION_to_SCMOBJ;
2589
2590   ___gstate.___TYPE_to_SCMOBJ
2591     = ___TYPE_to_SCMOBJ;
2592
2593   ___gstate.___POINTER_to_SCMOBJ
2594     = ___POINTER_to_SCMOBJ;
2595
2596   ___gstate.___NONNULLPOINTER_to_SCMOBJ
2597     = ___NONNULLPOINTER_to_SCMOBJ;
2598
2599   ___gstate.___FUNCTION_to_SCMOBJ
2600     = ___FUNCTION_to_SCMOBJ;
2601
2602   ___gstate.___NONNULLFUNCTION_to_SCMOBJ
2603     = ___NONNULLFUNCTION_to_SCMOBJ;
2604
2605   ___gstate.___BOOL_to_SCMOBJ
2606     = ___BOOL_to_SCMOBJ;
2607
2608   ___gstate.___STRING_to_SCMOBJ
2609     = ___STRING_to_SCMOBJ;
2610
2611   ___gstate.___NONNULLSTRING_to_SCMOBJ
2612     = ___NONNULLSTRING_to_SCMOBJ;
2613
2614   ___gstate.___NONNULLSTRINGLIST_to_SCMOBJ
2615     = ___NONNULLSTRINGLIST_to_SCMOBJ;
2616
2617   ___gstate.___CHARSTRING_to_SCMOBJ
2618     = ___CHARSTRING_to_SCMOBJ;
2619
2620   ___gstate.___NONNULLCHARSTRING_to_SCMOBJ
2621     = ___NONNULLCHARSTRING_to_SCMOBJ;
2622
2623   ___gstate.___NONNULLCHARSTRINGLIST_to_SCMOBJ
2624     = ___NONNULLCHARSTRINGLIST_to_SCMOBJ;
2625
2626   ___gstate.___ISO_8859_1STRING_to_SCMOBJ
2627     = ___ISO_8859_1STRING_to_SCMOBJ;
2628
2629   ___gstate.___NONNULLISO_8859_1STRING_to_SCMOBJ
2630     = ___NONNULLISO_8859_1STRING_to_SCMOBJ;
2631
2632   ___gstate.___NONNULLISO_8859_1STRINGLIST_to_SCMOBJ
2633     = ___NONNULLISO_8859_1STRINGLIST_to_SCMOBJ;
2634
2635   ___gstate.___UTF_8STRING_to_SCMOBJ
2636     = ___UTF_8STRING_to_SCMOBJ;
2637
2638   ___gstate.___NONNULLUTF_8STRING_to_SCMOBJ
2639     = ___NONNULLUTF_8STRING_to_SCMOBJ;
2640
2641   ___gstate.___NONNULLUTF_8STRINGLIST_to_SCMOBJ
2642     = ___NONNULLUTF_8STRINGLIST_to_SCMOBJ;
2643
2644   ___gstate.___UTF_16STRING_to_SCMOBJ
2645     = ___UTF_16STRING_to_SCMOBJ;
2646
2647   ___gstate.___NONNULLUTF_16STRING_to_SCMOBJ
2648     = ___NONNULLUTF_16STRING_to_SCMOBJ;
2649
2650   ___gstate.___NONNULLUTF_16STRINGLIST_to_SCMOBJ
2651     = ___NONNULLUTF_16STRINGLIST_to_SCMOBJ;
2652
2653   ___gstate.___UCS_2STRING_to_SCMOBJ
2654     = ___UCS_2STRING_to_SCMOBJ;
2655
2656   ___gstate.___NONNULLUCS_2STRING_to_SCMOBJ
2657     = ___NONNULLUCS_2STRING_to_SCMOBJ;
2658
2659   ___gstate.___NONNULLUCS_2STRINGLIST_to_SCMOBJ
2660     = ___NONNULLUCS_2STRINGLIST_to_SCMOBJ;
2661
2662   ___gstate.___UCS_4STRING_to_SCMOBJ
2663     = ___UCS_4STRING_to_SCMOBJ;
2664
2665   ___gstate.___NONNULLUCS_4STRING_to_SCMOBJ
2666     = ___NONNULLUCS_4STRING_to_SCMOBJ;
2667
2668   ___gstate.___NONNULLUCS_4STRINGLIST_to_SCMOBJ
2669     = ___NONNULLUCS_4STRINGLIST_to_SCMOBJ;
2670
2671   ___gstate.___WCHARSTRING_to_SCMOBJ
2672     = ___WCHARSTRING_to_SCMOBJ;
2673
2674   ___gstate.___NONNULLWCHARSTRING_to_SCMOBJ
2675     = ___NONNULLWCHARSTRING_to_SCMOBJ;
2676
2677   ___gstate.___NONNULLWCHARSTRINGLIST_to_SCMOBJ
2678     = ___NONNULLWCHARSTRINGLIST_to_SCMOBJ;
2679
2680   ___gstate.___VARIANT_to_SCMOBJ
2681     = ___VARIANT_to_SCMOBJ;
2682
2683   ___gstate.___CHARSTRING_to_UCS_2STRING
2684     = ___CHARSTRING_to_UCS_2STRING;
2685
2686   ___gstate.___free_UCS_2STRING
2687     = ___free_UCS_2STRING;
2688
2689   ___gstate.___NONNULLCHARSTRINGLIST_to_NONNULLUCS_2STRINGLIST
2690     = ___NONNULLCHARSTRINGLIST_to_NONNULLUCS_2STRINGLIST;
2691
2692   ___gstate.___free_NONNULLUCS_2STRINGLIST
2693     = ___free_NONNULLUCS_2STRINGLIST;
2694
2695   ___gstate.___make_sfun_stack_marker
2696     = ___make_sfun_stack_marker;
2697
2698   ___gstate.___kill_sfun_stack_marker
2699     = ___kill_sfun_stack_marker;
2700
2701   ___gstate.___alloc_rc
2702     = ___alloc_rc;
2703
2704   ___gstate.___release_rc
2705     = ___release_rc;
2706
2707   ___gstate.___addref_rc
2708     = ___addref_rc;
2709
2710   ___gstate.___data_rc
2711     = ___data_rc;
2712
2713   ___gstate.___set_data_rc
2714     = ___set_data_rc;
2715
2716   ___gstate.___alloc_scmobj
2717     = ___alloc_scmobj;
2718
2719   ___gstate.___release_scmobj
2720     = ___release_scmobj;
2721
2722   ___gstate.___make_pair
2723     = ___make_pair;
2724
2725   ___gstate.___make_vector
2726     = ___make_vector;
2727
2728   ___gstate.___still_obj_refcount_inc
2729     = ___still_obj_refcount_inc;
2730
2731   ___gstate.___still_obj_refcount_dec
2732     = ___still_obj_refcount_dec;
2733
2734   ___gstate.___gc_hash_table_ref
2735     = ___gc_hash_table_ref;
2736
2737   ___gstate.___gc_hash_table_set
2738     = ___gc_hash_table_set;
2739
2740   ___gstate.___gc_hash_table_rehash
2741     = ___gc_hash_table_rehash;
2742
2743   ___gstate.___get_min_heap
2744     = ___get_min_heap;
2745
2746   ___gstate.___set_min_heap
2747     = ___set_min_heap;
2748
2749   ___gstate.___get_max_heap
2750     = ___get_max_heap;
2751
2752   ___gstate.___set_max_heap
2753     = ___set_max_heap;
2754
2755   ___gstate.___get_live_percent
2756     = ___get_live_percent;
2757
2758   ___gstate.___set_live_percent
2759     = ___set_live_percent;
2760
2761   ___gstate.___get_standard_level
2762     = ___get_standard_level;
2763
2764   ___gstate.___set_standard_level
2765     = ___set_standard_level;
2766
2767   ___gstate.___set_debug_settings
2768     = ___set_debug_settings;
2769
2770   ___gstate.___get_program_startup_info
2771     = ___get_program_startup_info;
2772
2773   ___gstate.___cleanup
2774     = ___cleanup;
2775
2776   ___gstate.___cleanup_and_exit_process
2777     = ___cleanup_and_exit_process;
2778
2779   ___gstate.___call
2780     = ___call;
2781
2782   ___gstate.___propagate_error
2783     = ___propagate_error;
2784
2785 #ifdef ___DEBUG_HOST_CHANGES
2786   ___gstate.___register_host_entry
2787     = ___register_host_entry;
2788 #endif
2789
2790   ___gstate.___raise_interrupt
2791     = ___raise_interrupt;
2792
2793   ___gstate.___begin_interrupt_service
2794     = ___begin_interrupt_service;
2795
2796   ___gstate.___check_interrupt
2797     = ___check_interrupt;
2798
2799   ___gstate.___end_interrupt_service
2800     = ___end_interrupt_service;
2801
2802   ___gstate.___disable_interrupts
2803     = ___disable_interrupts;
2804
2805   ___gstate.___enable_interrupts
2806     = ___enable_interrupts;
2807
2808   ___gstate.___alloc_mem
2809     = ___alloc_mem;
2810
2811   ___gstate.___free_mem
2812     = ___free_mem;
2813
2814 #endif
2815
2816   /*
2817    * Get processor state.
2818    */
2819
2820   ___ps = ___PSTATE;
2821
2822   /*
2823    * Setup multithreading structures.
2824    */
2825
2826   ___ps->current_thread = ___FAL;
2827   ___ps->run_queue = ___FAL;
2828
2829   /*
2830    * Setup registers.
2831    */
2832
2833   for (i=0; i<___NB_GVM_REGS; i++)
2834     ___ps->r[i] = ___VOID;
2835
2836   /*
2837    * Setup exception handling.
2838    */
2839
2840 #ifdef ___USE_SETJMP
2841
2842   ___ps->catcher = 0;
2843
2844 #endif
2845
2846   /*
2847    * Setup interrupt system.
2848    */
2849
2850   ___disable_interrupts ();
2851
2852   for (i=0; i<___NB_INTRS; i++)
2853     ___ps->intr_flag[i] = 0;
2854
2855   ___begin_interrupt_service ();
2856   ___end_interrupt_service (0);
2857
2858   /*
2859    * Create empty global variable list, symbol table and keyword
2860    * table.
2861    */
2862
2863   ___ps->glo_list_head = 0;
2864   ___ps->glo_list_tail = 0;
2865
2866   ___GSTATE->symbol_table =
2867     symkey_table_alloc (___sSYMBOL, INIT_SYMKEY_TBL_LENGTH);
2868
2869   if (___FIXNUMP(___GSTATE->symbol_table))
2870     {
2871       ___cleanup ();
2872       return ___GSTATE->symbol_table;
2873     }
2874
2875   ___GSTATE->keyword_table =
2876     symkey_table_alloc (___sKEYWORD, INIT_SYMKEY_TBL_LENGTH);
2877
2878   if (___FIXNUMP(___GSTATE->keyword_table))
2879     {
2880       ___cleanup ();
2881       return ___GSTATE->keyword_table;
2882     }
2883
2884   /*
2885    * Setup program's linker structure.
2886    */
2887
2888   mol = linker_to_mod_or_lnk (___setup_params.linker);
2889
2890   /*
2891    * Initialize symbol table, keyword table, global variables
2892    * and primitives.
2893    */
2894
2895   init_symkey_glo1 (mol);
2896   init_symkey_glo2 (mol);
2897
2898   /*
2899    * Setup each module.
2900    */
2901
2902   ___GSTATE->program_descr = setup_modules (mol);
2903
2904   if (___FIXNUMP(___GSTATE->program_descr))
2905     {
2906       ___cleanup ();
2907       return ___GSTATE->program_descr;
2908     }
2909
2910   /*
2911    * Create list of command line arguments (accessible through ##command-line).
2912    */
2913
2914   {
2915     ___UCS_2STRING *argv = ___setup_params.argv;
2916
2917     if (argv[0] == 0) /* use dummy program name if none supplied */
2918       argv = reset_argv;
2919
2920 #define ___COMMAND_LINE_CE_SELECT(ISO_8859_1,UTF_8,UCS_2,UCS_4,wchar,native) UCS_2
2921
2922     if ((___err = ___NONNULLSTRINGLIST_to_SCMOBJ
2923                     (argv,
2924                      &___GSTATE->command_line,
2925                      0,
2926                      ___CE(___COMMAND_LINE_CE_SELECT)))
2927         != ___FIX(___NO_ERR))
2928       {
2929         ___cleanup ();
2930         return ___err;
2931       }
2932   }
2933
2934   /*
2935    * Setup kernel handlers.
2936    */
2937
2938 #define ___PH_LBL0 1
2939
2940   /*
2941    * The label numbers must match those in the procedure
2942    * "##kernel-handlers" in the file "_kernel.scm".
2943    */
2944
2945   ___start = ___G__23__23_kernel_2d_handlers.prm;
2946
2947   ___gstate.handler_sfun_conv_error = ___LBL(0);
2948   ___gstate.handler_cfun_conv_error = ___LBL(1);
2949   ___gstate.handler_stack_limit     = ___LBL(2);
2950   ___gstate.handler_heap_limit      = ___LBL(3);
2951   ___gstate.handler_not_proc        = ___LBL(4);
2952   ___gstate.handler_not_proc_glo    = ___LBL(5);
2953   ___gstate.handler_wrong_nargs     = ___LBL(6);
2954   ___gstate.handler_get_rest        = ___LBL(7);
2955   ___gstate.handler_get_key         = ___LBL(8);
2956   ___gstate.handler_get_key_rest    = ___LBL(9);
2957   ___gstate.handler_force           = ___LBL(10);
2958   ___gstate.handler_return_to_c     = ___LBL(11);
2959   ___gstate.handler_break           = ___LBL(12);
2960   ___gstate.internal_return         = ___LBL(13);
2961
2962   /*
2963    * The label numbers must match those in the procedure
2964    * "##dynamic-env-bind" in the file "_kernel.scm".
2965    */
2966
2967   ___start = ___G__23__23_dynamic_2d_env_2d_bind.prm;
2968
2969   ___gstate.dynamic_env_bind_return = ___LBL(1);
2970
2971 #undef ___PH_LBL0
2972
2973   /*
2974    * Call kernel to start executing program.
2975    */
2976
2977   ___ps->r[0] = ___gstate.handler_break;
2978
2979   ___BEGIN_TRY
2980
2981   if ((___err = ___make_sfun_stack_marker
2982                   (&marker,
2983                    ___FIELD(___FIELD(___GSTATE->program_descr,0),0)))
2984       == ___FIX(___NO_ERR))
2985     {
2986       ___err = ___call (0, ___FIELD(marker,0), marker);
2987       ___kill_sfun_stack_marker (marker);
2988     }
2989
2990   ___END_TRY
2991
2992   if (___err != ___FIX(___NO_ERR))
2993     ___cleanup ();
2994
2995   return ___err;
2996 }
2997
2998
2999 /*---------------------------------------------------------------------------*/