home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / gofer / Sources / c / runtime < prev    next >
Encoding:
Text File  |  1993-02-12  |  35.6 KB  |  1,307 lines
  1. /* --------------------------------------------------------------------------
  2.  * runtime.c:   Copyright (c) Mark P Jones 1991-1993.   All rights reserved.
  3.  *              See goferite.h for details and conditions of use etc...
  4.  *        Gofer Compiler version 1.00 January 1992
  5.  *              Gofer version 2.28 January 1993
  6.  *
  7.  * Runtime system for compiled Gofer programs ... uses a considerably
  8.  * simplified runtime system than required in the full interpreter.
  9.  * ------------------------------------------------------------------------*/
  10.  
  11. #define  NEED_MATH
  12. #include "gofc.h"
  13.  
  14. /* --------------------------------------------------------------------------
  15.  * Static data areas:
  16.  * ------------------------------------------------------------------------*/
  17.  
  18. static  int   keep_argc;        /* keep record of command line       */
  19. static  char  **keep_argv;        /* arguments               */
  20.  
  21. static  Cell  consCharArray[NUM_CHARS];    /* array of ((:) c) for each char c*/
  22.  
  23. static  Cell  resps = 0;        /* pointer to list of responses       */
  24.  
  25. /* --------------------------------------------------------------------------
  26.  * Local function prototypes:
  27.  * ------------------------------------------------------------------------*/
  28.  
  29. static Void   evalString    Args((Cell));
  30.  
  31. static Cell   openFile        Args((String));
  32. static Void   evalFile        Args((Cell));
  33. static Void   closeFile        Args((Int));
  34.  
  35. static Void   dialogue        Args((Cell));
  36. static Void   readFile        Args((Void));
  37. static Void   writeFile        Args((Void));
  38. static Void   appendFile    Args((Void));
  39. static Void   readChan        Args((Void));
  40. static Void   appendChan    Args((Void));
  41. static FILE   *validOutChannel    Args((String));
  42. static Void   echo        Args((Void));
  43. static Void   getArgs        Args((Void));
  44. static Void   getProgName    Args((Void));
  45. static Void   getEnv        Args((Void));
  46. static Void   outputString    Args((FILE *,Cell));
  47. static String evalName        Args((Cell));
  48.  
  49. static Int    compare        Args((Void));
  50.  
  51. static Void   primInit        Args((Void));
  52. static Void   primMark        Args((Void));
  53.  
  54. static sigProto(onBreak);
  55.  
  56. static Void   abandon        Args((String));
  57. static Void   leave        Args((int));
  58.  
  59. /* --------------------------------------------------------------------------
  60.  * Machine dependent code for Gofer runtime system:
  61.  * ------------------------------------------------------------------------*/
  62.  
  63. #define  MACHDEP_RUNTIME 1
  64. #define  internal abandon
  65. #include "machdep.c"
  66. #undef   internal
  67.  
  68. /* --------------------------------------------------------------------------
  69.  * Heap storage: Provides a garbage collected heap.
  70.  *
  71.  * We currently have a choice of two garbage collectors here.  You may use
  72.  * either one or substitute your own collector if you prefer.
  73.  * ------------------------------------------------------------------------*/
  74.  
  75. #if GC_MARKSCAN
  76. #include "markscan.c"
  77. #endif
  78. #if GC_TWOSPACE
  79. #include "twospace.c"
  80. #endif
  81.  
  82. /* --------------------------------------------------------------------------
  83.  * Control stack:
  84.  * ------------------------------------------------------------------------*/
  85.  
  86. Cell     cellStack[NUM_STACK];        /* Storage for cells on stack       */
  87. #ifndef  GLOBALsp
  88. StackPtr sp;                /* stack pointer            */
  89. #endif
  90.  
  91. Void overflow() {            /* Report stack overflow        */
  92.     abandon("control stack overflow");
  93. }
  94.  
  95. Void insufficientArgs() {        /* Report insufficent args on stack*/
  96.     abandon("insufficient arguments on stack");
  97. }
  98.  
  99. /* --------------------------------------------------------------------------
  100.  * Evaluator:
  101.  * ------------------------------------------------------------------------*/
  102.  
  103. #define cfunNil        mkCfun(0)    /* List constructors:           */
  104. #define cfunCons    mkCfun(1)
  105.  
  106. #define cfunFalse    mkCfun(0)    /* Bool constructors:           */
  107. #define cfunTrue    mkCfun(1)
  108.  
  109. Cell  whnf;                /* head of term in whnf           */
  110. Int   whnfInt;                /* whnf term integer value       */
  111.  
  112. Void eval(n)                /* Graph reduction evaluator       */
  113. register Cell n; {
  114.     StackPtr base = sp;
  115.  
  116. unw:if (isPair(n)) {
  117.     switch (fst(n)) {
  118.         case INDIRECT    : n = snd(n);
  119.                   allowBreak();
  120.                   goto unw;
  121.  
  122.         case SUPERCOMB    : push(n);
  123. #if ARGCHECK
  124.                   (*superOf(n))(base);
  125. #else
  126.                   (*superOf(n))();
  127. #endif
  128.                   n  = pop();
  129.                   goto unw;
  130.  
  131.         case INTCELL    : whnfInt = bigOf(n);
  132.                   break;
  133.  
  134.         case FLOATCELL    : break;
  135.  
  136.         case STRCELL    : evalString(n);
  137.                   goto unw;
  138.  
  139.         case FILECELL    : evalFile(n);
  140.                   goto unw;
  141.  
  142.         default        : push(n);
  143.                   n = fst(n);
  144.                   goto unw;
  145.     }
  146.     }
  147.     else
  148.     whnfInt = smallOf(n);
  149.  
  150.     whnf = n;                /* save head of term           */
  151.  
  152.     {   register StackPtr tmp=sp;    /* rearrange components of term on */
  153.     while (tmp<base) {        /* stack, now in whnf ...       */
  154.         fst(*tmp) = n;
  155.         n          = *tmp;
  156.         *tmp++    = snd(n);
  157.     }
  158.     }
  159. }
  160.  
  161. static Void evalString(n)        /* expand STRCELL at node n       */
  162. Cell n; {
  163.     String s = stringOf(n);
  164.     Int    c = *s;
  165.  
  166.     if (c<0)
  167.     c += NUM_CHARS;
  168.     if (c==0) {                /* end of string?           */
  169.     fst(n) = INDIRECT;
  170.     snd(n) = cfunNil;
  171.     return;
  172.     }
  173.     if (c=='\\')            /* check for escape sequence       */
  174.         if ((c = *++s) !='\\')
  175.         c = 0;
  176.     fst(n) = consCharArray[c];
  177.     snd(n) = mkString(++s);
  178. }
  179.  
  180. Void fail() {                /* failure to apply supercombinator*/
  181.     abandon("no applicable equation");
  182. }
  183.  
  184. Cell rootFst(r)                /* find root node           */
  185. register Cell r; {
  186.     for (; fst(r)==INDIRECT; r=snd(r))
  187.     allowBreak();
  188.     for (r=fst(r); isPair(r) && fst(r)==INDIRECT; r=snd(r))
  189.     allowBreak();
  190.     return r;
  191. }
  192.  
  193. /* --------------------------------------------------------------------------
  194.  * File operations:
  195.  * ------------------------------------------------------------------------*/
  196.  
  197. static FILE *infiles[NUM_FILES];    /* file pointers for input files   */
  198.  
  199. static Cell openFile(s)            /* create FILECELL object for named*/
  200. String s; {                /* input file               */
  201.     Int i;
  202.  
  203.     for (i=0; i<NUM_FILES && infiles[i]; ++i)    /* look for unused file .. */
  204.     ;
  205.     if (i>=NUM_FILES) {                /* if at first we don't    */
  206.     garbageCollect();            /* succeed, garbage collect*/
  207.     for (i=0; i<NUM_FILES && infiles[i]; ++i)
  208.         ;                    /* and try again ...       */
  209.     }
  210.     if (i>=NUM_FILES) {                /* ... before we give up   */
  211.     abandon("Too many files open");
  212.     }
  213.  
  214.     if (infiles[i]=fopen(s,"r"))
  215.     return pair(FILECELL,i);
  216.     else
  217.     return cfunNil;
  218. }
  219.  
  220. static Void evalFile(f)                /* read char from given    */
  221. Cell f; {                    /* input file -- ensure       */
  222.     Int c;                    /* only 1 copy of FILECELL */
  223.     if ((c = fgetc(infiles[snd(f)]))==EOF) {
  224.     closeFile(snd(f));
  225.     fst(f) = INDIRECT;
  226.     snd(f) = cfunNil;
  227.     }
  228.     else {
  229.     snd(f) = pair(FILECELL,snd(f));
  230.     fst(f) = consCharArray[c<0 ? c+NUM_CHARS : c];
  231.     }
  232. }
  233.  
  234. static Void closeFile(n)            /* close input file n       */
  235. Int n; {                    /* only permitted when the */
  236.     if (0<=n && n<NUM_FILES && infiles[n]) {    /* end of file is read or  */
  237.     fclose(infiles[n]);            /* when discarded during gc*/
  238.     infiles[n] = 0;
  239.     }
  240. }
  241.  
  242. /* --------------------------------------------------------------------------
  243.  * Dialogue based input/output:
  244.  *
  245.  * N.B. take care when modifying this code - it is rather delicate and even
  246.  * the simplest of changes might create a nasty space leak... you have been
  247.  * warned (please let me know if you think there already is a space leak!).
  248.  * ------------------------------------------------------------------------*/
  249.  
  250. #define cfunReadFile        mkCfun(0)    /* Request constructors:   */
  251. #define cfunWriteFile        mkCfun(1)
  252. #define cfunAppendFile        mkCfun(2)
  253. #define nameReadChan        mkCfun(3)
  254. #define cfunAppendChan        mkCfun(4)
  255. #define cfunEcho        mkCfun(5)
  256. #define cfunGetArgs        mkCfun(6)
  257. #define cfunGetProgName        mkCfun(7)
  258. #define cfunGetEnv        mkCfun(8)
  259.  
  260. #define cfunSuccess        mkCfun(0)    /* Response constructors:  */
  261. #define cfunStr            mkCfun(1)
  262. #define cfunFailure        mkCfun(2)    /* N.B. different ordering */
  263. #define cfunStrList        mkCfun(3)    /* to Haskell report       */
  264.  
  265. #define cfunWriteError        mkCfun(0)    /* IOError constructors:   */
  266. #define cfunReadError        mkCfun(1)
  267. #define cfunSearchError        mkCfun(2)
  268. #define cfunFormatError        mkCfun(3)
  269. #define    cfunOtherError        mkCfun(4)
  270.  
  271. static Bool echoChanged;        /* TRUE => echo changed in dialogue*/
  272. static Bool stdinUsed;            /* TRUE => ReadChan stdin has been */
  273.                     /*       seen in dialogue       */
  274.  
  275. static Void dialogue(prog)        /* carry out dialogue ...       */
  276. Cell prog; {                /*    :: [Response]->[Request]       */
  277.  
  278.     echoChanged = FALSE;        /* set status flags           */
  279.     stdinUsed   = FALSE;
  280.  
  281.     clearStack();
  282.     pushStr("Attempt to read response before request complete");
  283.     resps = pair(primError,pop());    /* set up initial responses       */
  284.  
  285.     eval(pair(prog,resps));
  286.     while (whnf==cfunCons) {
  287.     eval(pop());            /* evaluate the request           */
  288.  
  289.     if (whnf==cfunReadFile)        /* carry out the request       */
  290.         readFile();
  291.     else if (whnf==cfunWriteFile)
  292.         writeFile();
  293.     else if (whnf==cfunAppendFile)
  294.         appendFile();
  295.     else if (whnf==nameReadChan)
  296.         readChan();
  297.     else if (whnf==cfunAppendChan)
  298.         appendChan();
  299.     else if (whnf==cfunEcho)
  300.         echo();
  301.     else if (whnf==cfunGetArgs)
  302.         getArgs();
  303.     else if (whnf==cfunGetProgName)
  304.         getProgName();
  305.     else if (whnf==cfunGetEnv)
  306.         getEnv();
  307.     else
  308.         abandon("type error in request");
  309.  
  310.     heap(2);
  311.     fst(resps) = pair(cfunCons,pop());    /* save response       */
  312.         snd(resps) = pair(primError,snd(resps));
  313.         resps      = snd(resps);
  314.  
  315.     eval(pop());            /* evaluate the rest of the program*/
  316.     }
  317.     if (whnf!=cfunNil)
  318.     abandon("type error in dialogue");
  319. }
  320.  
  321. /* --------------------------------------------------------------------------
  322.  * File system requests:
  323.  * ------------------------------------------------------------------------*/
  324.  
  325. static Void readFile() {        /* repond to ReadFile request       */
  326.     String s = evalName(pushed(0));    /* pushed(0) = file name string       */
  327.     Cell   f;                /* pushed(1) = rest of program       */
  328.  
  329.     if (access(s,0)!=0) {        /* can't find file           */
  330.     heap(2);
  331.     topfun(cfunSearchError);
  332.         topfun(cfunFailure);
  333.     }
  334.     else if (isPair(f=openFile(s))) {    /* file opened?               */
  335.     pushed(0) = f;
  336.     heap(1);
  337.         topfun(cfunStr);
  338.     }
  339.     else {                /* can't open file           */
  340.     heap(2);
  341.     topfun(cfunReadError);
  342.     topfun(cfunFailure);
  343.     }
  344. }
  345.  
  346. static Void writeFile() {        /* respond to WriteFile request       */
  347.     String s   = evalName(pushed(0));    /* pushed(0) = file name string       */
  348.     FILE   *fp;                /* pushed(1) = contents           */
  349.                     /* pushed(2) = rest of program       */
  350.  
  351.     if ((fp=fopen(s,FOPEN_WRITE))==0) { /* problem with output file       */
  352.     heap(2);
  353.     topfun(cfunWriteError);
  354.     topfun(cfunFailure);
  355.     slide(1,top());
  356.     }
  357.     else {
  358.     drop();                /* discard file name           */
  359.         outputString(fp,pop());        /* output string           */
  360.     fclose(fp);            /* and then close file           */
  361.     onto(cfunSuccess);
  362.     }
  363. }
  364.  
  365. static Void appendFile() {        /* respond to AppendFile request   */
  366.     String s   = evalName(pushed(0));    /* pushed(0) = file name string       */
  367.     FILE   *fp;                /* pushed(1) = contents           */
  368.                     /* pushed(2) = rest of program       */
  369.  
  370.     if (access(s,0)!=0) {        /* can't find file           */
  371.     heap(2);
  372.     topfun(cfunSearchError);
  373.         topfun(cfunFailure);
  374.     slide(1,top());
  375.     }
  376.     else if ((fp=fopen(s,FOPEN_APPEND))==0) {
  377.     heap(2);
  378.     topfun(cfunWriteError);        /* problem with output file       */
  379.     topfun(cfunFailure);
  380.     slide(1,top());
  381.     }
  382.     else {
  383.     drop();                /* discard file name           */
  384.         outputString(fp,pop());        /* output string           */
  385.     fclose(fp);            /* and then close file           */
  386.     onto(cfunSuccess);
  387.     }
  388. }
  389.  
  390. /* --------------------------------------------------------------------------
  391.  * Channel system requests:
  392.  * ------------------------------------------------------------------------*/
  393.  
  394. static Cell primInput;            /* builtin primitive function       */
  395.  
  396. static Void readChan() {                /* respond to ReadChan request       */
  397.     String s = evalName(pushed(0));    /* pushed(0) = channel name string */
  398.                                         /* pushed(1) = rest of program       */
  399.  
  400.     if (strcmp(s,"stdin")!=0) {        /* only valid channel == stdin       */
  401.     heap(2);
  402.         topfun(cfunSearchError);
  403.     topfun(cfunFailure);
  404.     }
  405.     else if (stdinUsed) {        /* can't reuse stdin channel       */
  406.     heap(2);
  407.     topfun(cfunReadError);
  408.     topfun(cfunFailure);
  409.     }
  410.     else {                /* otherwise we can read from stdin*/
  411.     stdinUsed = 1;
  412.     pushed(0) = cfunFalse;/*dummy*/
  413.     heap(2);
  414.         topfun(primInput);
  415.     topfun(cfunStr);
  416.     }
  417. }
  418.  
  419. static comb1(pr_Input)            /* input from stdin primitive       */
  420. {   Int c = readTerminalChar();
  421.     if (c==EOF || c<0 || c>=NUM_CHARS) {
  422.     clearerr(stdin);
  423.     update(0,cfunNil);
  424.     }
  425.     else {
  426.     needStack(1);
  427.     heap(1);
  428.     pushpair(primInput,cfunNil);
  429.     updap(0,consCharArray[c<0 ? c+NUM_CHARS : c],pop());
  430.     }
  431.     ret();
  432. }
  433. End
  434.  
  435. static comb3(pr_Fopen)            /* open file for reading as str       */
  436. {   String s = evalName(offset(3));    /*  :: String->a->(String->a)->a   */
  437.  
  438.     if (s) {
  439.     Cell file = openFile(s);
  440.     if (file!=cfunNil) {
  441.         updap(0,offset(1),file);
  442.         ret();
  443.     }
  444.     }
  445.     update(0,offset(2));
  446.     ret();
  447. }
  448. End
  449.  
  450. static Void appendChan() {        /* respond to AppendChan request   */
  451.     String s    = evalName(pushed(0));    /* pushed(0) = channel name string */
  452.     FILE   *fp;                /* pushed(1) = contents           */
  453.                     /* pushed(2) = rest of program       */
  454.  
  455.     if ((fp=validOutChannel(s))==0) {    /* problem with output channel       */
  456.     heap(2);
  457.     topfun(cfunSearchError);
  458.     topfun(cfunFailure);
  459.     slide(1,top());
  460.     }
  461.     else {                /* otherwise do output           */
  462.     drop();
  463.     outputString(fp,pop());
  464.     onto(cfunSuccess);
  465.     }
  466. }
  467.  
  468. static FILE *validOutChannel(s)        /* return FILE * for valid output  */
  469. String s; {                /* channel name or 0 otherwise...  */
  470.     if (strcmp(s,"stdout")==0)
  471.     return stdout;
  472.     if (strcmp(s,"stderr")==0)
  473.     return stderr;
  474.     if (strcmp(s,"stdecho")==0)        /* in Gofer, stdecho==stdout       */
  475.     return stdout;
  476.     return 0;
  477. }
  478.  
  479. /* --------------------------------------------------------------------------
  480.  * Environment requests:
  481.  * ------------------------------------------------------------------------*/
  482.  
  483. static Void echo() {            /* respond to Echo request       */
  484.                     /* pushed(0) = boolean echo status */
  485.                     /* pushed(1) = rest of program       */
  486.  
  487.     if (stdinUsed) {            /* stdin already used?           */
  488.     heap(3);
  489.     top() = mkString("stdin already in use");
  490.     topfun(cfunOtherError);
  491.     topfun(cfunFailure);
  492.     }
  493.     else if (echoChanged) {        /* echo previously changed?       */
  494.     heap(3);
  495.     top() = mkString("repeated Echo request");
  496.     topfun(cfunOtherError);
  497.     topfun(cfunFailure);
  498.     }
  499.     else {                /* otherwise evaluate and carry       */
  500.     eval(top());            /* out request               */
  501.     if (whnf==cfunFalse)
  502.         noechoTerminal();
  503.     echoChanged = 1;
  504.         top() = cfunSuccess;
  505.     }
  506. }
  507.  
  508. static Void getArgs() {            /* respond to GetArgs request       */
  509.     int i = keep_argc;
  510.  
  511.     push(cfunNil);            /* build list of args in reverse   */
  512.     while (1<i--) {
  513.     heap(3);
  514.     pushStr(keep_argv[i]);
  515.     topfun(cfunCons);
  516.     mkap();
  517.     }
  518.     heap(1);
  519.     topfun(cfunStrList);        /* and add StrList constructor       */
  520. }
  521.  
  522. static Void getProgName() {        /* respond to GetProgName request  */
  523.     if (keep_argc>=1 && keep_argv[0]) {    /* normally, just return argv[0]   */
  524.     pushStr(keep_argv[0]);
  525.     topfun(cfunStr);
  526.     }
  527.     else {
  528.     push(cfunNil);            /* return Failure (OtherError "")  */
  529.     topfun(cfunOtherError);
  530.     topfun(cfunFailure);
  531.     }
  532. }
  533.  
  534. static Void getEnv() {            /* repond to GetEnv request       */
  535.     String s = evalName(pushed(0));    /* pushed(0) = variable name str   */
  536.     String r = getenv(s);        /* pushed(1) = rest of program       */
  537.     if (r) {
  538.     pushStr(r);
  539.     topfun(cfunStr);
  540.     }
  541.     else {
  542.     topfun(cfunSearchError);
  543.     topfun(cfunFailure);
  544.     }
  545. }
  546.  
  547. /* --------------------------------------------------------------------------
  548.  * Top-level printing mechanism:
  549.  * ------------------------------------------------------------------------*/
  550.  
  551. static Void outputString(fp,cs)        /* Evaluate string cs and print       */
  552. FILE *fp;                /* on specified output stream fp   */
  553. Cell cs; {
  554.     eval(cs);                /* keep reducing and printing head */
  555.     while (whnf==cfunCons) {
  556.     eval(pop());            /* evaluate character           */
  557.     fputc(charOf(whnf),fp);
  558.     /*fflush(fp);*/
  559.     eval(pop());            /* evaluate rest of string       */
  560.     }
  561.     if (whnf!=cfunNil)            /* check for proper end of string  */
  562.     abandon("type error in string");
  563. }
  564.  
  565. /* --------------------------------------------------------------------------
  566.  * Evaluate name, obtaining a C string from a Gofer string:
  567.  * ------------------------------------------------------------------------*/
  568.  
  569. static String evalName(es)        /* evaluate es :: [Char] and save  */
  570. Cell es; {                /* in char array... return ptr to  */
  571.     static char buffer[FILENAME_MAX+1];    /* string or 0, if error occurs       */
  572.     Int         pos    = 0;
  573.  
  574.     eval(es);
  575.     while (whnf==cfunCons && pos<FILENAME_MAX) {
  576.     eval(pop());
  577.     buffer[pos++] = charOf(whnf);
  578.     eval(pop());
  579.     }
  580.     if (pos>=FILENAME_MAX)        /* perhaps name was too long?       */
  581.     abandon("name too long");
  582.     if (whnf!=cfunNil)            /* check for proper end of string  */
  583.     abandon("type error in name");
  584.     buffer[pos] = '\0';
  585.     return buffer;
  586. }
  587.  
  588. /* --------------------------------------------------------------------------
  589.  * Builtin primitive functions:
  590.  * ------------------------------------------------------------------------*/
  591.  
  592. static comb2(pr_FATBAR)            /* FAIL `FATBAR` r = r           */
  593.     eval(offset(2));            /* l    `FATBAR` r = l           */
  594.     update(0,offset(whnf==FAIL?1:2));
  595.     ret();
  596. End
  597.  
  598. static comb0(pr_FAIL)            /* Pattern matching/guard failure  */
  599.     update(0,FAIL);
  600.     ret();
  601. End
  602.  
  603. static comb0(pr_UNDEFMEM)        /* undefined member           */
  604.     abandon("undefined member function");
  605.     ret();/*not reached*/
  606. End
  607.  
  608. static comb0(pr_BlackHole)        /* garbage collector black hole       */
  609.     abandon("{GC black hole detected}");
  610.     ret();/* not reached */
  611. End
  612.  
  613. static comb3(pr_SEL)            /* component selection           */
  614.     eval(offset(2));            /* _SEL c e n ==> nth component in */
  615.     if (whnf==offset(3)) {        /* expression e built using cfun c */
  616.     update(0,pushed(intOf(offset(1))-1));
  617.     }
  618.     else
  619.     abandon("pattern matching");
  620.     ret();
  621. End
  622.  
  623. static comb3(pr_IF)            /* conditional primitive       */
  624.     eval(offset(3));
  625.     if (whnf==cfunTrue) {
  626.     update(0,offset(2));
  627.     }
  628.     else {
  629.     update(0,offset(1));
  630.     }
  631.     ret();
  632. End
  633.  
  634. static comb2(pr_STRICT)            /* strict application primitive       */
  635.     eval(offset(1));
  636.     updap(0,offset(2),offset(1));
  637.     ret();
  638. End
  639.  
  640. static comb1(pr_Error)            /* error primitive           */
  641.     fputs("\nprogram error: ",stderr);
  642.     outputString(stderr,pop());
  643.     fputc('\n',stderr);
  644.     leave(1);
  645. End
  646.  
  647. /* --------------------------------------------------------------------------
  648.  * Integer arithmetic primitives:
  649.  * ------------------------------------------------------------------------*/
  650.  
  651. static comb2(pr_PlusInt)        /* integer addition primitive       */
  652. {   Int x;
  653.     eval(offset(2));
  654.     x = whnfInt;
  655.     eval(offset(1));
  656.     heap(1);
  657.     update(0,mkInt(x+whnfInt));
  658.     ret();
  659. }
  660. End
  661.  
  662. static comb2(pr_MinusInt)        /* integer subtraction primitive   */
  663. {   Int x;
  664.     eval(offset(2));
  665.     x = whnfInt;
  666.     eval(offset(1));
  667.     heap(1);
  668.     update(0,mkInt(x-whnfInt));
  669.     ret();
  670. }
  671. End
  672.  
  673. static comb2(pr_MulInt)            /* integer multiplication primitive*/
  674. {   Int x;
  675.     eval(offset(2));
  676.     x = whnfInt;
  677.     eval(offset(1));
  678.     heap(1);
  679.     update(0,mkInt(x*whnfInt));
  680.     ret();
  681. }
  682. End
  683.  
  684. static comb2(pr_DivInt)            /* integer division primitive       */
  685. {   Int x,y;                /* truncate towards -ve infinity   */
  686.     eval(offset(2));
  687.     x = whnfInt;
  688.     eval(offset(1));
  689.     if (whnfInt==0)
  690.     abandon("division by zero");
  691.     heap(1);
  692.     y = x%whnfInt;
  693.     x = x/whnfInt;
  694.     if ((y<0 && whnfInt>0) || (y>0 && whnfInt<0))
  695.     x--;
  696.     update(0,mkInt(x));
  697.     ret();
  698. }
  699. End
  700.  
  701. static comb2(pr_QuotInt)        /* integer division primitive       */
  702. {   Int x;                /* truncated towards zero       */
  703.     eval(offset(2));
  704.     x = whnfInt;
  705.     eval(offset(1));
  706.     if (whnfInt==0)
  707.     abandon("division by zero");
  708.     heap(1);
  709.     update(0,mkInt(x/whnfInt));
  710.     ret();
  711. }
  712. End
  713.  
  714. static comb2(pr_ModInt)            /* integer modulo primitive       */
  715. {   Int x,y;
  716.     eval(offset(2));
  717.     x = whnfInt;
  718.     eval(offset(1));
  719.     if (whnfInt==0)
  720.     abandon("division by zero");
  721.     heap(1);
  722.     y = x%whnfInt;            /* "... the modulo having the sign */
  723.     if ((y<0 && whnfInt>0) ||        /*           of the divisor ..." */
  724.     (y>0 && whnfInt<0)) {        /* See definition on p.81 of       */
  725.     update(0,mkInt(y+whnfInt));    /* Haskell report...           */
  726.     }
  727.     else {
  728.     update(0,mkInt(y));
  729.     }
  730.     ret();
  731. }
  732. End
  733.  
  734. static comb2(pr_RemInt)            /* integer remainder primitive       */
  735. {   Int x;
  736.     eval(offset(2));            /* div and rem satisfy:           */
  737.     x = whnfInt;            /* (x `div` y)*y+(x `rem` y) == x  */
  738.     eval(offset(1));            /* which is exactly the property   */
  739.     if (whnfInt==0)            /* described in K&R 2:           */
  740.     abandon("division by zero");    /*      (a/b)*b + a%b == a       */
  741.     heap(1);
  742.     update(0,mkInt(x%whnfInt));
  743.     ret();
  744. }
  745. End
  746.  
  747. static comb1(pr_NegInt)            /* integer negation primitive       */
  748.     eval(offset(1));
  749.     heap(1);
  750.     update(0,mkInt(-whnfInt));
  751.     ret();
  752. End
  753.  
  754. /* --------------------------------------------------------------------------
  755.  * Coercion primitives:
  756.  * ------------------------------------------------------------------------*/
  757.  
  758. static comb1(pr_CharToInt)        /* character to integer conversion */
  759.     eval(offset(1));
  760.     heap(1);
  761.     update(0,mkInt(charOf(whnf)));
  762.     ret();
  763. End
  764.  
  765. static comb1(pr_IntToChar)        /* integer to character conversion */
  766.     eval(offset(1));
  767.     if (whnfInt<0 || whnfInt>=NUM_CHARS)
  768.     abandon("character out of range");
  769.     update(0,mkChar(whnfInt));
  770.     ret();
  771. End
  772.  
  773. static comb1(pr_IntToFloat)        /* integer to float primitive       */
  774.     eval(offset(1));
  775.     heap(1);
  776.     update(0,mkFloat((Float)(whnfInt)));
  777.     ret();
  778. End
  779.  
  780. /* --------------------------------------------------------------------------
  781.  * Float arithmetic primitives:
  782.  * ------------------------------------------------------------------------*/
  783.  
  784. static comb2(pr_PlusFloat)        /* float addition primitive       */
  785. {   Float x;
  786.     eval(offset(2));
  787.     x = floatOf(whnf);
  788.     eval(offset(1));
  789.     heap(1);
  790.     update(0,mkFloat(x+floatOf(whnf)));
  791.     ret();
  792. }
  793. End
  794.  
  795. static comb2(pr_MinusFloat)        /* float subtraction primitive       */
  796. {   Float x;
  797.     eval(offset(2));
  798.     x = floatOf(whnf);
  799.     eval(offset(1));
  800.     heap(1);
  801.     update(0,mkFloat(x-floatOf(whnf)));
  802.     ret();
  803. }
  804. End
  805.  
  806. static comb2(pr_MulFloat)        /* float multiplication primitive  */
  807. {   Float x;
  808.     eval(offset(2));
  809.     x = floatOf(whnf);
  810.     eval(offset(1));
  811.     heap(1);
  812.     update(0,mkFloat(x*floatOf(whnf)));
  813.     ret();
  814. }
  815. End
  816.  
  817. static comb2(pr_DivFloat)        /* float division primitive       */
  818. {   Float x;
  819.     eval(offset(2));
  820.     x = floatOf(whnf);
  821.     eval(offset(1));
  822.     if (floatOf(whnf)==0)
  823.     abandon("float division by zero");
  824.     heap(1);
  825.     update(0,mkFloat(x/floatOf(whnf)));
  826.     ret();
  827. }
  828. End
  829.  
  830. static comb1(pr_NegFloat)        /* float negation primitive       */
  831.     eval(offset(1));
  832.     heap(1);
  833.     update(0,mkFloat(-floatOf(whnf)));
  834.     ret();
  835. End
  836.  
  837. #if HAS_FLOATS
  838. #define FPRIM(n,f)        static comb1(n)                    \
  839.                     eval(offset(1));                \
  840.                     heap(1);                    \
  841.                     update(0,safeMkFloat(f(floatOf(whnf))));\
  842.                     ret();                    \
  843.                 End
  844. FPRIM(pr_SinFloat,sin)            /* floating point math prims       */
  845. FPRIM(pr_CosFloat,cos)
  846. FPRIM(pr_TanFloat,tan)
  847. FPRIM(pr_AsinFloat,asin)
  848. FPRIM(pr_AcosFloat,acos)
  849. FPRIM(pr_AtanFloat,atan)
  850. FPRIM(pr_LogFloat,log)            /* one day, I should expand these  */
  851. FPRIM(pr_Log10Float,log10)        /* to ensure the argument is > 0   */
  852. FPRIM(pr_ExpFloat,exp)
  853. FPRIM(pr_SqrtFloat,sqrt)
  854. #undef FPRIM
  855.  
  856. static comb2(pr_Atan2Float)        /* arc tan with quadrant info       */
  857. {   Float x;
  858.     eval(offset(2));
  859.     x = floatOf(whnf);
  860.     eval(offset(1));
  861.     heap(1);
  862.     update(0,mkFloat(atan2(x,floatOf(whnf))));
  863.     ret();
  864. }
  865. End
  866.  
  867. static comb1(pr_FloatToInt)        /* convert floating point to int   */
  868.     eval(offset(1));            /* :: Float -> Int           */
  869.     heap(1);
  870.     update(0,mkFloat((Float)(whnfInt)));
  871.     ret();
  872. End
  873. #endif
  874.  
  875. /* --------------------------------------------------------------------------
  876.  * Comparison primitives:
  877.  * ------------------------------------------------------------------------*/
  878.  
  879. static comb2(pr_EqInt)            /* integer equality primitive       */
  880. {   Int x;
  881.     eval(offset(2));
  882.     x = whnfInt;
  883.     eval(offset(1));
  884.     update(0,(x==whnfInt ? cfunTrue : cfunFalse));
  885.     ret();
  886. }
  887. End
  888.  
  889. static comb2(pr_LeInt)            /* integer <= primitive           */
  890. {   Int x;
  891.     eval(offset(2));
  892.     x = whnfInt;
  893.     eval(offset(1));
  894.     update(0,(x<=whnfInt ? cfunTrue : cfunFalse));
  895.     ret();
  896. }
  897. End
  898.  
  899. static comb2(pr_EqChar)            /* character equality primitive       */
  900. {   Cell x;
  901.     eval(offset(2));
  902.     x = whnf;
  903.     eval(offset(1));
  904.     update(0,(x==whnf ? cfunTrue : cfunFalse));
  905.     ret();
  906. }
  907. End
  908.  
  909. static comb2(pr_LeChar)            /* character <= primitive       */
  910. {   Cell x;
  911.     eval(offset(2));
  912.     x = whnf;
  913.     eval(offset(1));
  914.     update(0,(x<=whnf ? cfunTrue : cfunFalse));
  915.     ret();
  916. }
  917. End
  918.  
  919. static comb2(pr_EqFloat)        /* float equality primitive       */
  920. {   Float x;
  921.     eval(offset(2));
  922.     x = floatOf(whnf);
  923.     eval(offset(1));
  924.     update(0,(x==floatOf(whnf) ? cfunTrue : cfunFalse));
  925.     ret();
  926. }
  927. End
  928.  
  929. static comb2(pr_LeFloat)        /* float <= primitive           */
  930. {   Float x;
  931.     eval(offset(2));
  932.     x = floatOf(whnf);
  933.     eval(offset(1));
  934.     update(0,(x<=floatOf(whnf) ? cfunTrue : cfunFalse));
  935.     ret();
  936. }
  937. End
  938.  
  939. /* --------------------------------------------------------------------------
  940.  * Generic comparison primitives:
  941.  *
  942.  * The following primitives are provided for the benefit of anyone that
  943.  * wants to use Gofer's generic comparison functions in place of the
  944.  * type class alternative.  Be warned however, that an attempt to compare
  945.  * two function values using these routines will generate a runtime error
  946.  * which will not be trapped unless you compile the runtime system and
  947.  * application with ARGCHECK=1 (in which case, the overall performance
  948.  * will degrade, even if you never actually do compare function values).
  949.  * You see, using type classes really can bring benefits ...       :-)
  950.  *
  951.  * (The hardest thing in the following code is ensuring that all of the
  952.  * appropriate temporary variables stay on the stack to ensure proper
  953.  * operation of the garbage collector.)
  954.  * ------------------------------------------------------------------------*/
  955.  
  956. #define LT 0
  957. #define EQ 1
  958. #define GT 2
  959.  
  960. static Int compare() {            /* Shared auxiliary function       */
  961.     StackPtr args = sp;            /* for generic comparisons       */
  962.     Int      xy;
  963.  
  964.     pushed(1) = pair(pushed(1),cfunNil);/* turn arguments into lists       */
  965.     pushed(0) = pair(pushed(0),cfunNil);/* simulating depth-first stack       */
  966.  
  967.     do {
  968.     Int xdepth, ydepth;
  969.  
  970.     eval(fst(pushed(0)));        /* evaluate part of `x'           */
  971.         push(whnf);
  972.     xdepth = pushedSince(args);
  973.  
  974.     eval(fst(pushed(1+xdepth)));    /* evaluate part of `y'           */
  975.     push(whnf);
  976.     ydepth = pushedSince(args) - xdepth;
  977.  
  978.     xy         = xdepth+ydepth;    /* discard values on top of depth- */
  979.     pushed(xy)   = snd(pushed(xy));    /* first stacks               */
  980.     pushed(xy+1) = snd(pushed(xy+1));
  981.  
  982.         /* If the whnf of the part of x is   X x1 ... xn
  983.      * and the whnf of the part of y is  Y y1 ... ym,
  984.      * then the top of the stack will look like this:
  985.      *
  986.      *    top() =    Y  \
  987.      *        y1  |
  988.      *        .   |    ydepth elements
  989.      *        .   |
  990.      *        ym /
  991.      *        X  \
  992.      *        x1  |
  993.      *        .   |    xdepth elements
  994.      *        .   |
  995.      *        xn /
  996.      *        xs
  997.      *        ys
  998.      */
  999.  
  1000.     if (isPair(top()) || isPair(pushed(ydepth))) {
  1001.         if (isPair(top()) && fst(top())==FLOATCELL) {    /* Floats  */
  1002.         Float xf = floatOf(pushed(ydepth));
  1003.         Float yf = floatOf(top());
  1004.         if (xf<yf) return LT;
  1005.         if (xf>yf) return GT;
  1006.         }
  1007.         else {                        /* Ints       */
  1008.         Int xi = intOf(pushed(ydepth));
  1009.         Int yi = intOf(top());
  1010.         if (xi<yi) return LT;
  1011.         if (xi>yi) return GT;
  1012.         }
  1013.     }
  1014.     else {                /* two proper constructor applics  */
  1015.         if (top()>pushed(ydepth))    /* x structure has smaller constr  */
  1016.         return LT;
  1017.         if (top()<pushed(ydepth))    /* y structure has smaller constr  */
  1018.         return GT;
  1019.         if (xdepth!=ydepth)
  1020.         abandon("type error in comparison");
  1021.         else {
  1022.         Int i;
  1023.         for (i=ydepth-1; i>0; --i) {        /* add new values  */
  1024.             pushed(xy+1) = pair(pushed(i),pushed(xy+1));
  1025.             pushed(xy)   = pair(pushed(i+ydepth),pushed(xy));
  1026.         }
  1027.         }
  1028.     }
  1029.     sp = args;
  1030.     } while (isPair(top()));        /* loop if value queue not empty*/
  1031.  
  1032.     return EQ;                /* everything matched, so x==y  */
  1033. }
  1034.  
  1035. #define genericPrim(n,bool)    static comb2(n)                   \
  1036.                     update(0,bool ? cfunTrue : cfunFalse); \
  1037.                     ret();                   \
  1038.                 End
  1039. genericPrim(pr_GenericEq, compare()==EQ)
  1040. genericPrim(pr_GenericNe, compare()!=EQ)
  1041. genericPrim(pr_GenericLt, compare()==LT)
  1042. genericPrim(pr_GenericLe, compare()!=GT)
  1043. genericPrim(pr_GenericGt, compare()==GT)
  1044. genericPrim(pr_GenericGe, compare()!=LT)
  1045. #undef genericPrim
  1046.  
  1047. /* --------------------------------------------------------------------------
  1048.  * Print primitives:
  1049.  * ------------------------------------------------------------------------*/
  1050.  
  1051. static comb3(pr_ShowsInt)        /* find string rep. for integer       */
  1052. {   Int num;                /*  :: Int -> Int -> ShowS       */
  1053.     drop();                /* throw away first parameter       */
  1054.     eval(pop());
  1055.     num = whnfInt;
  1056.  
  1057.     if (0<=num && num<10) {                /* single digit       */
  1058.     updap(0,consCharArray['0'+num],top());
  1059.     }
  1060.     else if (num<0) {                    /* negative integer*/
  1061.     num = -num;
  1062.     do {
  1063.         heap(1);
  1064.         topfun(consCharArray['0'+num%10]);
  1065.     } while ((num/=10)>0);
  1066.     updap(0,consCharArray['-'],top());
  1067.     }
  1068.     else {                        /* positive integer*/
  1069.     do {
  1070.         heap(1);
  1071.         topfun(consCharArray['0'+num%10]);
  1072.     } while ((num/=10)>9);
  1073.     updap(0,consCharArray['0'+num],top());
  1074.     }
  1075.     ret();
  1076. }
  1077. End
  1078.  
  1079. static comb3(pr_ShowsFloat)        /* find string rep. for float       */
  1080. {   String s;                /*  :: Int -> Float -> ShowS       */
  1081.     Int    n;
  1082.     drop();                /* throw away first parameter       */
  1083.     eval(pop());
  1084.     s = floatToString(floatOf(whnf));
  1085.     n = strlen(s);
  1086.     while (1<n--) {
  1087.     heap(1);
  1088.     topfun(consCharArray[s[n]]);
  1089.     }
  1090.     updap(0,consCharArray[*s],top());
  1091.     ret();
  1092. }
  1093. End
  1094.  
  1095. /* --------------------------------------------------------------------------
  1096.  * Storage, initialisation and marking of primitives:
  1097.  * ------------------------------------------------------------------------*/
  1098.  
  1099. Cell primFatbar,     primFail;        /* System (internal) primitives       */
  1100. Cell primUndefMem,   primBlackHole;
  1101. Cell primSel,         primIf;
  1102. Cell primStrict;
  1103.  
  1104. Cell primPlusInt,    primMinusInt;    /* User (general) primitives       */
  1105. Cell primMulInt,     primDivInt;
  1106. Cell primModInt,     primRemInt;
  1107. Cell primNegInt,     primQuotInt;
  1108. Cell primCharToInt,  primIntToChar;
  1109. Cell primIntToFloat;
  1110. Cell primPlusFloat,  primMinusFloat;
  1111. Cell primMulFloat,   primDivFloat;
  1112. Cell primNegFloat;
  1113. Cell primEqInt,         primLeInt;
  1114. Cell primEqChar,     primLeChar;
  1115. Cell primEqFloat,    primLeFloat;
  1116. Cell primGenericEq,  primGenericNe;
  1117. Cell primGenericGt,  primGenericGe;
  1118. Cell primGenericLt,  primGenericLe;
  1119. Cell primShowsInt,   primShowsFloat;
  1120. Cell primError;
  1121.  
  1122. #if  HAS_FLOATS
  1123. Cell primSinFloat,   primAsinFloat;
  1124. Cell primCosFloat,   primAcosFloat;
  1125. Cell primTanFloat,   primAtanFloat;
  1126. Cell primAtan2Float, primExpFloat;
  1127. Cell primLogFloat,   primLog10Float;
  1128. Cell primSqrtFloat,  primFloatToInt;
  1129. #endif
  1130.  
  1131. Cell primFopen;                /* read from file primitive       */
  1132.  
  1133. static Void primInit() {        /* initialise primitives       */
  1134.     primFatbar       = mkSuper(pr_FATBAR);
  1135.     primFail       = mkSuper(pr_FAIL);
  1136.     primUndefMem   = mkSuper(pr_UNDEFMEM);
  1137.     primBlackHole  = mkSuper(pr_BlackHole);
  1138.     primSel       = mkSuper(pr_SEL);
  1139.     primIf       = mkSuper(pr_IF);
  1140.     primStrict       = mkSuper(pr_STRICT);
  1141.     primPlusInt       = mkSuper(pr_PlusInt);
  1142.     primMinusInt   = mkSuper(pr_MinusInt);
  1143.     primMulInt       = mkSuper(pr_MulInt);
  1144.     primDivInt       = mkSuper(pr_DivInt);
  1145.     primQuotInt       = mkSuper(pr_QuotInt);
  1146.     primModInt       = mkSuper(pr_ModInt);
  1147.     primRemInt       = mkSuper(pr_RemInt);
  1148.     primNegInt       = mkSuper(pr_NegInt);
  1149.     primCharToInt  = mkSuper(pr_CharToInt);
  1150.     primIntToChar  = mkSuper(pr_IntToChar);
  1151.     primIntToFloat = mkSuper(pr_IntToFloat);
  1152.     primPlusFloat  = mkSuper(pr_PlusFloat);
  1153.     primMinusFloat = mkSuper(pr_MinusFloat);
  1154.     primMulFloat   = mkSuper(pr_MulFloat);
  1155.     primDivFloat   = mkSuper(pr_DivFloat);
  1156.     primNegFloat   = mkSuper(pr_NegFloat);
  1157.     primEqInt       = mkSuper(pr_EqInt);
  1158.     primLeInt       = mkSuper(pr_LeInt);
  1159.     primEqChar       = mkSuper(pr_EqChar);
  1160.     primLeChar       = mkSuper(pr_LeChar);
  1161.     primEqFloat       = mkSuper(pr_EqFloat);
  1162.     primLeFloat       = mkSuper(pr_LeFloat);
  1163.     primGenericEq  = mkSuper(pr_GenericEq);
  1164.     primGenericNe  = mkSuper(pr_GenericNe);
  1165.     primGenericGt  = mkSuper(pr_GenericGt);
  1166.     primGenericGe  = mkSuper(pr_GenericGe);
  1167.     primGenericLt  = mkSuper(pr_GenericLt);
  1168.     primGenericLe  = mkSuper(pr_GenericLe);
  1169.     primShowsInt   = mkSuper(pr_ShowsInt);
  1170.     primShowsFloat = mkSuper(pr_ShowsFloat);
  1171.     primError      = mkSuper(pr_Error);
  1172.     primInput       = mkSuper(pr_Input);
  1173.     primFopen      = mkSuper(pr_Fopen);
  1174. #if HAS_FLOATS
  1175.     primSinFloat   = mkSuper(pr_SinFloat);
  1176.     primAsinFloat  = mkSuper(pr_AsinFloat);
  1177.     primCosFloat   = mkSuper(pr_CosFloat);
  1178.     primAcosFloat  = mkSuper(pr_AcosFloat);
  1179.     primTanFloat   = mkSuper(pr_TanFloat);
  1180.     primAtanFloat  = mkSuper(pr_AtanFloat);
  1181.     primAtan2Float = mkSuper(pr_Atan2Float);
  1182.     primExpFloat   = mkSuper(pr_ExpFloat);
  1183.     primLogFloat   = mkSuper(pr_LogFloat);
  1184.     primLog10Float = mkSuper(pr_Log10Float);
  1185.     primSqrtFloat  = mkSuper(pr_SqrtFloat);
  1186.     primFloatToInt = mkSuper(pr_FloatToInt);
  1187. #endif
  1188. }
  1189.  
  1190. static Void primMark() {        /* mark primitives           */
  1191.     mark(primFatbar);
  1192.     mark(primFail);
  1193.     mark(primUndefMem);
  1194.     mark(primBlackHole);
  1195.     mark(primSel);
  1196.     mark(primIf);
  1197.     mark(primStrict);
  1198.     mark(primPlusInt);
  1199.     mark(primMinusInt);
  1200.     mark(primMulInt);
  1201.     mark(primDivInt);
  1202.     mark(primQuotInt);
  1203.     mark(primModInt);
  1204.     mark(primRemInt);
  1205.     mark(primNegInt);
  1206.     mark(primCharToInt);
  1207.     mark(primIntToChar);
  1208.     mark(primIntToFloat);
  1209.     mark(primPlusFloat);
  1210.     mark(primMinusFloat);
  1211.     mark(primMulFloat);
  1212.     mark(primDivFloat);
  1213.     mark(primNegFloat);
  1214.     mark(primEqInt);
  1215.     mark(primLeInt);
  1216.     mark(primEqChar);
  1217.     mark(primLeChar);
  1218.     mark(primEqFloat);
  1219.     mark(primLeFloat);
  1220.     mark(primGenericEq);
  1221.     mark(primGenericNe);
  1222.     mark(primGenericGt);
  1223.     mark(primGenericGe);
  1224.     mark(primGenericLt);
  1225.     mark(primGenericLe);
  1226.     mark(primShowsInt);
  1227.     mark(primShowsFloat);
  1228.     mark(primError);
  1229.     mark(primInput);
  1230.     mark(primFopen);
  1231. #if HAS_FLOATS
  1232.     mark(primSinFloat);
  1233.     mark(primAsinFloat);
  1234.     mark(primCosFloat);
  1235.     mark(primAcosFloat);
  1236.     mark(primTanFloat);
  1237.     mark(primAtanFloat);
  1238.     mark(primAtan2Float);
  1239.     mark(primExpFloat);
  1240.     mark(primLogFloat);
  1241.     mark(primLog10Float);
  1242.     mark(primSqrtFloat);
  1243.     mark(primFloatToInt);
  1244. #endif
  1245. }
  1246.  
  1247. /* --------------------------------------------------------------------------
  1248.  * Main program including startup code and initialisation:
  1249.  * ------------------------------------------------------------------------*/
  1250.  
  1251. Main main(argc,argv)            /* entry point and initialisation  */
  1252. int argc;
  1253. char *argv[]; {
  1254.     int i;
  1255.  
  1256.     if (argcheck!=ARGCHECK)        /* consistency check on compilation*/
  1257.     abandon("program linked with wrong runtime support file");
  1258.  
  1259.     keep_argc = argc;            /* save command line arguments       */
  1260.     keep_argv = argv;
  1261.  
  1262.     for (i=0; i<NUM_FILES; i++)        /* initialise file storage       */
  1263.     infiles[i] = 0;
  1264.  
  1265.     clearStack();            /* initialise control stack       */
  1266.  
  1267.     heapInit();                /* initialise heap storage       */
  1268.  
  1269.     for (i=0; i<num_scs; i++)        /* initialise CAF table           */
  1270.     sc[i] = mkSuper(scNames[i]);
  1271.  
  1272.     primInit();                /* initialise primitives       */
  1273.  
  1274.     for (i=num_dicts; --i>0; )        /* initialise dictionaries       */
  1275.     if (dictImps[i]>=0)
  1276.         dict[i] = pair(sc[dictImps[i]],dict[i]);
  1277.  
  1278.     for (i=0; i<NUM_CHARS; ++i)        /* initialise character array       */
  1279.     consCharArray[i] = pair(cfunCons,mkChar(i));
  1280.  
  1281.     ctrlbrk(onBreak);
  1282.     dialogue(sc[num_scs-1]);        /* sc_main is always the last sc   */
  1283.     leave(0);
  1284.     MainDone
  1285. }
  1286.  
  1287. static sigHandler(onBreak) {        /* break handler           */
  1288.     abandon("interrupted");
  1289.     sigResume;/*NOTREACHED*/
  1290. }
  1291.  
  1292. static Void abandon(why)        /* abort execution of program       */
  1293. String why; {
  1294.     fputs("\nprogram aborting: ",stderr);
  1295.     fputs(why,stderr);
  1296.     fputc('\n',stderr);
  1297.     leave(1);
  1298. }
  1299.  
  1300. static Void leave(exitcode)        /* tidy up and exit from program   */
  1301. int exitcode; {
  1302.     normalTerminal();
  1303.     exit(exitcode);
  1304. }
  1305.  
  1306. /*-------------------------------------------------------------------------*/
  1307.