home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / OSK / EFFO / pd6.lzh / SRC / kernel.c < prev    next >
Text File  |  1990-05-08  |  62KB  |  3,179 lines
  1. /*
  2.   C BASED FORTH-83 MULTI-TASKING KERNEL
  3.  
  4.   Copyright (c) 1989 by Mikael R.K. Patel
  5.  
  6.   Computer Aided Design Laboratory (CADLAB)
  7.   Department of Computer and Information Science
  8.   Linkoping University
  9.   S-581 83 LINKOPING
  10.   SWEDEN
  11.  
  12.   Email: mip@ida.liu.se
  13.  
  14.   Started on: 30 June 1988
  15.  
  16.   Last updated on: 11 December 1989
  17.  
  18.   Dependencies:
  19.        (cc) kernel.h, error.h, memory.h and io.c
  20.  
  21.   Description:
  22.        Virtual Forth machine and kernel code supporting multi-tasking of
  23.        light weight processes. A pure 32-bit Forth-83 Standard implementation.
  24.  
  25.        Extended with argument binding and local variables, exception
  26.        handling, queue data management, multi-tasking, symbol hiding and
  27.        casting, forwarding, null terminated string and memory allocation,
  28.        file search paths, and source library module loading.
  29.   
  30.        The kernel does not implement the block word set. All code is
  31.        stored as text files.
  32.  
  33.   Copying:
  34.        This program is free software; you can redistribute it and/or modify
  35.        it under the terms of the GNU General Public License as published by
  36.        the Free Software Foundation; either version 1, or (at your option)
  37.        any later version.
  38.  
  39.        This program is distributed in the hope that it will be useful,
  40.        but WITHOUT ANY WARRANTY; without even the implied warranty of
  41.        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  42.        GNU General Public License for more details.
  43.  
  44.        You should have received a copy of the GNU General Public License
  45.        along with this program; see the file COPYING.  If not, write to
  46.        the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  47.  
  48. */
  49.  
  50. #include "kernel.h"
  51. #include "memory.h"
  52. #include "error.h"
  53. #include "io.h"
  54.  
  55.  
  56. /* EXTERNAL DECLARATIONS */
  57.  
  58. extern void io_dispatch();
  59.  
  60.  
  61. /* INTERNAL FORWARD DECLARATIONS */
  62.  
  63. extern ENTRY terminate;
  64. extern ENTRY toexception;
  65. extern ENTRY kernel_abort;
  66. extern ENTRY span;
  67. extern ENTRY state;
  68. extern ENTRY vocabulary;
  69. extern char  thepad[];
  70. extern char  thetib[];
  71.  
  72.  
  73. /* VOCABULARY LISTING PARAMETERS */
  74.  
  75. #define COLUMNWIDTH 15
  76. #define LINEWIDTH 75
  77.  
  78.  
  79. /* CONTROL STRUCTURE MARKERS */
  80.  
  81. #define ELSE 1
  82. #define THEN 2
  83. #define AGAIN 4
  84. #define UNTIL 8
  85. #define WHILE 16
  86. #define REPEAT 32
  87. #define LOOP 64
  88. #define PLUSLOOP 128
  89. #define OF 256
  90. #define ENDOF 512
  91. #define ENDCASE 1024
  92. #define SEMICOLON 2048
  93.  
  94.  
  95. /* MULTI-TASKING MACHINE REGISTERS */
  96.  
  97. long verbose;                  /* Application or programming mode */
  98. long quited;                   /* Interpreter toploop state */
  99. long running;                  /* Task switch flag */
  100. long tasking;                  /* Multi-tasking flag */
  101.  
  102. TASK *tp;                      /* Task pointer */
  103. TASK *foreground;              /* Foreground task pointer */
  104.  
  105.  
  106. /* FORTH MACHINE REGISTERS */
  107.  
  108. long tos;                      /* Top of stack register */
  109. long *sp;                      /* Parameter stack pointer */
  110. long *s0;                      /* Bottom of parameter stack pointer */
  111.  
  112. long *ip;                      /* Instruction pointer */
  113. long *rp;                      /* Return stack pointer */
  114. long *r0;                      /* Bottom of return stack pointer */
  115.  
  116. long *fp;                      /* Argument frame pointer */
  117. long *ep;                      /* Exception frame pointer */
  118.  
  119.  
  120. /* VOCABULARY SEARCH LISTS */
  121.  
  122. #define CONTEXTSIZE 32
  123.  
  124. static ENTRY *current = &forth;
  125. static ENTRY *context[CONTEXTSIZE] = {&forth};
  126.  
  127.  
  128. /* ENTRY LOOKUP CACHE, SIZE AND HASH FUNCTION */
  129.  
  130. #define CACHESIZE 256
  131. #define hash(s) ((s[0] + (s[1] << 4)) & (CACHESIZE - 1))
  132.  
  133. static ENTRY *cache[CACHESIZE];
  134.  
  135.  
  136. /* DICTIONARY AREA FOR THREADED CODE AND DATA */
  137.  
  138. long *dictionary;
  139. long *dp;
  140.  
  141.  
  142. /* INTERNAL STRUCTURE SIZES */
  143.  
  144. #define PADSIZE 84
  145. #define TIBSIZE 256
  146.     
  147.  
  148. /* INNER MULTI-TASKING FORTH VIRTUAL MACHINE */
  149.  
  150. void doinner()
  151. {
  152.     long e;
  153.  
  154.     /* Exception marking and handler */
  155.     if (e = setjmp(restart)) {
  156.        spush(e);
  157.        doraise();
  158.     }
  159.     
  160.     /* Run virtual machine until task switch */
  161.     running = TRUE;
  162.     while (running) {
  163.  
  164.        /* Fetch next thread to execute */
  165.        ENTRY *p = (ENTRY *) *ip++;
  166.  
  167.        /* Select on type of entry */
  168.        switch (p -> code) {
  169.          case CODE:
  170.            ((void (*)()) (p -> parameter))(); 
  171.            break;
  172.          case COLON:
  173.            rpush(ip);
  174.            jump(p -> parameter);
  175.            break;
  176.          case VARIABLE:
  177.            spush(&(p -> parameter));
  178.            break;
  179.          case CONSTANT:
  180.            spush(p -> parameter);
  181.            break;
  182.          case VOCABULARY:
  183.            doappend(p);
  184.            break;
  185.          case CREATE:
  186.            spush(p -> parameter);
  187.            break;
  188.          case USER:
  189.            spush(tp + p -> parameter);
  190.            break;
  191.          case LOCAL:
  192.            spush(*((long *) (long) fp - p -> parameter));
  193.            break;
  194.          case FORWARD:
  195.            if (p -> parameter)
  196.                docall((ENTRY *) p -> parameter);
  197.            else {
  198.                (void) printf("%s: unresolved forward entry\n", p -> name);
  199.                doabort();
  200.            }
  201.            break;
  202.          case EXCEPTION:
  203.            spush(p);
  204.            break;
  205.          case FIELD:
  206.            tos = p -> parameter + tos;
  207.            break;
  208.          default: /* DOES: FORTH LEVEL INTERPRETATION */
  209.            rpush(ip);
  210.            spush(p -> parameter);
  211.            jump(p -> code);
  212.            break;
  213.        }
  214.     }
  215. }
  216.  
  217. void docommand()
  218. {
  219.     long e;
  220.  
  221.     /* Exception marking and handler */
  222.     if (e = setjmp(restart)) {
  223.        spush(e);
  224.        doraise();
  225.        return;
  226.     }
  227.  
  228.     /* Execute command on top of stack */
  229.     doexecute();
  230.  
  231.     /* Check if this affects the virtual machine */
  232.     if (rp != r0) {
  233.        tasking = TRUE;
  234.  
  235.        /* Run the virtual machine and allow user extension */
  236.        while (tasking) {
  237.            doinner();
  238.            io_dispatch();
  239.        }
  240.     }
  241. }
  242.  
  243. void docall(p)
  244.     ENTRY *p;
  245. {
  246.     /* Select on type of entry */
  247.     switch (p -> code) {
  248.       case CODE:
  249.        ((void (*)()) (p -> parameter))(); 
  250.        return; 
  251.       case COLON:
  252.        rpush(ip);
  253.        jump(p -> parameter);
  254.        return;
  255.       case VARIABLE:
  256.        spush(&(p -> parameter));
  257.        return;
  258.       case CONSTANT:
  259.        spush(p -> parameter);
  260.        return;
  261.       case VOCABULARY:
  262.        doappend(p);
  263.        return;
  264.       case CREATE:
  265.        spush(p -> parameter);
  266.        return;
  267.       case USER:
  268.        spush(tp + p -> parameter);
  269.        return;
  270.       case LOCAL:
  271.        spush(*((long *) (long) fp - p -> parameter));
  272.        return;
  273.       case FORWARD:
  274.        if (p -> parameter)
  275.            docall((ENTRY *) p -> parameter);
  276.        else {
  277.            (void) printf("%s: unresolved forward entry\n", p -> name);
  278.            doabort();
  279.        }
  280.        return;
  281.       case EXCEPTION:
  282.        spush(p);
  283.        return;
  284.       case FIELD:
  285.        tos = p -> parameter + tos;
  286.        return;
  287.       default: /* DOES: FORTH LEVEL INTERPRETATION */
  288.        rpush(ip);
  289.        spush(p -> parameter);
  290.        jump(p -> code);
  291.        return;
  292.     }
  293. }
  294.  
  295. void doappend(p)
  296.     ENTRY *p;
  297. {
  298.     long v;
  299.     
  300.     /* Flush the entry cache */
  301.     spush(FALSE);
  302.     dorestore();
  303.  
  304.     /* Check if the vocabulary is a member of the current search set */
  305.     for (v = 0; v < CONTEXTSIZE; v++)
  306.  
  307.        /* If a member then rotate the vocabulary first */
  308.        if (p == context[v]) {
  309.            for (; v; v--) context[v] = context[v - 1];
  310.            context[0] = p;
  311.            return;
  312.        }
  313.  
  314.     /* If not a member, then insert first into the search set */
  315.     for (v = CONTEXTSIZE - 1; v > 0; v--) context[v] = context[v - 1];
  316.     context[0] = p;
  317. }    
  318.  
  319.  
  320. /* VOCABULARY ROOT */
  321.  
  322. ENTRY forth = {(ENTRY *) NIL, "forth", NORMAL, VOCABULARY, (long) &vocabulary};
  323.  
  324.  
  325. /* CONTROL: EXTENSION LEVEL DEFINITIONS */
  326.  
  327. void doparenbranch()
  328. {
  329.     branch(*ip);
  330. }
  331.  
  332. COMPILATION_CODE(parenbranch, forth, "(branch)", doparenbranch);
  333.  
  334. void doparenqbranch()
  335. {
  336.     long flag = spop;
  337.     
  338.     /* Check flag on top of stack and branch if false */
  339.     if (flag)
  340.        skip;
  341.     else
  342.        branch(*ip);
  343. }
  344.  
  345. COMPILATION_CODE(parenqbranch, parenbranch, "(?branch)", doparenqbranch);
  346.  
  347. void doparendo()
  348. {
  349.     /* Build a loop frame on return stack */
  350.     rpush(ip++);
  351.     rpush(spop);
  352.     rpush(spop);
  353. }
  354.  
  355. COMPILATION_CODE(parendo, parenqbranch, "(do)", doparendo);
  356.  
  357. void doparenqdo()
  358. {
  359.     /* Check if the start and stop value are equal */
  360.     if (tos == snth(0)) {
  361.  
  362.        /* If equal then branch over the loop block */
  363.        sdrop(1);
  364.        branch(*ip);
  365.     }
  366.     else {
  367.  
  368.        /* else build a loop frame on the return stack */
  369.        rpush(ip++);
  370.        rpush(spop);
  371.        rpush(spop);
  372.     }
  373. }
  374.  
  375. COMPILATION_CODE(parenqdo, parendo, "(?do)", doparenqdo);
  376.  
  377. void doparenloop()
  378. {
  379.     /* Increment the index by one and check if within loop range */
  380.     rnth(1) += 1;
  381.     if (rnth(0) > rnth(1)) {
  382.  
  383.        /* Branch if still within range */
  384.        branch(*ip);
  385.        return;
  386.     }
  387.  
  388.     /* Else remove the loop frame from the return stack and skip */
  389.     rdrop(3);
  390.     skip;
  391.  
  392. }
  393.  
  394. COMPILATION_CODE(parenloop, parenqdo, "(loop)", doparenloop);
  395.  
  396. void doparenplusloop()
  397. {
  398.     long d = spop;
  399.  
  400.     /* Increment the index with the top of stack value */
  401.     rnth(1) += d;
  402.  
  403.     /* Check direction and if the index is still within the loop range */
  404.     if (d > 0) {
  405.        if (rnth(0) > rnth(1)) {
  406.            branch(*ip);
  407.            return;
  408.        }
  409.     }
  410.     else {
  411.        if (rnth(0) < rnth(1)) {
  412.            branch(*ip);
  413.            return;
  414.        }
  415.     }
  416.  
  417.     /* Else remove the loop frame from the return stack and skip */
  418.     rdrop(3);
  419.     skip;
  420. }
  421.  
  422. COMPILATION_CODE(parenplusloop, parenloop, "(+loop)", doparenplusloop);
  423.  
  424.  
  425. /* COMPILATION LITERALS */
  426.  
  427. void doparenliteral()
  428. { 
  429.     spush(*ip++);
  430. }
  431.  
  432. COMPILATION_CODE(parenliteral, parenplusloop, "(literal)", doparenliteral);
  433.  
  434. void doparendotquote()
  435. {
  436.     (void) printf("%s", *ip++);
  437. }
  438.  
  439. COMPILATION_CODE(parendotquote, parenliteral, "(.\")", doparendotquote);
  440.  
  441. void doparenabortquote()
  442. {
  443.     long flag = spop;
  444.     
  445.     /* Check flag on top of stack. If true then abort and give inline message */
  446.     if (flag) {
  447.        doparendotquote();
  448.        doabort();
  449.     }
  450.     else skip;
  451. }
  452.  
  453. COMPILATION_CODE(parenabortquote, parendotquote, "(abort\")", doparenabortquote);
  454.  
  455. void doparensemicolon()
  456. {
  457.     jump(rpop);
  458. }
  459.  
  460. COMPILATION_CODE(parensemicolon, parendotquote, "(;)", doparensemicolon);
  461.  
  462. void doparendoes()
  463. {
  464.     ((ENTRY *) (current -> parameter)) -> code = (long) ip;
  465.     jump(rpop);
  466. }
  467.  
  468. COMPILATION_CODE(parendoes, parensemicolon, "(does>)", doparendoes);
  469.  
  470.  
  471. /* THREADING PRIMITIVES */
  472.  
  473. void dothread()
  474. {
  475.     *dp++ = spop;
  476. }
  477.  
  478. NORMAL_CODE(thread, parendoes, "thread", dothread);
  479.  
  480. void dounthread()
  481. {
  482.     unary(*(long *));
  483. }
  484.  
  485. NORMAL_CODE(unthread, thread, "unthread", dounthread);
  486.  
  487.  
  488. /* COMPILATION: STANDARD EXTENSION LEVEL DEFINITIONS */
  489.  
  490. void doforwardmark()
  491. {
  492.     dohere();
  493.     spush(0);
  494.     docomma();
  495. }
  496.  
  497. COMPILATION_CODE(forwardmark, unthread, ">mark", doforwardmark);
  498.  
  499. void dobackwardmark()
  500. {
  501.     dohere();
  502. }
  503.  
  504. COMPILATION_CODE(backwardmark, forwardmark, "<mark", dobackwardmark);
  505.  
  506. void doforwardresolve()
  507. {
  508.     dohere();
  509.     doover();
  510.     dominus();
  511.     doswap();
  512.     dostore();
  513. }
  514.  
  515. COMPILATION_CODE(forwardresolve, backwardmark, ">resolve", doforwardresolve);
  516.  
  517. void dobackwardresolve()
  518. {
  519.     dohere();
  520.     dominus();
  521.     docomma();
  522. }
  523.  
  524. COMPILATION_CODE(backwardresolve, forwardresolve, "<resolve", dobackwardresolve);
  525.  
  526. NORMAL_VOCABULARY(compiler, forth, "compiler", backwardresolve);
  527.  
  528.  
  529. /* LOCAL VARIABLES AND ARGUMENT BINDING */
  530.  
  531. static ENTRY *theframed = (ENTRY *) NIL;
  532.  
  533. void doremovelocals()
  534. {
  535.     /* Check if the last definition used an argument definition */
  536.     if (theframed) {
  537.        
  538.        /* Restore the vocabulary structure */
  539.        spush(theframed);
  540.        dorestore();
  541.        theframed = (ENTRY *) NIL;
  542.     }
  543. }
  544.  
  545. void doparenlink()  
  546. {
  547.     /* Build an argument and local variable frame */
  548.     spush(tos);
  549.     rpush(fp);
  550.  
  551.     /* Using the two inline values: arguments and local variables */
  552.     fp = sp + *ip++;
  553.     sp = sp - *ip++;
  554.  
  555.     /* Save entry stack pointer to allow result movement on exit */
  556.     rpush(sp);
  557. }
  558.  
  559. COMPILATION_CODE(parenlink, forth, "(link)", doparenlink);
  560.  
  561. void doparenunlink()  
  562. {    
  563.     long *t;
  564.  
  565.     /* Remove the argument and local variable frame */
  566.     t = (long *) rpop;
  567.     spush(tos);
  568.  
  569.     /* And move results to new top of stack */
  570.     for (--t; t > sp; *--fp = *--t);
  571.     sp = fp;
  572.     spop;
  573.  
  574.     /* Restore old frame pointer */
  575.     fp = (long *) rpop;
  576. }
  577.  
  578. COMPILATION_CODE(parenunlink, parenlink, "(unlink)", doparenunlink);
  579.  
  580. void doparenunlinksemicolon() 
  581. {
  582.     long *t;
  583.  
  584.     /* Remove the argument and local variable frame */
  585.     t = (long *) rpop;
  586.     spush(tos);
  587.  
  588.     /* And move results to new top of stack */
  589.     for (--t; t > sp; *--fp = *--t);
  590.     sp = fp;
  591.     spop;
  592.  
  593.     /* Restore old frame pointer */
  594.     fp = (long *) rpop;
  595.  
  596.     /* Return from this colon definition */
  597.     jump(rpop);
  598. }
  599.  
  600. COMPILATION_CODE(parenunlinksemicolon, parenunlink, "(unlink;)", doparenunlinksemicolon);
  601.  
  602. void doparenunlinkdoes()
  603. {
  604.     long *t;
  605.  
  606.     /* Remove the argument and local variable frame */
  607.     t = (long *) rpop;
  608.     spush(tos);
  609.  
  610.     /* And move results to new top of stack */
  611.     for (--t; t > sp; *--fp = *--t);
  612.     sp = fp;
  613.     spop;
  614.  
  615.     /* Restore old frame pointer */
  616.     fp = (long *) rpop;
  617.  
  618.     /* Make the last definition of the following does code */
  619.     ((ENTRY *) ((ENTRY *) current -> parameter)) -> code = (long) ip;
  620.  
  621.     /* Return from this colon definition */
  622.     jump(rpop);
  623. }
  624.  
  625. COMPILATION_CODE(parenunlinkdoes, parenunlinksemicolon, "(unlinkdoes>)", doparenunlinkdoes);
  626.  
  627. void doparenlocal()
  628. {
  629.     spush(((long *) (long) fp - *ip++));
  630. }
  631.  
  632. COMPILATION_CODE(parenlocal, parenunlinkdoes, "(local)", doparenlocal);
  633.  
  634. void doparenlocalstore()
  635. {
  636.     *((long *) (long) fp - *ip++) = spop;
  637. }
  638.  
  639. COMPILATION_CODE(parenlocalstore, parenlocal, "(local!)", doparenlocalstore);
  640.  
  641. void doparenlocalfetch()
  642. {
  643.     spush(*((long *) (long) fp - *ip++));
  644. }
  645.  
  646. COMPILATION_CODE(parenlocalfetch, parenlocalstore, "(local@)", doparenlocalfetch);
  647.  
  648. void doassignlocal()
  649. {
  650.     *((long *) (long) fp - ((ENTRY *) *ip++) -> parameter) = spop;
  651. }
  652.  
  653. COMPILATION_CODE(assignlocal, parenlocalfetch, "->", doassignlocal);
  654.  
  655. COMPILATION_CODE(localexit, assignlocal, "exit", doparenunlinksemicolon);
  656.  
  657. void docurlebracket()
  658. {
  659.     long frameflag = 1;
  660.     long argflag   = 1;
  661.     long arguments = 0;
  662.     long locals    = 0;
  663.  
  664.     /* Check only one active lexical levels allowed */
  665.     if (theframed) {
  666.        (void) printf("%s: illegal argument binding\n", theframed -> name);
  667.        doremovelocals();
  668.        doabort();
  669.        return;
  670.     }
  671.  
  672.     /* Save pointer to latest defintion to allow removal of local names */
  673.     theframed = (ENTRY *) current -> parameter;
  674.  
  675.     /* While the end of the frame description is not found */
  676.     while (frameflag) {
  677.  
  678.        /* Scan the next symbol */
  679.        spush(' ');
  680.        doword();
  681.        if (io_eof()) {
  682.            (void) printf("locals: end of file during scan of parameter list\n");
  683.            doabort();
  684.            return;
  685.        }
  686.  
  687.        /* Check if it marks the end of the argument section */
  688.        if (STREQ(tos, "|")) {
  689.            argflag = 0;
  690.        }
  691.        else {
  692.            /* else check if its the end of the frame description */
  693.             if (STREQ(tos, "}")) {
  694.                frameflag = 0;
  695.            }
  696.            else {
  697.                /* Or the beginning of the return description */
  698.                if (STREQ(tos, "--")) {
  699.                    spop;
  700.                    spush('}');
  701.                    doword();
  702.                    frameflag = 0;
  703.                }
  704.                else {
  705.                    /* If not then make the symbol a local variable */
  706.                    if (argflag)
  707.                        arguments++;
  708.                    else
  709.                        locals++;
  710.                    (void) makeentry((char *) tos,
  711.                                     (long) LOCAL,
  712.                                     (long) COMPILATION,
  713.                                     arguments + locals);
  714.                }
  715.            }
  716.        }
  717.        spop;
  718.     }
  719.  
  720.     /* Compile the parameter binding linkage */
  721.     spush(&parenlink);
  722.     dothread();
  723.  
  724.     /* And the appropriate frame size */
  725.     spush(arguments);
  726.     docomma();
  727.     spush(locals);
  728.     docomma();
  729. }
  730.  
  731. COMPILATION_IMMEDIATE_CODE(curlebracket, localexit, "{", docurlebracket);
  732.  
  733. NORMAL_VOCABULARY(locals, compiler, "locals", curlebracket);
  734.  
  735.  
  736. /* NULL TERMINATED STRINGS */
  737.  
  738. void doparenquote()
  739. {
  740.     spush(*ip++);
  741. }
  742.  
  743. COMPILATION_CODE(parenquote, forth, "(\")", doparenquote);
  744.  
  745. void doquote()
  746. {
  747.     /* Scan for the string if not end of input */
  748.     (void) io_scan(thetib, '"');
  749.  
  750.     /* Make a copy of it */
  751.     spush(thetib);
  752.     dostringcopy();
  753.  
  754.     /* If compilation mode then thread a string literal */
  755.     if (state.parameter) {
  756.        spush(&parenquote);
  757.        dothread();
  758.        docomma();
  759.     }
  760. }
  761.  
  762. IMMEDIATE_CODE(quote, parenquote, "\"", doquote);
  763.  
  764. void dostringlength()
  765. {
  766.     tos = (long) strlen((char *) tos);
  767. }
  768.  
  769. NORMAL_CODE(stringlength, quote, "length", dostringlength);
  770.  
  771. void dostringcopy()
  772. {
  773.     tos = (long) strcpy(malloc((unsigned) strlen((char *) tos) + 1), (char *) tos);
  774. }
  775.  
  776. NORMAL_CODE(stringcopy, stringlength, "copy", dostringcopy);
  777.  
  778. void dostringequal()
  779. {
  780.     char *s = (char *) spop;
  781.     
  782.     tos = ((STREQ(tos, s) ? TRUE : FALSE));
  783. }
  784.  
  785. NORMAL_CODE(stringequal, stringcopy, "=", dostringequal);
  786.  
  787. void dostringcat()
  788. {
  789.     char *s = (char *) spop;
  790.     
  791.     tos = (long) strcat((char *) tos, s);
  792. }
  793.  
  794. NORMAL_CODE(stringcat, stringequal, "+", dostringcat);
  795.  
  796. void dostringprint()
  797. {
  798.     char *s = (char *) spop;
  799.     
  800.     (void) printf("%s", s);
  801. }
  802.  
  803. NORMAL_CODE(stringprint, stringcat, "print", dostringprint);
  804.  
  805. NORMAL_VOCABULARY(string, locals, "string", stringprint); 
  806.  
  807.  
  808. /* MEMORY ALLOCATION */
  809.  
  810. void domalloc()
  811. {
  812.     tos = (long) malloc((unsigned) tos);
  813. }
  814.  
  815. NORMAL_CODE(kernel_malloc, forth, "malloc", domalloc);
  816.  
  817. void dorealloc()
  818. {
  819.     char *m = (char *) spop;
  820.     
  821.     tos = (long) realloc(m, (unsigned) tos);
  822. }
  823.  
  824. NORMAL_CODE(kernel_realloc, kernel_malloc, "realloc", dorealloc);
  825.  
  826. void dofree()
  827. {
  828.     char *m = (char *) spop;
  829.     
  830.     free(m);
  831. }
  832.  
  833. NORMAL_CODE(kernel_free, kernel_realloc, "free", dofree);
  834.  
  835. NORMAL_VOCABULARY(memory, string, "memory", kernel_free); 
  836.  
  837.  
  838. /* DOUBLE LINKED LIST */
  839.  
  840. void doqemptyqueue()
  841. {
  842.     compare(== (long) (((QUEUE *) tos) -> succ));
  843. }
  844.  
  845. NORMAL_CODE(qemptyqueue, forth, "?empty", doqemptyqueue);
  846.  
  847. void dointoqueue()
  848. {
  849.     QUEUE *t, *q;
  850.  
  851.     q = (QUEUE *) spop;
  852.     t = (QUEUE *) spop;
  853.  
  854.     t -> pred = q -> pred;
  855.     t -> succ = q;
  856.  
  857.     q -> pred -> succ = t;
  858.     q -> pred = t;
  859. }
  860.  
  861. NORMAL_CODE(intoqueue, qemptyqueue, "into", dointoqueue);
  862.  
  863. void dooutqueue()
  864. {
  865.     QUEUE *t = (QUEUE *) spop;
  866.  
  867.     t -> succ -> pred = t -> pred;
  868.     t -> pred -> succ = t -> succ;
  869.  
  870.     t -> succ = t -> pred = t;
  871. }
  872.  
  873. NORMAL_CODE(outqueue, intoqueue, "out", dooutqueue);
  874.  
  875. NORMAL_VOCABULARY(queues, memory, "queues", outqueue);
  876.  
  877.  
  878. /* MULTI-TASKING */
  879.  
  880. static long toterminate = (long) &terminate;
  881.  
  882. NORMAL_CONSTANT(kernel_foreground, forth, "foreground", (long) &foreground);
  883.  
  884. NORMAL_CONSTANT(kernel_running, kernel_foreground, "running", (long) &tp);
  885.  
  886. void douser()
  887. {
  888.     spush(NORMAL);
  889.     spush(USER);
  890.     spush(' ');
  891.     doword();
  892.     doentry();
  893. }
  894.  
  895. NORMAL_CODE(user, kernel_running, "user", douser);
  896.  
  897. TASK *maketask(users, params, returns, action)
  898.     long users, params, returns, action;
  899. {
  900.     long size = sizeof(TASK_HEADER) + users + params + returns;
  901.     TASK *t = (TASK *) malloc((unsigned) size);
  902.  
  903.     /* Initiate queues structure, status and environment */
  904.     t -> queue.succ = t -> queue.pred = (QUEUE *) t;
  905.     t -> status = READY;
  906.  
  907.     t -> s0 = t -> sp = (long *) ((char *) t + size - returns);
  908.     t -> r0 = t -> rp = (long *) ((char *) t + size);
  909.     t -> ip = (action ? (long *) action : (long *) &toterminate);
  910.     t -> fp = NIL;
  911.     t -> ep = NIL;
  912.  
  913.     /* Return task pointer */
  914.     return t;
  915. }
  916.  
  917. void dotask()
  918. {
  919.     long users, params, returns, action;
  920.  
  921.     action  = spop;
  922.     returns = spop;
  923.     params  = spop;
  924.     users   = spop;
  925.     spush(maketask(users, params, returns, action));
  926. }
  927.  
  928. NORMAL_CODE(task, user, "task", dotask);
  929.  
  930. void doresume()
  931. {
  932.     TASK *t = (TASK *) tos;
  933.  
  934.     /* Check if the task to resume is the current task and active */
  935.     if (t -> status && t != tp) {
  936.  
  937.        /* Store the state of the current task */
  938.        tp -> sp = sp;
  939.        tp -> s0 = s0;
  940.        tp -> ip = ip;
  941.        tp -> rp = rp;
  942.        tp -> r0 = r0;
  943.        tp -> fp = fp;
  944.        tp -> ep = ep;
  945.  
  946.        /* Indicate task switch to the virtual machine */
  947.        running = FALSE;
  948.     
  949.        /* Restore the parameter task */
  950.        sp = t -> sp;
  951.        s0 = t -> s0;
  952.        ip = t -> ip;
  953.        rp = t -> rp;
  954.        r0 = t -> r0;
  955.        fp = t -> fp;
  956.        ep = t -> ep;
  957.        tp = t;
  958.     }
  959.  
  960.     /* Load top of stack again */
  961.     spop;
  962. }
  963.  
  964. NORMAL_CODE(resume, task, "resume", doresume);
  965.  
  966. void doschedule()
  967. {
  968.     /* Put the task after the current task */
  969.     spush(tp -> queue.succ);
  970.     dointoqueue();
  971.  
  972.     /* Resume the task now */
  973.     dodetach();
  974.  
  975.     /* Restore parameter and return stack */
  976.     spush(tp);
  977.     rpush(&toterminate);
  978.  
  979.     /* Mark the task as running */
  980.     tp -> status = RUNNING;
  981. }
  982.  
  983. NORMAL_CODE(schedule, resume, "schedule", doschedule);
  984.  
  985. void dodetach()
  986. {
  987.     /* Resume the next task in the system task queue */
  988.     spush(tp -> queue.succ);
  989.     doresume();
  990. }
  991.  
  992. NORMAL_CODE(detach, schedule , "detach", dodetach);
  993.  
  994. void doterminate()
  995. {
  996.     TASK *t = tp;
  997.  
  998.     /* Check if the task is the foreground task */
  999.     if (tp == foreground) {
  1000.  
  1001.        /* Empty the return stack and signal end of execution to inner loop */
  1002.        rinit;
  1003.        running = FALSE;
  1004.        tasking = FALSE;
  1005.  
  1006.        /* Foreground should always terminate on last exit */
  1007.        ip = (long *) &toterminate;
  1008.     }
  1009.     else {
  1010.  
  1011.        /* else remove the current task from the system task queue */
  1012.        dodetach();
  1013.        t -> status = TERMINATED;
  1014.        spush(t);
  1015.        dooutqueue();
  1016.     }
  1017. }
  1018.  
  1019. NORMAL_CODE(terminate, detach, "terminate", doterminate);
  1020.  
  1021. NORMAL_VOCABULARY(multitasking, queues, "multi-tasking", terminate);
  1022.  
  1023.  
  1024. /* EXCEPTION MANAGEMENT */
  1025.  
  1026. void donewexception()
  1027. {
  1028.     spush(NIL);
  1029.     spush(NORMAL);
  1030.     spush(EXCEPTION);
  1031.     spush(' ');
  1032.     doword();
  1033.     doentry();
  1034. }
  1035.  
  1036. NORMAL_CODE(newexception, forth, "exception", donewexception);
  1037.  
  1038. void doparenexceptionsemicolon()
  1039. {  
  1040.     /* Restore the old exception frame pointer */
  1041.     ep = (long *) rpop;
  1042.  
  1043.     /* Remove the exception frame */
  1044.     rdrop(4);
  1045.     
  1046.     /* Return from the current definition */
  1047.     jump(rpop);
  1048. }
  1049.  
  1050. COMPILATION_CODE(parenexceptionsemicolon, newexception, "(exception;)", doparenexceptionsemicolon);
  1051.  
  1052. void doparenexceptionunlinksemicolon()
  1053. {  
  1054.     long *t;
  1055.  
  1056.     /* Remove the argument and local variable frame */
  1057.     t = (long *) rpop;
  1058.     spush(tos);
  1059.  
  1060.     /* And move results to new top of stack */
  1061.     for (--t; t > sp; *--fp = *--t);
  1062.     sp = fp;
  1063.     spop;
  1064.  
  1065.     /* Restore old frame pointer */
  1066.     fp = (long *) rpop;
  1067.  
  1068.     /* Restore the old exception frame pointer */
  1069.     ep = (long *) rpop;
  1070.  
  1071.     /* Remove the exception frame */
  1072.     rdrop(4);
  1073.     
  1074.     /* Return from the current definition */
  1075.     jump(rpop);
  1076. }
  1077.  
  1078. COMPILATION_CODE(parenexceptionunlinksemicolon, parenexceptionsemicolon, "(exceptionunlink;)", doparenexceptionunlinksemicolon);
  1079.  
  1080. void doparenexception()
  1081. {   
  1082.     long body;
  1083.  
  1084.     /* Capture pointer to body */
  1085.     body = spop;
  1086.    
  1087.     /* Build an exception frame */
  1088.     rpush(tos);
  1089.     rpush(sp);
  1090.     rpush(ip);
  1091.     rpush(fp);
  1092.     rpush(ep);
  1093.     ep = rp;
  1094.     
  1095.     /* Jump to the body of the definition */
  1096.     jump(body);
  1097. }
  1098.  
  1099. COMPILATION_CODE(parenexception, parenexceptionunlinksemicolon, "(exception>)", doparenexception);
  1100.  
  1101. void doexception()
  1102. {  
  1103.     ENTRY *t;
  1104.  
  1105.     /* Set up pointer to last definition */
  1106.     dolast();
  1107.     t = (ENTRY *) spop;
  1108.     
  1109.     /* Compile an exit of the current definition */
  1110.     spush((theframed ? &parenexceptionunlinksemicolon : &parenexceptionsemicolon));
  1111.     dothread();
  1112.     doremovelocals();
  1113.     
  1114.     /* Redefine the code type of the last definition */
  1115.     t -> code = (long) dp;
  1116.     
  1117.     /* Compile the run time exception management definition */
  1118.     spush(&parenexception);
  1119.     dothread();
  1120. }
  1121.  
  1122. COMPILATION_IMMEDIATE_CODE(exception, parenexception, "exception>", doexception);
  1123.  
  1124. void doraise()
  1125. {  
  1126.     long s = spop;
  1127.     
  1128.     /* Check if there is an exception block available */
  1129.     if (ep) {
  1130.  
  1131.        /* Restore the call environment */
  1132.        rp = ep;
  1133.        ep = (long *) rpop;
  1134.        fp = (long *) rpop;
  1135.        ip = (long *) rpop;
  1136.        sp = (long *) rpop;
  1137.        tos = rpop;
  1138.  
  1139.        /* Pass on the signal or exception to the exception block */
  1140.        spush(s);
  1141.     }
  1142.     else {
  1143.        
  1144.        /* Call low level management of signal */
  1145.        (void) error_signal(s);
  1146.     }
  1147. }
  1148.  
  1149. NORMAL_CODE(raise, exception, "raise", doraise);
  1150.  
  1151. NORMAL_VOCABULARY(exceptions, multitasking, "exceptions", raise);
  1152.  
  1153.  
  1154. /* LOGIC: FORTH-83 VOCABULARY */
  1155.  
  1156. NORMAL_CONSTANT(false, exceptions, "false", FALSE);
  1157.  
  1158. NORMAL_CONSTANT(true, false, "true", TRUE);
  1159.  
  1160. void doboolean()
  1161. {
  1162.     compare(!= 0);
  1163. }
  1164.  
  1165. NORMAL_CODE(boolean, true, "boolean", doboolean);
  1166.  
  1167. void donot()
  1168. {
  1169.     unary(~);
  1170. }
  1171.  
  1172. NORMAL_CODE(not, boolean, "not", donot);
  1173.  
  1174. void doand()
  1175. {
  1176.     binary(&);
  1177. }
  1178.  
  1179. NORMAL_CODE(and, not, "and", doand);
  1180.  
  1181. void door()
  1182. {
  1183.     binary(|);
  1184. }
  1185.  
  1186. NORMAL_CODE(or, and, "or", door);
  1187.  
  1188. void doxor()
  1189. {
  1190.     binary(^);
  1191. }
  1192.  
  1193. NORMAL_CODE(xor, or, "xor", doxor);
  1194.  
  1195. void doqwithin()
  1196. {
  1197.     long value;
  1198.     long upper;
  1199.     long lower;
  1200.     
  1201.     upper = spop;
  1202.     lower = spop;
  1203.     value = spop;
  1204.     
  1205.     spush((value > upper) || (value < lower) ? FALSE : TRUE);
  1206. }
  1207.     
  1208. NORMAL_CODE(qwithin, xor, "?within", doqwithin);
  1209.  
  1210.  
  1211. /* STACK MANIPULATION */
  1212.  
  1213. void dodup()
  1214. {
  1215.     spush(tos);
  1216. }
  1217.  
  1218. NORMAL_CODE(kernel_dup, qwithin, "dup", dodup);
  1219.  
  1220. void dodrop()
  1221. {
  1222.     spop;
  1223. }
  1224.  
  1225. NORMAL_CODE(drop, kernel_dup, "drop", dodrop);
  1226.  
  1227. void doswap()
  1228. {
  1229.     long t = tos;
  1230.  
  1231.     tos = snth(0);
  1232.     snth(0) = t;
  1233. }
  1234.  
  1235. NORMAL_CODE(swap, drop, "swap", doswap);
  1236.  
  1237. void doover()
  1238. {
  1239.     spush(snth(1));
  1240. }
  1241.  
  1242. NORMAL_CODE(over, swap, "over", doover);
  1243.  
  1244. void dorot()
  1245. {
  1246.     long t = tos;
  1247.  
  1248.     tos = snth(1);
  1249.     snth(1) = snth(0);
  1250.     snth(0) = t;
  1251. }
  1252.  
  1253. NORMAL_CODE(rot, over, "rot", dorot);
  1254.  
  1255. void dopick()
  1256. {
  1257.     tos = snth(tos);
  1258. }
  1259.  
  1260. NORMAL_CODE(pick, rot, "pick", dopick);
  1261.  
  1262. void doroll()
  1263. {
  1264.     long e;
  1265.     long *s;
  1266.  
  1267.     /* Fetch roll parameters: number and element */
  1268.     e = snth(tos);
  1269.  
  1270.     /* Roll the stack */
  1271.     for (s = sp + tos; s > sp; s--) *s = *(s - 1);
  1272.     sp++;
  1273.     
  1274.     /* And assign the new top of stack */
  1275.     tos = e;
  1276. }
  1277.  
  1278. NORMAL_CODE(roll, pick, "roll", doroll);
  1279.  
  1280. void doqdup()
  1281. {
  1282.     if (tos) spush(tos);
  1283. }
  1284.  
  1285. NORMAL_CODE(qdup, roll, "?dup", doqdup);
  1286.  
  1287. void dotor()
  1288. {
  1289.     rpush(spop);
  1290. }
  1291.  
  1292. COMPILATION_CODE(tor, qdup, ">r", dotor);
  1293.  
  1294. void dofromr()
  1295. {
  1296.     spush(rpop);
  1297. }
  1298.  
  1299. COMPILATION_CODE(fromr, tor, "r>", dofromr);
  1300.  
  1301. void docopyr()
  1302. {
  1303.     spush(*rp);
  1304. }
  1305.  
  1306. COMPILATION_CODE(copyr, fromr, "r@", docopyr);
  1307.  
  1308. void dodepth()
  1309. {
  1310.     long *t = sp;
  1311.  
  1312.     spush((s0 - t));
  1313. }
  1314.  
  1315. NORMAL_CODE(depth, copyr, "depth", dodepth);
  1316.  
  1317. void dodots()
  1318. {
  1319.     /* Print the stack depth */
  1320.     (void) printf("[%d] ", s0 - sp);
  1321.  
  1322.     /* Check if there are any elements on the stack */
  1323.     if (s0 - sp > 0) {
  1324.        long *s;
  1325.  
  1326.        /* Print them and don't forget top of stack */
  1327.        for (s = s0 - 2; s >= sp; s--) {
  1328.            (void) printf("\\");
  1329.            spush(*s);
  1330.            if (tos < 0) {
  1331.                (void) putchar('-');
  1332.                tos = -tos;
  1333.            }
  1334.            dolesssharp();
  1335.            dosharps();
  1336.            dosharpgreater();
  1337.            dotype();
  1338.        }
  1339.        (void) printf("\\");
  1340.        dodup();
  1341.        dodot();
  1342.     }
  1343. }
  1344.  
  1345. NORMAL_CODE(dots, depth, ".s", dodots);
  1346.  
  1347.  
  1348. /* COMPARISON */
  1349.  
  1350. void dolessthan()
  1351. {
  1352.     relation(<);
  1353. }
  1354.  
  1355. NORMAL_CODE(lessthan, dots, "<", dolessthan);
  1356.  
  1357. void doequals()
  1358. {
  1359.     relation(==);
  1360. }
  1361.  
  1362. NORMAL_CODE(equals, lessthan, "=", doequals);
  1363.  
  1364. void dogreaterthan()
  1365. {
  1366.     relation(>);
  1367. }
  1368.  
  1369. NORMAL_CODE(greaterthan, equals, ">", dogreaterthan);
  1370.  
  1371. void dozeroless()
  1372. {
  1373.     compare(< 0);
  1374. }
  1375.  
  1376. NORMAL_CODE(zeroless, greaterthan, "0<", dozeroless);
  1377.  
  1378. void dozeroequals()
  1379. {
  1380.     compare(== 0);
  1381. }
  1382.  
  1383. NORMAL_CODE(zeroequals, zeroless, "0=", dozeroequals);
  1384.  
  1385. void dozerogreater()
  1386. {
  1387.     compare(> 0);
  1388. }
  1389.  
  1390. NORMAL_CODE(zerogreater, zeroequals, "0>", dozerogreater);
  1391.  
  1392. void doulessthan()
  1393. {
  1394.     urelation(<);
  1395. }
  1396.  
  1397. NORMAL_CODE(ulessthan, zerogreater, "u<", doulessthan);
  1398.  
  1399.  
  1400. /* CONSTANTS */
  1401.  
  1402. NORMAL_CONSTANT(nil, ulessthan, "nil", NIL);
  1403.  
  1404. NORMAL_CONSTANT(minustwo, nil, "-2", -2);
  1405.  
  1406. NORMAL_CONSTANT(minusone, minustwo, "-1", -1);
  1407.  
  1408. NORMAL_CONSTANT(zero, minusone, "0", 0);
  1409.  
  1410. NORMAL_CONSTANT(one, zero, "1", 1);
  1411.  
  1412. NORMAL_CONSTANT(two, one, "2", 2);
  1413.  
  1414.  
  1415. /* ARITHMETRIC */
  1416.  
  1417. void doplus()
  1418. {
  1419.     binary(+);
  1420. }
  1421.  
  1422. NORMAL_CODE(plus, two, "+", doplus);
  1423.  
  1424. void dominus()
  1425. {
  1426.     binary(-);
  1427. }
  1428.  
  1429. NORMAL_CODE(minus, plus, "-", dominus);
  1430.  
  1431. void dooneplus()
  1432. {
  1433.     unary(++);
  1434. }
  1435.  
  1436. NORMAL_CODE(oneplus, minus, "1+", dooneplus);
  1437.  
  1438. void dooneminus()
  1439. {
  1440.     unary(--);
  1441. }
  1442.  
  1443. NORMAL_CODE(oneminus, oneplus, "1-", dooneminus);
  1444.  
  1445. void dotwoplus()
  1446. {
  1447.     unary(2 +);
  1448. }
  1449.  
  1450. NORMAL_CODE(twoplus, oneminus, "2+", dotwoplus);
  1451.  
  1452. void dotwominus()
  1453. {
  1454.     unary(-2 +);
  1455. }
  1456.  
  1457. NORMAL_CODE(twominus, twoplus, "2-", dotwominus);
  1458.  
  1459. void dotwotimes()
  1460. {
  1461.     tos <<= 1;
  1462. }
  1463.  
  1464. NORMAL_CODE(twotimes, twominus, "2*", dotwotimes);
  1465.  
  1466. void doleftshift()
  1467. {
  1468.     binary(<<);
  1469. }
  1470.  
  1471. NORMAL_CODE(leftshift, twotimes, "<<", doleftshift);
  1472.  
  1473. void dotimes()
  1474. {
  1475.     binary(*);
  1476. }
  1477.  
  1478. NORMAL_CODE(kernel_times, leftshift, "*", dotimes);
  1479.  
  1480. void doumtimes()
  1481. {
  1482.     ubinary(*);
  1483. }
  1484.  
  1485. NORMAL_CODE(kernel_utimes, kernel_times, "um*", doumtimes);
  1486.  
  1487. void doumdividemod()
  1488. {
  1489.     long t = snth(0);
  1490.  
  1491.     snth(0) = (unsigned long) t % (unsigned long) tos;
  1492.     tos = (unsigned long) t / (unsigned long) tos;
  1493. }
  1494.  
  1495. NORMAL_CODE(umdividemod, kernel_utimes, "um/mod", doumdividemod);
  1496.  
  1497. void dotwodivide()
  1498. {
  1499.     tos >>= 1;
  1500. }
  1501.  
  1502. NORMAL_CODE(twodivide, umdividemod, "2/", dotwodivide);
  1503.  
  1504. void dorightshift()
  1505. {
  1506.     binary(>>);
  1507. }
  1508.  
  1509. NORMAL_CODE(rightshift, twodivide, ">>", dorightshift);
  1510.  
  1511. void dodivide()
  1512. {
  1513.     binary(/);
  1514. }
  1515.  
  1516. NORMAL_CODE(divide, rightshift, "/", dodivide);
  1517.  
  1518. void domod()
  1519. {
  1520.     binary(%);
  1521. }
  1522.  
  1523. NORMAL_CODE(mod, divide, "mod", domod);
  1524.  
  1525. void dodividemod()
  1526. {
  1527.     long t = snth(0);
  1528.  
  1529.     snth(0) = t % tos;
  1530.     tos = t / tos;
  1531. }
  1532.  
  1533. NORMAL_CODE(dividemod, mod, "/mod", dodividemod);
  1534.  
  1535. void dotimesdividemod()
  1536. {
  1537.     long t = spop;
  1538.  
  1539.     tos = tos * snth(0);
  1540.     snth(0) = tos % t;
  1541.     tos = tos / t;
  1542. }
  1543.  
  1544. NORMAL_CODE(timesdividemod, dividemod, "*/mod", dotimesdividemod);
  1545.  
  1546. void dotimesdivide()
  1547. {
  1548.     long t = spop;
  1549.  
  1550.     binary(*);
  1551.     spush(t);
  1552.     binary(/);
  1553. }
  1554.  
  1555. NORMAL_CODE(timesdivide, timesdividemod, "*/", dotimesdivide);
  1556.  
  1557. void domin()
  1558. {
  1559.     long t = spop;
  1560.     
  1561.     tos = (t < tos ? t : tos);
  1562. }
  1563.  
  1564. NORMAL_CODE(min, timesdivide, "min", domin);
  1565.  
  1566. void domax()
  1567. {
  1568.     long t = spop;
  1569.     
  1570.     tos = (t > tos ? t : tos);
  1571. }
  1572.  
  1573. NORMAL_CODE(max, min, "max", domax);
  1574.  
  1575. void doabs()
  1576. {
  1577.     tos = (tos < 0 ? -tos : tos);
  1578. }
  1579.  
  1580. NORMAL_CODE(kernel_abs, max, "abs", doabs);
  1581.  
  1582. void donegate()
  1583. {
  1584.     unary(-);
  1585. }
  1586.  
  1587. NORMAL_CODE(negate, kernel_abs, "negate", donegate);
  1588.  
  1589.  
  1590. /* MEMORY */
  1591.  
  1592. void dofetch()
  1593. {
  1594.     unary(*(long *));
  1595. }
  1596.  
  1597. NORMAL_CODE(fetch, negate, "@", dofetch);
  1598.  
  1599. void dostore()
  1600. {
  1601.     *((long *) tos) = snth(0);
  1602.     sdrop(1);
  1603. }
  1604.  
  1605. NORMAL_CODE(store, fetch, "!", dostore);
  1606.  
  1607. void dowfetch()
  1608. {
  1609.     unary(*(word *));
  1610. }
  1611.  
  1612. NORMAL_CODE(wfetch, store, "w@", dowfetch);
  1613.  
  1614. void dowstore()
  1615. {
  1616.     *((word *) tos) = snth(0);
  1617.     sdrop(1);
  1618. }
  1619.  
  1620. NORMAL_CODE(wstore, wfetch, "w!", dowstore);
  1621.  
  1622. void docfetch()
  1623. {
  1624.     unary(*(char *));
  1625. }
  1626.  
  1627. NORMAL_CODE(cfetch, wstore, "c@", docfetch);
  1628.  
  1629. void docstore()
  1630. {
  1631.     *((char *) tos) = snth(0);
  1632.     sdrop(1);
  1633. }
  1634.  
  1635. NORMAL_CODE(cstore, cfetch, "c!", docstore);
  1636.  
  1637. void doffetch()
  1638. {
  1639.     long pos;
  1640.     long width;
  1641.  
  1642.     width = spop;
  1643.     pos = spop;
  1644.     tos = (tos >> pos) & ~(-1 << width);
  1645. }
  1646.  
  1647. NORMAL_CODE(ffetch, cstore, "f@", doffetch);
  1648.  
  1649. void dofstore()
  1650. {
  1651.     long pos;
  1652.     long width;
  1653.     long value;
  1654.  
  1655.     width = spop;
  1656.     pos = spop;
  1657.     value = spop;
  1658.     tos = ((tos & ~(-1 << width)) << pos) | (value & ~((~(-1 << width)) << pos));
  1659. }
  1660.  
  1661. NORMAL_CODE(fstore, ffetch, "f!", dofstore);
  1662.  
  1663. void dobfetch()
  1664. {
  1665.     long bit = spop;
  1666.  
  1667.     tos = (((tos >> bit) & 1) ? TRUE : FALSE);
  1668. }
  1669.  
  1670. NORMAL_CODE(bfetch, fstore, "b@", dobfetch);
  1671.  
  1672. void dobstore()
  1673. {
  1674.     long bit;
  1675.     long value;
  1676.  
  1677.     bit = spop;
  1678.     value = spop;
  1679.  
  1680.     tos = (tos ? (value | (1 << bit)) : (value & ~(1 << bit)));
  1681. }
  1682.  
  1683. NORMAL_CODE(bstore, bfetch, "b!", dobstore);
  1684.  
  1685. void doplusstore()
  1686. {
  1687.     *((long *) tos) += snth(0);
  1688.     sdrop(1);
  1689. }
  1690.  
  1691. NORMAL_CODE(plusstore, bstore, "+!", doplusstore);
  1692.  
  1693.  
  1694. /* STRINGS */
  1695.  
  1696. void docmove()
  1697. {
  1698.     register long n;
  1699.     register char *to;
  1700.     register char *from;
  1701.  
  1702.     n = spop;
  1703.     to = (char *) spop;
  1704.     from = (char *) spop;
  1705.  
  1706.     while (--n != -1) *to++ = *from++;
  1707. }
  1708.  
  1709. NORMAL_CODE(cmove, plusstore, "cmove", docmove);
  1710.  
  1711. void docmoveup()
  1712. {
  1713.     register long n;
  1714.     register char *to;
  1715.     register char *from;
  1716.  
  1717.     n = spop;
  1718.     to = (char *) spop;
  1719.     from = (char *) spop;
  1720.  
  1721.     to += n;
  1722.     from += n;
  1723.     while (--n != -1) *--to = *--from;
  1724. }
  1725.  
  1726. NORMAL_CODE(cmoveup, cmove, "cmove>", docmoveup);
  1727.  
  1728. void dofill()
  1729. {
  1730.     register char with;
  1731.     register long n;
  1732.     register char *from;
  1733.  
  1734.     with = (char) spop;
  1735.     n = spop;
  1736.     from = (char *) spop;
  1737.  
  1738.     while (--n != -1) *from++ = with;
  1739. }
  1740.  
  1741. NORMAL_CODE(fill, cmoveup, "fill", dofill);
  1742.  
  1743. void docount()
  1744. {
  1745.     spush(*((char *) tos));
  1746.     snth(0)++;
  1747. }
  1748.  
  1749. NORMAL_CODE(count, fill, "count", docount);
  1750.  
  1751. void dodashtrailing()
  1752. {
  1753.     char *p = (char *) (snth(0) + tos);
  1754.     
  1755.     tos += 1;
  1756.     while (--tos && (*--p == ' '));
  1757. }
  1758.  
  1759. NORMAL_CODE(dashtrailing, count, "-trailing", dodashtrailing);
  1760.  
  1761.  
  1762. /* NUMERICAL CONVERSION */
  1763.  
  1764. NORMAL_VARIABLE(base, dashtrailing, "base", 10);
  1765.  
  1766. void dobinary()
  1767. {
  1768.     base.parameter = 2;
  1769. }
  1770.  
  1771. NORMAL_CODE(kernel_binary, base, "binary", dobinary);
  1772.  
  1773. void dooctal()
  1774. {
  1775.     base.parameter = 8;
  1776. }
  1777.  
  1778. NORMAL_CODE(octal, kernel_binary, "octal", dooctal);
  1779.  
  1780. void dodecimal()
  1781. {
  1782.     base.parameter = 10;
  1783. }
  1784.  
  1785. NORMAL_CODE(decimal, octal, "decimal", dodecimal);
  1786.  
  1787. void dohex()
  1788. {
  1789.     base.parameter = 16;
  1790. }
  1791.  
  1792. NORMAL_CODE(hex, decimal, "hex", dohex);
  1793.  
  1794. void doconvert()
  1795. {
  1796.     register char c;
  1797.     register long b;
  1798.     register long n;
  1799.     
  1800.     b = base.parameter;
  1801.     n = snth(0);                       
  1802.  
  1803.     for (;;) {
  1804.        c = *(char *) tos;
  1805.        if (c < '0' || c > 'z' || (c > '9' && c < 'a')) {
  1806.            snth(0) = n;
  1807.            return;
  1808.        }
  1809.        else {
  1810.            if (c > '9') c = c - 'a' + ':';
  1811.            c = c - '0';
  1812.            if (c < 0 || c >= b) {
  1813.                snth(0) = n;
  1814.                return;
  1815.            }
  1816.            n = (n * b) + c;
  1817.            tos += 1;
  1818.        }
  1819.     }
  1820. }
  1821.  
  1822. NORMAL_CODE(convert, hex, "convert", doconvert);
  1823.  
  1824. static long hld;
  1825.  
  1826. void dolesssharp()
  1827. {
  1828.     hld = (long) thepad + PADSIZE;
  1829. }
  1830.  
  1831. NORMAL_CODE(lesssharp, convert, "<#", dolesssharp);
  1832.  
  1833. void dosharp()
  1834. {
  1835.     long n = tos;
  1836.     
  1837.     tos = (unsigned long) n / (unsigned long) base.parameter;
  1838.     n = (unsigned long) n % (unsigned long) base.parameter;
  1839.     *(char *) --hld = n + ((n > 9) ? 'a' - 10 : '0');
  1840. }
  1841.  
  1842. NORMAL_CODE(sharp, lesssharp, "#", dosharp);
  1843.  
  1844. void dosharps()
  1845. {
  1846.     do { dosharp(); } while (tos);
  1847. }
  1848.  
  1849. NORMAL_CODE(sharps, sharp, "#s", dosharps);
  1850.  
  1851. void dohold()
  1852. {
  1853.     *(char *) --hld = spop;
  1854. }
  1855.  
  1856. NORMAL_CODE(hold, sharps, "hold", dohold);
  1857.  
  1858. void dosign()
  1859. {
  1860.     long flag = spop;
  1861.     
  1862.     if (flag < 0) *(char *) --hld = '-';
  1863. }
  1864.  
  1865. NORMAL_CODE(sign, hold, "sign", dosign);
  1866.  
  1867. void dosharpgreater()
  1868. {
  1869.     tos = hld;
  1870.     spush(thepad + PADSIZE - hld);
  1871. }
  1872.  
  1873. NORMAL_CODE(sharpgreater, sign, "#>", dosharpgreater);
  1874.  
  1875. void doqnumber()
  1876. {
  1877.     char *s0;
  1878.     char *s1;
  1879.     
  1880.     s0 = (char *) spop;
  1881.     spush(0);
  1882.     if (*s0 == '-') {
  1883.        spush(s0 + 1);
  1884.     }
  1885.     else {
  1886.        spush(s0);
  1887.     }
  1888.     doconvert();
  1889.     s1 = (char *) spop;
  1890.     if (*s1 == '\0') {
  1891.        if (*s0 == '-') unary(-);
  1892.        spush(TRUE);
  1893.     }
  1894.     else {
  1895.        tos = (long) s0;
  1896.        spush(FALSE);
  1897.     }
  1898. }
  1899.  
  1900. NORMAL_CODE(qnumber, sharpgreater, "?number", doqnumber);
  1901.  
  1902.  
  1903. /* CONTROL STRUCTURES */
  1904.  
  1905. long docheck(this)
  1906.     int this;
  1907. {
  1908.     ENTRY *last;
  1909.     long follow = spop;
  1910.  
  1911.     /* Check if the symbol is in the follow set */
  1912.     if (this & follow) {
  1913.  
  1914.        /* Return true is so */
  1915.        return TRUE;
  1916.     }
  1917.     else {
  1918.  
  1919.        /* Else report a control structure error */
  1920.        dolast();
  1921.        last = (ENTRY *) spop;
  1922.        (void) printf("%s: illegal control structure\n", last -> name);
  1923.        doabort();
  1924.  
  1925.        return FALSE;
  1926.     }
  1927. }
  1928.  
  1929. void dodo()
  1930. {
  1931.     spush(&parendo);
  1932.     dothread();
  1933.     doforwardmark();
  1934.     dobackwardmark();
  1935.     spush(LOOP+PLUSLOOP);
  1936. }
  1937.  
  1938. COMPILATION_IMMEDIATE_CODE(kernel_do, qnumber, "do", dodo);
  1939.  
  1940. void doqdo()
  1941. {
  1942.     spush(&parenqdo);
  1943.     dothread();
  1944.     doforwardmark();
  1945.     dobackwardmark();
  1946.     spush(LOOP+PLUSLOOP);
  1947. }
  1948.  
  1949. COMPILATION_IMMEDIATE_CODE(kernel_qdo, kernel_do, "?do", doqdo);
  1950.  
  1951. void doloop()
  1952. {
  1953.     if (docheck(LOOP)) {
  1954.        spush(&parenloop);
  1955.        dothread();
  1956.        dobackwardresolve();
  1957.        doforwardresolve();
  1958.     }
  1959. }
  1960.  
  1961. COMPILATION_IMMEDIATE_CODE(loop, kernel_qdo, "loop", doloop);
  1962.  
  1963. void doplusloop()
  1964. {
  1965.     if (docheck(PLUSLOOP)) {
  1966.        spush(&parenplusloop);
  1967.        dothread();
  1968.        dobackwardresolve();
  1969.        doforwardresolve();
  1970.     }
  1971. }
  1972.  
  1973. COMPILATION_IMMEDIATE_CODE(plusloop, loop, "+loop", doplusloop);
  1974.  
  1975. void doleave()
  1976. {
  1977.     rdrop(2);
  1978.     jump(rpop);
  1979.     branch(*ip);
  1980. }
  1981.  
  1982. COMPILATION_CODE(leave, plusloop, "leave", doleave);
  1983.  
  1984. void doi()
  1985. {
  1986.     spush(rnth(1));
  1987. }
  1988.  
  1989. COMPILATION_CODE(kernel_i, leave,"i", doi);
  1990.  
  1991. void doj()
  1992. {
  1993.     spush(rnth(4));
  1994. }
  1995.  
  1996. COMPILATION_CODE(kernel_j, kernel_i, "j", doj);
  1997.  
  1998. void doif()
  1999. {
  2000.     spush(&parenqbranch);
  2001.     dothread();
  2002.     doforwardmark();
  2003.     spush(ELSE+THEN);
  2004. }
  2005.  
  2006. COMPILATION_IMMEDIATE_CODE(kernel_if, kernel_j, "if", doif);
  2007.  
  2008. void doelse()
  2009. {
  2010.     if (docheck(ELSE)) {
  2011.        spush(&parenbranch);
  2012.        dothread();
  2013.        doforwardmark();
  2014.        doswap();
  2015.        doforwardresolve();
  2016.        spush(THEN);
  2017.     }
  2018. }
  2019.  
  2020. COMPILATION_IMMEDIATE_CODE(kernel_else, kernel_if, "else", doelse);
  2021.  
  2022. void dothen()
  2023. {
  2024.     if (docheck(THEN)) {
  2025.        doforwardresolve();
  2026.     }
  2027. }
  2028.  
  2029. COMPILATION_IMMEDIATE_CODE(kernel_then, kernel_else, "then", dothen);
  2030.  
  2031. void docase()
  2032. {
  2033.     spush(0);
  2034.     spush(OF+ENDCASE);
  2035. }
  2036.  
  2037. COMPILATION_IMMEDIATE_CODE(kernel_case, kernel_then, "case", docase);
  2038.  
  2039. void doof()
  2040. {
  2041.     if (docheck(OF)) {
  2042.        spush(&over);
  2043.        dothread();
  2044.        spush(&equals);
  2045.        dothread();
  2046.        spush(&parenqbranch);
  2047.        dothread();
  2048.        doforwardmark();
  2049.        spush(&drop);
  2050.        dothread();
  2051.        spush(ENDOF);
  2052.     }
  2053. }
  2054.  
  2055. COMPILATION_IMMEDIATE_CODE(kernel_of, kernel_case, "of", doof);
  2056.  
  2057. void doendof()
  2058. {
  2059.     if (docheck(ENDOF)) {
  2060.        spush(&parenbranch);
  2061.        dothread();
  2062.        doforwardmark();
  2063.        doswap();
  2064.        doforwardresolve();
  2065.        spush(OF+ENDCASE);
  2066.     }
  2067. }
  2068.  
  2069. COMPILATION_IMMEDIATE_CODE(endof, kernel_of, "endof", doendof);
  2070.  
  2071. void doendcase()
  2072. {
  2073.     if (docheck(ENDCASE)) {
  2074.        spush(&drop);
  2075.        dothread();
  2076.        while (tos) doforwardresolve();
  2077.        dodrop();
  2078.     }
  2079. }
  2080.  
  2081. COMPILATION_IMMEDIATE_CODE(endcase, endof, "endcase", doendcase);
  2082.  
  2083. void dobegin()
  2084. {
  2085.     dobackwardmark();
  2086.     spush(AGAIN+UNTIL+WHILE);
  2087. }
  2088.  
  2089. COMPILATION_IMMEDIATE_CODE(begin, endcase, "begin", dobegin);
  2090.  
  2091. void dountil()
  2092. {
  2093.     if (docheck(UNTIL)) {
  2094.        spush(&parenqbranch);
  2095.        dothread();
  2096.        dobackwardresolve();
  2097.     }
  2098. }
  2099.  
  2100. COMPILATION_IMMEDIATE_CODE(until, begin, "until", dountil);
  2101.  
  2102. void dowhile()
  2103. {
  2104.     if (docheck(WHILE)) {
  2105.        spush(&parenqbranch);
  2106.        dothread();
  2107.        doforwardmark();
  2108.        spush(REPEAT);
  2109.     }
  2110. }
  2111.  
  2112. COMPILATION_IMMEDIATE_CODE(kernel_while, until, "while", dowhile);
  2113.  
  2114. void dorepeat()
  2115. {
  2116.     if (docheck(REPEAT)) {
  2117.        spush(&parenbranch);
  2118.        dothread();
  2119.        doswap();
  2120.        dobackwardresolve();
  2121.        doforwardresolve();
  2122.     }
  2123. }
  2124.  
  2125. COMPILATION_IMMEDIATE_CODE(repeat, kernel_while, "repeat", dorepeat);
  2126.  
  2127. void doagain()
  2128. {
  2129.     if (docheck(AGAIN)) {
  2130.        spush(&parenbranch);
  2131.        dothread();
  2132.        dobackwardresolve();
  2133.     }
  2134. }
  2135.  
  2136. COMPILATION_IMMEDIATE_CODE(again, repeat, "again", doagain);
  2137.  
  2138. void dorecurse()
  2139. {
  2140.     dolast();
  2141.     dothread();
  2142. }
  2143.  
  2144. COMPILATION_IMMEDIATE_CODE(recurse, again, "recurse", dorecurse);
  2145.  
  2146. void dotailrecurse()
  2147. {
  2148.     if (theframed) {
  2149.        spush(&parenunlink);
  2150.        dothread();
  2151.     }
  2152.     dolast();
  2153.     dotobody();
  2154.     spush(&parenbranch);
  2155.     dothread();
  2156.     dobackwardresolve();
  2157. }
  2158.  
  2159. COMPILATION_IMMEDIATE_CODE(tailrecurse, recurse, "tail-recurse", dotailrecurse);
  2160.  
  2161. void doexit()
  2162. {
  2163.     jump(rpop);
  2164. }
  2165.  
  2166. COMPILATION_CODE(kernel_exit, tailrecurse, "exit", doexit);
  2167.  
  2168. void doexecute()
  2169. {
  2170.     long t = spop;
  2171.  
  2172.     docall((ENTRY *) t);
  2173. }
  2174.  
  2175. NORMAL_CODE(execute, kernel_exit, "execute", doexecute);
  2176.  
  2177. void dobye()
  2178. {
  2179.     quited = FALSE;
  2180. }
  2181.  
  2182. NORMAL_CODE(bye, execute, "bye", dobye);
  2183.  
  2184.  
  2185. /* TERMINAL INPUT-OUTPUT */
  2186.  
  2187. void dodot()
  2188. {
  2189.     if (tos < 0) {
  2190.        (void) putchar('-');
  2191.        tos = -tos;
  2192.     }
  2193.     doudot();
  2194. }
  2195.  
  2196. NORMAL_CODE(dot, bye, ".", dodot);
  2197.  
  2198. void doudot()
  2199. {
  2200.     dolesssharp();
  2201.     dosharps();
  2202.     dosharpgreater();
  2203.     dotype();
  2204.     dospace();
  2205. }
  2206.  
  2207. NORMAL_CODE(udot, dot, "u.", doudot);
  2208.  
  2209. void doascii()
  2210. {
  2211.     spush(' ');
  2212.     doword();
  2213.     docfetch();
  2214.     doliteral();
  2215. }
  2216.  
  2217. IMMEDIATE_CODE(ascii, udot, "ascii", doascii);
  2218.  
  2219. void dodotquote()
  2220. {
  2221.     (void) io_scan(thetib, '"');
  2222.     spush(thetib);
  2223.     dostringcopy();
  2224.     spush(&parendotquote);
  2225.     dothread();
  2226.     docomma();
  2227. }
  2228.  
  2229. COMPILATION_IMMEDIATE_CODE(dotquote, ascii, ".\"", dodotquote);
  2230.  
  2231. void dodotparen()
  2232. {
  2233.     (void) io_scan(thetib, ')'); 
  2234.     spush(thetib);
  2235.     dostringprint();
  2236. }
  2237.  
  2238. IMMEDIATE_CODE(dotparen, dotquote, ".(", dodotparen);
  2239.  
  2240. void docr()
  2241. {
  2242.     (void) putchar('\n');
  2243. }
  2244.  
  2245. NORMAL_CODE(cr, dotparen, "cr", docr);
  2246.  
  2247. void doemit()
  2248. {
  2249.     char c = (char) spop;
  2250.     
  2251.     (void) putchar(c);
  2252. }
  2253.  
  2254. NORMAL_CODE(emit, cr, "emit", doemit);
  2255.  
  2256. void dotype()
  2257. {
  2258.     long n;
  2259.     char *s;
  2260.  
  2261.     n = spop;
  2262.     s = (char *) spop;
  2263.     while (n--) (void) putchar(*s++);
  2264. }
  2265.  
  2266. NORMAL_CODE(type, emit, "type", dotype);
  2267.  
  2268. void dospace()
  2269. {
  2270.     (void) putchar(' ');
  2271. }
  2272.  
  2273. NORMAL_CODE(space, type, "space", dospace);
  2274.  
  2275. void dospaces()
  2276. {
  2277.     long n = spop;
  2278.  
  2279.     while (n--) (void) putchar(' ');
  2280. }
  2281.  
  2282. NORMAL_CODE(spaces, space, "spaces", dospaces);
  2283.  
  2284. void dokey()
  2285. {
  2286.     spush(io_getchar());
  2287. }
  2288.  
  2289. NORMAL_CODE(key, spaces, "key", dokey);
  2290.  
  2291. void doexpect()
  2292. {
  2293.     char *s0;
  2294.     char *s1;
  2295.     char  c;
  2296.     long  n;
  2297.     
  2298.     /* Pop buffer pointer and size */
  2299.     n = spop;
  2300.     s0 = s1 = (char *) spop;
  2301.     
  2302.     /* Fill buffer until end of line or buffer */
  2303.     while (io_not_eof() && (n-- > 0) && ((c = io_getchar()) != '\n')) *s1++ = c;
  2304.  
  2305.     /* Set span to number of characters received */
  2306.     span.parameter = (long) (s1 - s0);
  2307. }
  2308.  
  2309. NORMAL_CODE(expect, key, "expect", doexpect);
  2310.  
  2311. NORMAL_VARIABLE(span, expect, "span", 0);
  2312.  
  2313.  
  2314. /* PROGRAM BEGINNING AND TERMINATION */
  2315.  
  2316. void doforth83()
  2317. { }
  2318.  
  2319. NORMAL_CODE(forth83, span, "forth-83", doforth83);
  2320.     
  2321. void dointerpret()
  2322. {
  2323.     long flag;                 /* Flag value returned by for words */
  2324.     long cast;                 /* Casting operation flag */
  2325.  
  2326.     quited = TRUE;             /* Iterate until bye or end of input */
  2327.  
  2328.     while (quited) {
  2329.  
  2330.        /* Check stack underflow */
  2331.        if (s0 < sp) {
  2332.            (void) printf("interpret: stack underflow\n");
  2333.            doabort();
  2334.        }
  2335.  
  2336.        /* Scan for the next symbol */
  2337.        spush(' ');
  2338.        doword();
  2339.  
  2340.        /* Exit top loop if end of input stream */
  2341.        if (io_eof()) {
  2342.            spop;
  2343.            return;
  2344.        }
  2345.  
  2346.        /* Search for the symbol in the current vocabulary search set*/
  2347.        dofind();
  2348.        flag = spop;
  2349.  
  2350.        /* Check for vocabulary casting prefix */
  2351.        for (cast = flag; !cast;) {
  2352.            char *s = (char *) tos;
  2353.            long l = strlen(s) - 1;
  2354.  
  2355.            /* Assume casting prefix */
  2356.            cast = TRUE;
  2357.  
  2358.            /* Check casting syntax, vocabulary name within parethesis */ 
  2359.            if ((s[0] == '(') && (s[l] == ')')) {
  2360.  
  2361.                /* Remove the parenthesis from the input string */
  2362.                s[l] = 0;
  2363.                tos++;
  2364.  
  2365.                /* Search for the symbol again */
  2366.                dofind();
  2367.                flag = spop;
  2368.                
  2369.                /* If found check that its a vocabulary */
  2370.                if (flag) {
  2371.                    ENTRY *v = (ENTRY *) spop;
  2372.  
  2373.                    /* Check that the symbol is really a vocabulary */
  2374.                    if (v -> code == VOCABULARY) {
  2375.  
  2376.                        /* Scan for a new symbol */
  2377.                        spush(' ');
  2378.                        doword();
  2379.  
  2380.                        /* Exit top loop if end of input stream */
  2381.                        if (io_eof()) {
  2382.                            spop;
  2383.                            return;
  2384.                        }
  2385.  
  2386.                        /* And look for it in the given vocabulary */
  2387.                        spush(v);
  2388.                        dolookup();
  2389.                        flag = spop;
  2390.                        cast = flag;
  2391.                    }
  2392.                }
  2393.            }
  2394.        }
  2395.        
  2396.        /* If found then execute or thread the symbol */
  2397.        if (flag) {
  2398.            if (state.parameter == flag)
  2399.                dothread();
  2400.            else
  2401.                docommand();
  2402.        }
  2403.        else {
  2404.            /* Else check if it is a number */
  2405.            doqnumber();
  2406.            flag = spop;
  2407.            if (flag) {
  2408.                doliteral();
  2409.            }
  2410.            else {
  2411.                /* If not print error message and abort */
  2412.                (void) printf("%s ??\n", tos);
  2413.                doabort();
  2414.            }
  2415.        }
  2416.     }
  2417.     quited = TRUE;
  2418. }
  2419.  
  2420. NORMAL_CODE(interpret, forth83, "interpret", dointerpret);
  2421.  
  2422. void doquit()
  2423. {
  2424.     long e;
  2425.  
  2426.     /* Exception marking and handler */
  2427.     if (e = setjmp(restart)) {
  2428.        spush(e);
  2429.        doraise();
  2430.     }
  2431.     rinit;
  2432.     doleftbracket();
  2433.     dointerpret();
  2434. }
  2435.  
  2436. NORMAL_CODE(quit, interpret, "quit", doquit);
  2437.  
  2438. void doabort()
  2439. {
  2440.     /* Check if it is the foreground task */
  2441.     if (tp == foreground) {
  2442.        sinit; 
  2443.        doleftbracket();
  2444.        io_flush();
  2445.     }
  2446.  
  2447.     /* Terminate aborted tasks */
  2448.     doterminate();
  2449. }
  2450.  
  2451. NORMAL_CODE(kernel_abort, quit, "abort", doabort);
  2452.  
  2453. void doabortquote()
  2454. {
  2455.     spush('"');
  2456.     doword();
  2457.     dostringcopy();
  2458.     spush(&parenabortquote);
  2459.     dothread();
  2460.     docomma();
  2461. }
  2462.  
  2463. COMPILATION_IMMEDIATE_CODE(abortquote, kernel_abort, "abort\"", doabortquote);
  2464.     
  2465.  
  2466. /* DICTIONARY ADDRESSES */
  2467.  
  2468. void dohere()
  2469. {
  2470.     spush(dp);
  2471. }
  2472.  
  2473. NORMAL_CODE(here, abortquote, "here", dohere);
  2474.  
  2475. static char thepad[PADSIZE];
  2476.  
  2477. NORMAL_CONSTANT(pad, here, "pad", (long) thepad);
  2478.  
  2479. static char thetib[TIBSIZE];
  2480.  
  2481. NORMAL_CONSTANT( tib, pad, "tib", (long) thetib);
  2482.  
  2483. void dotobody()
  2484. {
  2485.     tos = ((ENTRY *) tos) -> parameter;
  2486. }
  2487.  
  2488. NORMAL_CODE(tobody, tib, ">body", dotobody);
  2489.  
  2490. void dodotname()
  2491. {
  2492.     ENTRY *e = (ENTRY *) spop;
  2493.     
  2494.     (void) printf("%s", e -> name);
  2495. }
  2496.  
  2497. NORMAL_CODE(dotname, tobody, ".name", dodotname);
  2498.  
  2499.  
  2500. /* COMPILER AND INTERPRETER WORDS */
  2501.  
  2502. void dosharpif()
  2503. {
  2504.     long symbol;
  2505.     long flag = spop;
  2506.  
  2507.     if (!flag) {
  2508.        do {
  2509.            spush(' ');
  2510.            doword();
  2511.            symbol = spop;
  2512.            if (STREQ(symbol, "#if")) {
  2513.                dosharpelse();
  2514.                spush(' ');
  2515.                doword();
  2516.                symbol = spop;
  2517.            }
  2518.        } while (!((STREQ(symbol, "#else") || STREQ(symbol, "#then"))));
  2519.     }
  2520. }
  2521.  
  2522. IMMEDIATE_CODE(sharpif, dotname, "#if", dosharpif);
  2523.  
  2524. void dosharpelse()
  2525. {
  2526.     long symbol;
  2527.     
  2528.     do {
  2529.        spush(' ');
  2530.        doword();
  2531.        symbol = spop;
  2532.        if (STREQ(symbol, "#if")) {
  2533.            dosharpelse();
  2534.            spush(' ');
  2535.            doword();
  2536.            symbol = spop;
  2537.        }
  2538.     } while (!STREQ(symbol, "#then"));
  2539. }
  2540.  
  2541. IMMEDIATE_CODE(sharpelse, sharpif, "#else", dosharpelse);
  2542.  
  2543. void dosharpthen()
  2544. {
  2545.  
  2546. }
  2547.  
  2548. IMMEDIATE_CODE(sharpthen, sharpelse, "#then", dosharpthen);
  2549.  
  2550. void dosharpifdef()
  2551. {
  2552.     spush(' ');
  2553.     doword();
  2554.     dofind();
  2555.     doswap();
  2556.     spop;
  2557.     dosharpif();
  2558. }
  2559.  
  2560. IMMEDIATE_CODE(sharpifdef, sharpthen, "#ifdef", dosharpifdef);
  2561.  
  2562. void dosharpifundef()
  2563. {
  2564.     spush(' ');
  2565.     doword();
  2566.     dofind();
  2567.     doswap();
  2568.     spop;
  2569.     dozeroequals();
  2570.     dosharpif();
  2571. }
  2572.  
  2573. IMMEDIATE_CODE(sharpifundef, sharpifdef, "#ifundef", dosharpifundef);
  2574.  
  2575. void dosharpinclude()
  2576. {
  2577.     int  flag;
  2578.     char *fname;
  2579.     
  2580.     spush(' ');
  2581.     doword();
  2582.     fname = (char *) spop;
  2583.     if (flag = io_infile(fname) == IO_UNKNOWN_FILE)
  2584.        (void) printf("%s: file not found\n", fname);
  2585.     else if (flag == IO_TOO_MANY_FILES)
  2586.        (void) printf("%s: too many files open\n", fname);
  2587. }
  2588.  
  2589. NORMAL_CODE(sharpinclude, sharpifundef, "#include", dosharpinclude);
  2590.  
  2591. void dosharppath()
  2592. {
  2593.     int flag;
  2594.     
  2595.     spush(' ');
  2596.     doword();
  2597.     if (flag = io_path((char *) tos, IO_PATH_FIRST) == IO_UNKNOWN_PATH)
  2598.        (void) printf("%s: unknown environment variable\n", tos);
  2599.     else if (flag == IO_TOO_MANY_PATHS)
  2600.        (void) printf("%s: too many paths defined\n", tos);
  2601.     spop;
  2602. }
  2603.  
  2604. NORMAL_CODE(sharppath, sharpinclude, "#path", dosharppath);
  2605.  
  2606. void doparen()
  2607. {
  2608.     char c;
  2609.     
  2610.     while (c = io_getchar())
  2611.        if (c == ')') return;
  2612.        else if (c == '(') doparen();
  2613.        else if (io_eof()) return;
  2614. }
  2615.  
  2616. IMMEDIATE_CODE(paren, sharppath, "(", doparen);
  2617.  
  2618. void dobackslash()
  2619. {
  2620.     io_skip('\n');
  2621. }
  2622.  
  2623. IMMEDIATE_CODE(backslash, paren, "\\", dobackslash);
  2624.  
  2625. void docomma()
  2626. {
  2627.     *dp++ = spop;
  2628. }
  2629.  
  2630. NORMAL_CODE(comma, backslash, ",", docomma);
  2631.  
  2632. void doallot()
  2633. {
  2634.     long n = spop;
  2635.  
  2636.     dp = (long *) ((char *) dp + n);
  2637. }
  2638.  
  2639. NORMAL_CODE(allot, comma, "allot", doallot);
  2640.  
  2641. void dodoes()
  2642. {
  2643.     spush((theframed ? &parenunlinkdoes: &parendoes));
  2644.     dothread();
  2645.     doremovelocals();
  2646. }
  2647.  
  2648. COMPILATION_IMMEDIATE_CODE(does, allot, "does>", dodoes);
  2649.  
  2650. void doimmediate()
  2651. {
  2652.     ((ENTRY *) current -> parameter) -> mode |= IMMEDIATE;
  2653. }
  2654.  
  2655. NORMAL_CODE(immediate, does, "immediate", doimmediate);
  2656.  
  2657. void doexecution()
  2658. {
  2659.     ((ENTRY *) current -> parameter) -> mode |= EXECUTION;
  2660. }
  2661.  
  2662. NORMAL_CODE(execution, immediate, "execution", doexecution);
  2663.  
  2664. void docompilation()
  2665. {
  2666.     ((ENTRY *) current -> parameter) -> mode |= COMPILATION;
  2667. }
  2668.  
  2669. NORMAL_CODE(compilation, execution, "compilation", docompilation);
  2670.  
  2671. void doprivate()
  2672. {
  2673.     ((ENTRY *) current -> parameter) -> mode |= PRIVATE;
  2674. }
  2675.  
  2676. NORMAL_CODE(private, compilation, "private", doprivate);
  2677.  
  2678. void dobracketcompile()
  2679. {
  2680.     dotick();
  2681.     dothread();
  2682. }
  2683.  
  2684. COMPILATION_IMMEDIATE_CODE(bracketcompile, private, "[compile]", dobracketcompile);
  2685.  
  2686. void docompile()
  2687. {
  2688.     spush(*ip++);
  2689.     dothread();
  2690. }
  2691.  
  2692. COMPILATION_CODE(compile, bracketcompile, "compile", docompile);
  2693.  
  2694. void doqcompile()
  2695. {
  2696.     if (state.parameter) docompile();
  2697. }
  2698.  
  2699. COMPILATION_CODE(qcompile, compile, "?compile", doqcompile);
  2700.  
  2701. NORMAL_VARIABLE(state, qcompile, "state", FALSE);
  2702.  
  2703. void docompiling()
  2704. {
  2705.     spush(state.parameter);
  2706. }
  2707.  
  2708. NORMAL_CODE(compiling, state, "compiling", docompiling);
  2709.  
  2710. void doliteral()
  2711. {
  2712.     if (state.parameter) {
  2713.        spush(&parenliteral);
  2714.        dothread();
  2715.        docomma();
  2716.     }
  2717. }
  2718.  
  2719. COMPILATION_IMMEDIATE_CODE(literal, compiling, "literal", doliteral);
  2720.  
  2721. void doleftbracket()
  2722. {
  2723.     state.parameter = FALSE;
  2724. }
  2725.  
  2726. IMMEDIATE_CODE(leftbracket, literal, "[", doleftbracket);
  2727.  
  2728. void dorightbracket()
  2729. {
  2730.     state.parameter = TRUE;
  2731. }
  2732.  
  2733. NORMAL_CODE(rightbracket, leftbracket, "]", dorightbracket);
  2734.  
  2735. void doword()
  2736. {
  2737.     char brkchr = (char) spop;
  2738.     
  2739.     (void) io_skipspace();
  2740.     (void) io_scan(thetib, brkchr);
  2741.     spush(thetib);
  2742. }
  2743.  
  2744. NORMAL_CODE(kernel_word, rightbracket, "word", doword);
  2745.  
  2746.  
  2747. /* VOCABULARIES */
  2748.  
  2749. NORMAL_CONSTANT(kernel_context, kernel_word, "context", (long) context);
  2750.  
  2751. NORMAL_CONSTANT(kernel_current, kernel_context, "current", (long) ¤t);
  2752.  
  2753. void dolast()
  2754. {
  2755.     spush((theframed ? (long) theframed : current -> parameter));
  2756. }
  2757.  
  2758. NORMAL_CODE(last, kernel_current, "last", dolast);
  2759.  
  2760. void dodefinitions()
  2761. {
  2762.     current = context[0];
  2763. }
  2764.  
  2765. NORMAL_CODE(definitions, last, "definitions", dodefinitions);
  2766.  
  2767. void doonly()
  2768. {
  2769.     long v;
  2770.  
  2771.     /* Flush the entry cache */
  2772.     spush(FALSE);
  2773.     dorestore();
  2774.  
  2775.     /* Remove all vocabularies except the first */
  2776.     for (v = 1; v < CONTEXTSIZE; v++) context[v] = (ENTRY *) NIL;
  2777.  
  2778.     /* And make it definition vocabulary */
  2779.     current = context[0];
  2780. }
  2781.  
  2782. NORMAL_CODE(only, definitions, "only", doonly);
  2783.  
  2784. void dorestore()
  2785. {
  2786.     register long i;           /* Iteration variable */
  2787.     register ENTRY *e;         /* Pointer to parameter entry */
  2788.     register ENTRY *p;         /* Pointer to current entry */
  2789.  
  2790.     /* Access parameter and check if an entry */
  2791.     e = (ENTRY *) spop;
  2792.     if (e) {
  2793.  
  2794.        /* Flush all enties until the parameter symbol */
  2795.        for (p = (ENTRY *) current -> parameter; p && (p != e); p = p -> link)
  2796.            cache[hash(p -> name)] = (ENTRY *) NIL;
  2797.  
  2798.        /* If the entry was found remove all symbols until this entry */
  2799.        if (p == e) current -> parameter = (long) e;
  2800.     }
  2801.     else {
  2802.        
  2803.        /* Flush the entry cache */
  2804.        for (i = 0; i < CACHESIZE; i++) cache[i] = (ENTRY *) NIL;
  2805.     }
  2806. }
  2807.  
  2808. NORMAL_CODE(restore, only, "restore", dorestore);
  2809.  
  2810. void dotick()
  2811. {
  2812.     long flag;
  2813.  
  2814.     spush(' ');
  2815.     doword();
  2816.     dofind();
  2817.     flag = spop;
  2818.     if (!flag) {
  2819.        (void) printf("%s: unknown symbol\n", tos);
  2820.        doabort();
  2821.     }
  2822. }
  2823.  
  2824. NORMAL_CODE(tick, restore, "'", dotick);
  2825.  
  2826. void dobrackettick()
  2827. {
  2828.     dotick();
  2829.     doliteral();
  2830. }
  2831.  
  2832. COMPILATION_IMMEDIATE_CODE(brackettick, tick, "[']", dobrackettick);
  2833.  
  2834. void dolookup() 
  2835. {
  2836.     register ENTRY *v;         /* Vocabulary pointer */
  2837.     register ENTRY *e;         /* Entry pointer */
  2838.     register char  *s;         /* Symbol to be found */
  2839.     
  2840.     /* Fetch parameters and initate entry pointer */
  2841.     v = (ENTRY *) spop;
  2842.     s = (char *) tos;
  2843.     
  2844.     /* Iterate over the linked list of entries */
  2845.     for (e = (ENTRY *) v -> parameter; e; e = e -> link)
  2846.  
  2847.        /* Compare the symbol and entry string */
  2848.        if (STREQ(s, e -> name)) {
  2849.  
  2850.            /* Check if the entry is currently visible */
  2851.            if (!(((e -> mode & COMPILATION) && (!state.parameter)) ||
  2852.                  ((e -> mode & EXECUTION) && (state.parameter))  ||
  2853.                  ((e -> mode & PRIVATE) && (v != current)))) {
  2854.  
  2855.                /* Return the entry and compilation mode */
  2856.                tos = (long) e;
  2857.                spush((e -> mode & IMMEDIATE ? 1 : -1));
  2858.                return;
  2859.            }
  2860.        }
  2861.     spush(FALSE);
  2862. }
  2863.  
  2864. NORMAL_CODE(lookup, brackettick, "lookup", dolookup);
  2865.  
  2866. #ifdef PROFILE
  2867. void docollision()
  2868. {
  2869.     /* Add collision statistics to profile information */
  2870. }
  2871. #endif
  2872.  
  2873. void dofind()
  2874. {
  2875.     ENTRY *e;                  /* Entry in the entry cache */
  2876.     char  *n;                  /* Name string of entry to be found */
  2877.     long  v;                   /* Index into vocabulary set */
  2878.     
  2879.     /* Access the string to be found */
  2880.     n = (char *) tos;
  2881.  
  2882.     /* Check for cached entry */
  2883.     if (e = cache[hash(n)]) {
  2884.  
  2885.        /* Compare the string and the entry name */
  2886.        if (STREQ(tos, e -> name)) {
  2887.  
  2888.            /* Check if the entry is currently visible */
  2889.            if (!(((e -> mode & COMPILATION) && (!state.parameter)) ||
  2890.                  ((e -> mode & EXECUTION) && (state.parameter)))) {
  2891.                tos = (long) e;
  2892.                spush((e -> mode & IMMEDIATE ? 1 : -1));
  2893.                return;
  2894.            }
  2895.        }
  2896. #ifdef PROFILE
  2897.        else {
  2898.            docollision();
  2899.        }
  2900. #endif 
  2901.     }
  2902.     
  2903.     /* For each vocabulary in the current search chain */
  2904.     for (v = 0; context[v] && v < CONTEXTSIZE; v++) {
  2905.        spush(context[v]);
  2906.        dolookup();
  2907.        if (tos) {
  2908.            cache[hash(n)] = (ENTRY *) snth(0);
  2909.            return;
  2910.        }
  2911.        else {
  2912.            spop;
  2913.        }
  2914.     }
  2915.     spush(FALSE);
  2916. }
  2917.  
  2918. NORMAL_CODE(find, lookup, "find", dofind);
  2919.  
  2920. void doforget()
  2921. {
  2922.     dotick();
  2923.     tos = (long) ((ENTRY *) tos) -> link; 
  2924.     dorestore();
  2925. }
  2926.  
  2927. NORMAL_CODE(forget, find, "forget", doforget);
  2928.  
  2929. void dowords()
  2930. {
  2931.     ENTRY *e;                  /* Pointer to entries */
  2932.     long   v;                  /* Index into vocabulary set */
  2933.     long   l;                  /* String length */
  2934.     long   s;                  /* Spaces between words */
  2935.     long   c;                  /* Column counter */
  2936.     long   i;                  /* Loop index */
  2937.     
  2938.     /* Iterate over all vocabularies in the search set */
  2939.     for (v = 0; v < CONTEXTSIZE && context[v]; v++) {
  2940.  
  2941.        /* Print vocabulary name */
  2942.        (void) printf("VOCABULARY %s", context[v] -> name);
  2943.        if (context[v] == current) (void) printf(" DEFINITIONS");
  2944.        (void) putchar('\n');
  2945.  
  2946.        /* Access linked list of enties and initiate column counter */
  2947.        c = 0;
  2948.  
  2949.        /* Iterate over all entries in the vocabulary */
  2950.        for (e = (ENTRY *) context[v] -> parameter; e; e = e -> link) {
  2951.  
  2952.            /* Check if the entry is current visible */
  2953.            if (!(((e -> mode & COMPILATION) && (!state.parameter)) ||
  2954.                  ((e -> mode & EXECUTION) && (state.parameter))  ||
  2955.                  ((e -> mode & PRIVATE) && (context[v] != current)))) {
  2956.                
  2957.                /* Print the entry string. Check that space is available */
  2958.                l = strlen(e -> name);
  2959.                s = (c ? (COLUMNWIDTH - (c % COLUMNWIDTH)) : 0);
  2960.                c = c + s + l;
  2961.                if (c < LINEWIDTH) {
  2962.                    for (i = 0; i < s; i++) (void) putchar(' '); 
  2963.                }
  2964.                else {
  2965.                    (void) putchar('\n');
  2966.                    c = l;
  2967.                }
  2968.                (void) printf("%s", e -> name);
  2969.            }
  2970.        }
  2971.  
  2972.        /* End the list of words and separate the vocabularies */
  2973.        (void) putchar('\n');
  2974.        (void) putchar('\n');
  2975.     }
  2976. }
  2977.  
  2978. IMMEDIATE_CODE(words, forget, "words", dowords);
  2979.  
  2980.  
  2981. /* DEFINING NEW VOCABULARY ENTRIES */
  2982.  
  2983. ENTRY *makeentry(name, code, mode, parameter)
  2984.     char *name;                        /* String for the new entry */
  2985.     long code, mode, parameter; /* Entry parameters */
  2986. {
  2987.     /* Allocate space for the entry */
  2988.     ENTRY *e = (ENTRY *) malloc(sizeof(ENTRY));
  2989.  
  2990.     /* Insert into the current vocabulary and set parameters */
  2991.     e -> link = (ENTRY *) current -> parameter;
  2992.     current -> parameter = (long) e;
  2993.  
  2994.     /* Set entry parameters */
  2995.     e -> name = strcpy(malloc((unsigned) strlen(name) + 1), name);
  2996.     e -> code = code;
  2997.     e -> mode = mode;
  2998.     e -> parameter = parameter;
  2999.  
  3000.     /* Cache entry */
  3001.     cache[hash(name)] = e;
  3002.     
  3003.     /* Return pointer to the new entry */
  3004.     return e;
  3005. }
  3006.  
  3007. void doentry()
  3008. {
  3009.     long flag, name, code, mode, parameter;
  3010.     ENTRY *forward;
  3011.     
  3012.     /* Try to find entry to check for forward declarations */
  3013.     forward = (ENTRY *) NIL;
  3014.     dodup();
  3015.     dofind();
  3016.     flag = spop;
  3017.     if (flag) {
  3018.        forward = (ENTRY *) spop;
  3019.     }
  3020.     else {
  3021.        spop;
  3022.     }
  3023.     
  3024.     /* Access name, code, mode and parameter field parameters */
  3025.     name = spop;
  3026.     code = spop;
  3027.     mode = spop;
  3028.     parameter = spop;
  3029.  
  3030.     /* Create the new entry */
  3031.     (void) makeentry((char *) name, code, mode, parameter);
  3032.  
  3033.     /* If found and forward the redirect parameter field of initial entry */
  3034.     if (forward && forward -> code == FORWARD) {
  3035.        forward -> parameter = current -> parameter;
  3036.        if (verbose)
  3037.            (void) printf("%s: forward definition resolved\n", forward -> name);
  3038.     }
  3039. }
  3040.  
  3041. NORMAL_CODE(kernel_entry, words, "entry", doentry);
  3042.  
  3043. void doforward()
  3044. {
  3045.     spush(0);
  3046.     spush(NORMAL);
  3047.     spush(FORWARD);
  3048.     spush(' ');
  3049.     doword();
  3050.     doentry();
  3051. }
  3052.  
  3053. NORMAL_CODE(forward, kernel_entry, "forward", doforward);
  3054.  
  3055. static ENTRY *thelast = (ENTRY *) NIL;
  3056.  
  3057. void docolon()
  3058. {
  3059.     align(dp);
  3060.     dohere();
  3061.     spush(HIDDEN);
  3062.     spush(COLON);
  3063.     spush(' ');
  3064.     doword();
  3065.     doentry();
  3066.     dorightbracket();
  3067.     thelast = (ENTRY *) current -> parameter;
  3068. }
  3069.  
  3070. NORMAL_CODE(colon, forward, ":", docolon);
  3071.  
  3072. void dosemicolon()
  3073. {
  3074.     spush((theframed ? &parenunlinksemicolon : &parensemicolon));
  3075.     dothread();
  3076.     doleftbracket();
  3077.     doremovelocals();
  3078.     if (thelast) {
  3079.        thelast -> mode = NORMAL;
  3080.        cache[hash(thelast -> name)] = thelast;
  3081.        thelast = (ENTRY *) NIL;
  3082.     }
  3083. }
  3084.  
  3085. COMPILATION_IMMEDIATE_CODE(semicolon, colon, ";", dosemicolon);
  3086.  
  3087. void docreate()
  3088. {
  3089.     align(dp);
  3090.     dohere();
  3091.     spush(NORMAL);
  3092.     spush(CREATE);
  3093.     spush(' ');
  3094.     doword();
  3095.     doentry();
  3096. }
  3097.  
  3098. NORMAL_CODE(create, semicolon, "create", docreate);
  3099.  
  3100. void dovariable()
  3101. {
  3102.     spush(0);
  3103.     spush(NORMAL);
  3104.     spush(VARIABLE);
  3105.     spush(' ');
  3106.     doword();
  3107.     doentry();
  3108. }
  3109.  
  3110. NORMAL_CODE(variable, create, "variable", dovariable);
  3111.  
  3112. void doconstant()
  3113. {
  3114.     spush(NORMAL);
  3115.     spush(CONSTANT);
  3116.     spush(' ');
  3117.     doword();
  3118.     doentry();
  3119. }
  3120.  
  3121. NORMAL_CODE(constant, variable, "constant", doconstant);
  3122.  
  3123. void dovocabulary()
  3124. {
  3125.     spush(&forth);
  3126.     spush(NORMAL);
  3127.     spush(VOCABULARY);
  3128.     spush(' ');
  3129.     doword();
  3130.     doentry();
  3131. }
  3132.  
  3133. NORMAL_CODE(vocabulary, constant, "vocabulary", dovocabulary);
  3134.  
  3135. void dofield()
  3136. {
  3137.     spush(NORMAL);
  3138.     spush(FIELD);
  3139.     spush(' ');
  3140.     doword();
  3141.     doentry();
  3142. }
  3143.  
  3144. NORMAL_CODE(field, vocabulary, "field", dofield);
  3145.  
  3146.  
  3147. /* INITIALIZATION OF THE KERNEL */
  3148.  
  3149. void kernel_initiate(first, last, users, parameters, returns)
  3150.     ENTRY *first, *last;
  3151.     int users, parameters, returns;
  3152. {
  3153.     /* Link user symbols into vocabulary chain if given */
  3154.     if (first && last) {
  3155.        forth.parameter = (long) first;
  3156.        last -> link = (ENTRY *) &field;
  3157.     }
  3158.     
  3159.     /* Create the foreground task object */
  3160.     foreground = maketask((long) users, (long) parameters, (long) returns, NIL);
  3161.     
  3162.     s0 = foreground -> s0;
  3163.     sp = foreground -> sp;
  3164.     r0 = foreground -> r0;
  3165.     rp = foreground -> rp;
  3166.     ip = foreground -> ip;
  3167.     fp = foreground -> fp;
  3168.     ep = foreground -> ep;
  3169.  
  3170.     /* Make the foreground task the current task */
  3171.     tp = foreground;
  3172.  
  3173. }
  3174.  
  3175. void kernel_finish()
  3176. {
  3177.     /* Future clean up function for kernel */
  3178. }
  3179.