home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume1 / cforth / part2 < prev    next >
Encoding:
Internet Message Format  |  1986-11-30  |  57.5 KB
  1. Date: Tue, 30 Apr 85 15:19:04 est
  2. From: mit-eddie!ihnp4!purdue!iuvax!apratt (Allan Pratt)
  3. Subject: FORTH INTERPRETER IN C (Part 2 of 3)
  4.  
  5. : Run this shell script with "sh" not "csh"
  6. PATH=:/bin:/usr/bin:/usr/ucb
  7. export PATH
  8. echo 'x - Makefile'
  9. sed 's/^X//' <<'//go.sysin dd *' >Makefile
  10. test:        forth.core forth
  11.  
  12. forth:        forth.o prims.o
  13.         cc -o forth forth.o prims.o
  14.  
  15. forth.o:    forth.c common.h forth.h prims.h
  16.         cc -c forth.c
  17.  
  18. prims.o:    prims.c forth.h prims.h
  19.         cc -c prims.c
  20.  
  21. all:        forth forth.core l2b b2l
  22.  
  23. nf:        nf.o lex.yy.o
  24.         cc -o nf nf.o lex.yy.o
  25.  
  26. nf.o:        nf.c forth.lex.h common.h
  27.         cc -c nf.c
  28.  
  29. lex.yy.o:    lex.yy.c forth.lex.h
  30.         cc -c lex.yy.c
  31.  
  32. lex.yy.c:    forth.lex
  33.         lex forth.lex
  34.         rm -f lex.tmp
  35.         sed "s/yylex(){/TOKEN *yylex(){/" lex.yy.c > lex.tmp
  36.         mv -f lex.tmp lex.yy.c
  37.  
  38. forth.core:    nf forth.dict
  39.         nf < forth.dict
  40.  
  41. # l2b: convert a line file to a block file. Usage: l2b < linefile > blockfile
  42. l2b:        l2b.c
  43.         cc -o l2b l2b.c
  44.  
  45. # b2l: convert a block file to a line file. Usage: b2l < blockfile > linefile
  46. b2l:        b2l.c
  47.         cc -o b2l b2l.c
  48.  
  49. # forth.line and forth.block are not included here, because you can't tell
  50. # which one is more recent. To make one from the other, use b2l and l2b.
  51. //go.sysin dd *
  52. echo 'x - b2l.c'
  53. sed 's/^X//' <<'//go.sysin dd *' >b2l.c
  54. X/* usage: block2line < blockfile > linefile
  55.  * takes a block file from stdin and makes a cr-delimited file to stdout
  56.  * with 64 characters per line, 16 lines per screen
  57.  */
  58.  
  59. #include <stdio.h>
  60.  
  61. main()
  62. {
  63.     int i, j, screen;
  64.     char buf[64];    /* max line size */
  65.  
  66.     while(1) {
  67.         printf("------------------ SCREEN %d ------------------\n",
  68.             screen++);
  69.         for (i=0; i<16; i++) {
  70.         if (fread(buf,sizeof(char),64,stdin) < 64) exit(0);
  71.         j = 63;
  72.         while (buf[j] == ' ' && j >= 0) j--;
  73.         if (j >= 0) fwrite(buf,sizeof(char),j+1,stdout);
  74.         putchar('\n');
  75.         }
  76.     }
  77. }
  78. //go.sysin dd *
  79. echo 'x - common.h'
  80. sed 's/^X//' <<'//go.sysin dd *' >common.h
  81. X/*
  82.  * This is common.h -- the defines which are common to both nf.c and forth.c.
  83.  * These include the name of the SAVEFILE (the file which nf.c creates,
  84.  * and the default image which f.c loads), and all those boundaries for
  85.  * memory areas, like UP, USER_DEFAULTS, etc.
  86.  */
  87.  
  88. X/*
  89.  * NOTE THAT THIS FORTH IMPLENTATION REQUIRES int TO BE TWICE THE SIZE OF short
  90.  */
  91.  
  92. #define TRUE 1
  93. #define FALSE 0
  94.  
  95. X/*
  96.    TWEAKING: define TRACE to allow tracing, BREAKPOINT to allow breakpoints.
  97.    Each of these takes up time in the inner interpreter, so if you are
  98.    not debugging, take them out. Without TRACE, the DOTRACE primitive will
  99.    still work, but the TRON primitive will have no effect.
  100. */
  101.  
  102. #define TRACE
  103. #define BREAKPOINT
  104.  
  105. X/* external files */
  106.  
  107. #define COREFILE "forth.core"    /* used for input to f.c, output from nf.c */
  108. #define DICTFILE "forth.dict"    /* used for input to nf.c */
  109. #define MAPFILE "forth.map"    /* used for dump-output from nf.c */
  110. #define DUMPFILE "forth.dump"    /* used for dump-output from f.c */
  111. #define BLOCKFILE "forth.block"    /* used for block i/o */
  112. #define SAVEFILE "forth.newcore"    /* used by (SAVE) primitive */
  113.  
  114. X/* MEMORY ALLOCATION CONSTANTS */
  115.  
  116. X/* Set INITMEM to the size of the largest FORTH model you want nf to create.
  117.    This can be just barely enough (within GULPFRQ words) to hold the initial 
  118.    FORTH image, or it can be the maximum size you will ever want. Somewhere in
  119.    between is best, so you don't fragment memory with realloc() calls right
  120.    away. */
  121.  
  122. #define INITMEM (13*1024)    /* 13K holds the distribution forth.dict */
  123.   
  124. X/* set MAXMEM to the MOST MEMORY YOU EVER WANT ALLOCATED TO FORTH. FORTH will
  125.    never allocate more than MAXMEM*sizeof(short) for the FORTH memory image.
  126.    Note that other functions, like open, read, and write, allocate memory
  127.    transparent to the forth system. MAXMEM will not affect these. Also,
  128.    note that realloc is used to grow the FORTH image, and LARGE CHUNKS of
  129.    fragmented memory can result. If you want to keep a tight rein on things,
  130.    set MAXMEM to the same number as INITMEM, and the FORTH memory image will
  131.    be fixed at that many SHORTs, with no later allocations, and therefore
  132.    no fragmenting.
  133.     A value of 0 for MAXMEM means "allocate as much as you want" -- 
  134.    useful on virtual-memory machines. Also note that each malloc and realloc
  135.    is checked for success (of course), so MAXMEM is truly a maximal limit.
  136.     NOTE THAT MODELS OF GREATER THAN 32K MAY CRASH BECAUSE OF SIGNED
  137.    VALUES. THIS HAS NOT BEEN ADEQUATELY TESTED.
  138. */
  139.  
  140. #define MAXMEM 0
  141.  
  142. X/* set NSCR to the number of disk blocks from you want to keep in FORTH memory
  143.    at any time. If your disks are fast enough, you might want a low number
  144.    like 3. If you have lots of memory, you might want something like 10.
  145.    In any case, this number MUST BE AT LEAST 2. */
  146.  
  147. #define NSCR 5    /* MUST BE AT LEAST 2 */
  148.  
  149. X/* end of implementation-dependent DEFINEs. */
  150.  
  151. X/* define bits for the first byte of each word */
  152. #define MSB 0x80        /* says this is first byte */
  153. #define IMMEDIATE 0x40        /* Says this word is immediate */
  154. #define SMUDGE 0x20        /* on = you can't find this word */
  155.  
  156. #define MAXWIDTH 0x20        /* Maximum length of a word */
  157.  
  158. #define KBBUFF 1024        /* one disk-quantum */
  159. #define US 32            /* words needed for user variables */
  160. #define CO (KBBUFF+4)
  161.                 /* size of a disk buffer w/4 words overhead */
  162. #define NBUF NSCR        /* number of disk buffers, at 1 to a screen */
  163.  
  164. X/* Memory Management boundaries -- each name refers to the FIRST location of
  165.    the indicated field Some fields are nested, and I have tried to show the
  166.    nesting nature in the defines. */
  167.  
  168. #define ORIGIN 0        /* the Origin of this system is zero */
  169. #define ORIG ORIGIN        /* another word for ORIGIN */
  170. #define SCRATCHSIZE 16        /* From ORIGIN to ORIGIN+SCRATCHSIZE is scratch
  171.                    space which is saved across saves: see the
  172.                    definition of this space below */
  173. #define USER_DEFAULTS (ORIGIN+SCRATCHSIZE)    /* 16 */
  174.                 /* start of user variable initial-values space
  175.                    -- it's DEFS-SIZE bytes long */
  176. #define DEFS_SIZE 8        /* words in the USER DEFAULTS area */
  177. #define UP (USER_DEFAULTS+DEFS_SIZE)    /* User var space, US bytes long */
  178. #define TIB_START (UP+US)    /* Terminal input buffer, same size as a
  179.                    disk buffer (KBBUFF words), starts after
  180.                    user variables */
  181. #define TIB_END (TIB_START + KBBUFF)
  182. #define CS_SIZE 128        /* words in the Computation Stack */
  183. #define RS_SIZE 256        /* words in the Return Stack */
  184. #define INITS0 (TIB_START+KBBUFF+CS_SIZE) /* c. stack grows down CSS words,
  185.                    bangs into end of TIB */
  186. #define INITR0 (INITS0+RS_SIZE)    /* Return stack grows down RSS words, bangs
  187.                    into INITS0. */
  188. #define BUF1 INITR0        /* buffers start right after r. stack */
  189. #define DPBASE (BUF1+(NBUF*CO))    /* Dictionary starts just past last buffer */
  190.  
  191. X/* low-core definitions */
  192. #define LIMIT 0            /* mem[LIMIT] tells the size of core */
  193. #define COLDIP 1        /* mem[COLDIP] holds the CFA of ABORT */
  194.         /* you can set ip=mem[COLDIP] and call next() to start */
  195.  
  196. X/* these locations define the warm-start machine state: if you save the FORTH
  197.    memory image, then restart it, execution will start up with these values.
  198.    This save/restore system is not implemented, so leave mem[SAVEDIP] = 0. */
  199.  
  200. #define SAVEDIP 2        /* mem[SAVEDIP] = 0 for newly-generated
  201.                    systems, or the IP for a saved system */
  202. #define SAVEDSP 3        /* restored when SAVEDIP != 0 */
  203. #define SAVEDRP 4        /* ditto */
  204.  
  205. #define ABORTIP 5        /* need this to recover from ^C */
  206. //go.sysin dd *
  207. echo 'x - forth.c'
  208. sed 's/^X//' <<'//go.sysin dd *' >forth.c
  209. X/*
  210.  * forth.c
  211.  * 
  212.  * Portable FORTH interpreter in C
  213.  *
  214.  * Author: Allan Pratt, Indiana University (iuvax!apratt)
  215.  *         Spring, 1984
  216.  * References: 8080 and 6502 fig-FORTH source listings (not the greatest refs
  217.  *         in the world...)
  218.  *
  219.  * This program is intended to be compact, portable, and pretty complete.
  220.  * It is also intended to be in the public domain, and distribution should
  221.  * include this notice to that effect.
  222.  *
  223.  * This file contains the support code for all interpreter functions.
  224.  * the file prims.c contains code for the C-coded primitives, and the
  225.  * file forth.h connects the two with definitions.
  226.  *
  227.  * The program nf.c generates a new forth.core file from the dictionary
  228.  * forth.dict, using common.h to tie it together with this program.
  229.  */
  230.  
  231.  
  232. #include <stdio.h>
  233. #include <signal.h>
  234. #include <ctype.h>    /* only for isxdigit */
  235.  
  236. #include "common.h"
  237.  
  238. #include "forth.h"
  239.  
  240. #include "prims.h"    /* macro-defined primitives */
  241.  
  242. X/* declare globals which are defined in forth.h */
  243.  
  244. unsigned short csp, rsp, ip, w;
  245. short *mem;
  246. int trace, tracedepth, debug, breakenable, breakpoint, qtermflag, forceip;
  247. int nobuf;
  248. XFILE *blockfile;
  249. long bfilesize;
  250. char *bfilename;    /* block file name (change with -f ) */
  251. char *cfilename;    /* core file name  (change with -l ) */
  252. char *sfilename;    /* save file name  (change with -s ) */
  253.  
  254. X/*
  255.              ----------------------------------------------------
  256.                                SYSTEM FUNCTIONS
  257.              ----------------------------------------------------
  258. */
  259.  
  260. errexit(s,p1,p2)        /* An error occurred -- clean up (?) and
  261.                    exit. */
  262. {
  263.     printf(s,p1,p2);
  264.     printf("ABORT FORTH!\nDumping to %s... ",DUMPFILE);
  265.     fflush(stdout);
  266.     memdump();
  267.     puts("done.");
  268.     exit(1);
  269. }
  270.  
  271. Callot (n)            /* allot n words in the dictionary */
  272. short n;
  273. {
  274.     unsigned newsize;
  275.  
  276.     mem[DP] += n;            /* move DP */
  277.     if (mem[DP] + GULPFRQ > mem[LIMIT]) {    /* need space */
  278.     newsize = mem[DP] + GULPSIZE;
  279.     if (newsize > MAXMEM && MAXMEM)
  280.         errexit("ATTEMPT TO GROW PAST MAXMEM (%d) WORDS\n",MAXMEM);
  281.  
  282.     mem = (short *)realloc((char *)mem, newsize*sizeof(*mem));
  283.     if (mem == NULL)
  284.         errexit("REALLOC FAILED\n");
  285.     mem[LIMIT] = newsize;
  286.     }
  287. }
  288.  
  289. push(v)            /* push value v to cstack */
  290. short v;
  291. {
  292.     if (csp <= TIB_END)
  293.     errexit("PUSH TO FULL CALC. STACK\n");
  294.     mem[--csp] = v;
  295. }
  296.  
  297. short pop()            /* pop a value from comp. stack, and return
  298.                    it as the value of the function */
  299. {
  300.     if (csp >= INITS0) {
  301.     puts("Empty Stack!");
  302.     return 0;
  303.     }
  304.     return (mem[csp++]);
  305. }
  306.  
  307. rpush(v)
  308. short v;
  309. {
  310.     if (rsp <= INITS0)
  311.     errexit("PUSH TO FULL RETURN STACK");
  312.     mem[--rsp] = v;
  313. }
  314.  
  315. short rpop()
  316. {
  317.     if (rsp >= INITR0)
  318.     errexit("POP FROM EMPTY RETURN STACK!");
  319.     return (mem[rsp++]);
  320. }
  321.  
  322. pkey()            /* (KEY) -- wait for a key & return it */
  323. {
  324.     int c;
  325.     if ((c = getchar()) == EOF) errexit("END-OF-FILE ENCOUNTERED");
  326.     return(c);
  327. }
  328.  
  329. pqterm()            /* (?TERMINAL): 
  330.                     return true if BREAK has been hit */
  331. {
  332.     if (qtermflag) {
  333.         push(TRUE);
  334.         qtermflag = FALSE;    /* this influences ^C handling */
  335.     }
  336.     else push(FALSE);
  337. }
  338.  
  339. pemit()                /* (EMIT): c --    emit a character */
  340. {
  341.     putchar(pop() & 0x7f);    /* stdout is unbuffered */
  342. }
  343.  
  344. next()            /* instruction processor: control goes here
  345.                    almost right away, and cycles through here
  346.                    until you leave. */
  347.  
  348. X/* 
  349.  * This is the big kabloona. What it does is load the value at mem[ip]
  350.  * into w, increment ip, and invoke prim. number w. This implies that
  351.  * mem[ip] is the CFA of a word. What's in the CF of a word is the number
  352.  * of the primitive which should be executed. For a word written in FORTH,
  353.  * that primitive is "docol", which pushes ip to the return stack, then
  354.  * uses w+2 (the PFA of the word) as the new ip.  See "interp.doc" for
  355.  * more.
  356.  */
  357.  
  358. X/*
  359.  * There is an incredible hack going on here: the SPECIAL CASE mentioned in
  360.  * the code is for the word EXECUTE, which must set W itself and jump INSIDE
  361.  * the "next" loop, by-passing the first instruction. This has been made a
  362.  * special case: if the primitive to execute is zero, the special case is
  363.  * invoked, and the code for EXECUTE is put right in the NEXT loop. For this
  364.  * reason, "EXECUTE" MUST BE THE FIRST WORD IN THE DICTIONARY.
  365.  */
  366. {
  367.     short p;
  368.     
  369.     while (1) {
  370.     if (forceip) {        /* force ip to this value -- used by sig_int */
  371.         ip = forceip;
  372.         forceip = FALSE;
  373.     }
  374. #ifdef TRACE
  375.     if (trace) dotrace();
  376. #endif TRACE
  377.  
  378. #ifdef BREAKPOINT
  379.     if (breakenable && ip == breakpoint) dobreak();
  380. #endif BREAKPOINT
  381.  
  382.     w = mem[ip];
  383.     ip++;
  384.                 /* w, mem, and ip are all global. W is now
  385.                    a POINTER TO the primitive number to 
  386.                    execute, and ip points to the NEXT thread to
  387.                    follow. */
  388.  
  389. next1:                /* This is for the SPECIAL CASE */
  390.     p = mem[w];        /* p is the actual number of the primitive */
  391.     if (p == 0) {        /* SPECIAL CASE FOR EXECUTE! */
  392.         w = pop();        /* see above for explanation */
  393.         goto next1;
  394.     }
  395.     /* else */
  396.     switch(p) {
  397.     case LIT    :  lit(); break;
  398.     case BRANCH    :  branch(); break;
  399.     case ZBRANCH    :  zbranch(); break;
  400.     case PLOOP    :  ploop(); break;
  401.     case PPLOOP    :  pploop(); break;
  402.     case PDO    :  pdo(); break;
  403.     case I        :  i(); break;
  404.     case R        :  r(); break;
  405.     case DIGIT    :  digit(); break;
  406.     case PFIND    :  pfind(); break;
  407.     case ENCLOSE    :  enclose(); break;
  408.     case KEY    :  key(); break;
  409.     case PEMIT    :  pemit(); break;
  410.     case QTERMINAL    :  qterminal(); break;
  411.     case CMOVE    :  cmove(); break;
  412.     case USTAR    :  ustar(); break;
  413.     case USLASH    :  uslash(); break;
  414.     case AND    :  and(); break;
  415.     case OR        :  or(); break;
  416.     case XOR    :  xor(); break;
  417.     case SPFETCH    :  spfetch(); break;
  418.     case SPSTORE    :  spstore(); break;
  419.     case RPFETCH    :  rpfetch(); break;
  420.     case RPSTORE    :  rpstore(); break;
  421.     case SEMIS    :  semis(); break;
  422.     case LEAVE    :  leave(); break;
  423.     case TOR    :  tor(); break;
  424.     case FROMR    :  fromr(); break;
  425.     case ZEQ    :  zeq(); break;
  426.     case ZLESS    :  zless(); break;
  427.     case PLUS    :  plus(); break;
  428.     case DPLUS    :  dplus(); break;
  429.     case MINUS    :  minus(); break;
  430.     case DMINUS    :  dminus(); break;
  431.     case OVER    :  over(); break;
  432.     case DROP    :  drop(); break;
  433.     case SWAP    :  swap(); break;
  434.     case DUP    :  dup(); break;
  435.     case TDUP    :  tdup(); break;
  436.     case PSTORE    :  pstore(); break;
  437.     case TOGGLE    :  toggle(); break;
  438.     case FETCH    :  fetch(); break;
  439.     case CFETCH    :  cfetch(); break;
  440.     case TFETCH    :  tfetch(); break;
  441.     case STORE    :  store(); break;
  442.     case CSTORE    :  cstore(); break;
  443.     case TSTORE    :  tstore(); break;
  444.     case DOCOL    :  docol(); break;
  445.     case DOCON    :  docon(); break;
  446.     case DOVAR    :  dovar(); break;
  447.     case DOUSE    :  douse(); break;
  448.     case SUBTRACT    :  subtract(); break;
  449.     case EQUAL    :  equal(); break;
  450.     case NOTEQ    :  noteq(); break;
  451.     case LESS    :  less(); break;
  452.     case ROT    :  rot(); break;
  453.     case DODOES    :  dodoes(); break;
  454.     case DOVOC    :  dovoc(); break;
  455.     case ALLOT    :  allot(); break;
  456.     case PBYE    :  pbye(); break;
  457.     case TRON    :  tron(); break;
  458.     case TROFF    :  troff(); break;
  459.     case DOTRACE    :  dotrace(); break;
  460.     case PRSLW    :  prslw(); break;
  461.     case PSAVE    :  psave(); break;
  462.     case PCOLD    :  pcold(); break;
  463.     default        :  errexit("Bad execute-code %d\n",p); break;
  464.     }
  465.     }
  466. }
  467.  
  468. dotrace()
  469. {
  470.     short worka, workb, workc;
  471.     putchar('\n');
  472.     if (tracedepth) {        /* show any stack? */
  473.         printf("sp: %04x (", csp);
  474.         worka = csp;
  475.         for (workb = tracedepth; workb; workb--)
  476.             printf("%04x ",(unsigned short) mem[worka++]);
  477.         putchar(')');
  478.     }
  479.     printf(" ip=%04x ",ip);
  480.  
  481.     if (mem[R0]-rsp < RS_SIZE && mem[R0] - rsp > 0) /* if legal rsp */
  482.         for (worka = mem[R0]-rsp; worka; worka--) { /* indent */
  483.         putchar('>');
  484.         putchar(' ');
  485.         }
  486.     worka = mem[ip] - 3;        /* this is second-to-last letter, or
  487.                        the count byte */
  488.     while (!(mem[worka] & 0x80)) worka--;    /* skip back to count byte */
  489.     workc = mem[worka] & 0x2f;        /* workc is count value */
  490.     worka++;
  491.     while (workc--) putchar(mem[worka++] & 0x7f);
  492.     fflush(stdout);
  493.     if (debug) {        /* wait for \n -- any other input will dump */
  494.         char buffer[10];
  495.         if (*gets(buffer) != '\0') {
  496.             printf("dumping core... ");
  497.             fflush(stdout);
  498.             memdump();
  499.             puts("done.");
  500.         }
  501.     }
  502. }
  503.  
  504. #ifdef BREAKPOINT
  505. dobreak()
  506. {
  507.     int temp;
  508.     puts("Breakpoint.");
  509.     printf("Stack pointer = %x:\n",csp);
  510.     for (temp = csp; temp < INITS0; temp++)
  511.         printf("\t%04x",mem[temp]);
  512.     putchar('\n');
  513. }
  514. #endif BREAKPOINT
  515.  
  516. main(argc,argv)
  517. int argc;
  518. char *argv[];
  519. {
  520.     FILE *fp;
  521.     unsigned short size;
  522.     int i = 1;
  523.  
  524.     cfilename = COREFILE;    /* "forth.core" */
  525.     bfilename = BLOCKFILE;    /* "forth.block" */
  526.     sfilename = SAVEFILE;    /* "forth.newcore" */
  527.     trace = debug = breakenable = nobuf = 0;
  528.  
  529.     while (i < argc) {
  530.         if (*argv[i] == '-') {
  531.             switch (*(argv[i]+1)) {
  532. #ifdef TRACE
  533.             case 'd':            /* -d[n] */
  534.                 debug = 1;    /* ...and fall through */
  535.             case 't':            /* -t[n] */
  536.                 trace = TRUE;
  537.                 if (argv[i][2])
  538.                     tracedepth = (argv[i][2] - '0');
  539.                 else tracedepth = 0;
  540.                 break;
  541. #else !TRACE
  542.             case 'd':
  543.             case 't':
  544.                 fprintf(stderr,
  545.         "Must compile with TRACE defined for -t or -d\n");
  546.                 break;
  547. #endif TRACE
  548.             case 'c': if (++i == argc) usage(argv[0]);
  549.                   cfilename = argv[i];        /* -c file */
  550.                   break;
  551.             case 's': if (++i == argc) usage(argv[0]);
  552.                   sfilename = argv[i];        /* -s file */
  553.                   break;
  554. #ifdef BREAKPOINT
  555.             case 'p': if (++i == argc) usage(argv[0]);
  556.                   breakenable = TRUE;    /* -p xxxx */
  557.                   breakpoint = xtoi(argv[i]);
  558.                   break;
  559. #else !BREAKPOINT
  560.             case 'p': fprintf(stderr,
  561.         "Must compile with BREAKPOINT defined for -p");
  562.                   break;
  563. #endif BREAKPOINT
  564.             case 'b': if (++i == argc) usage();
  565.                   bfilename = argv[i]; /* -b blockfile */
  566.                   break;
  567.             case 'n': nobuf = TRUE;
  568.                   break;
  569.             default: usage(argv[0]);
  570.                  exit(1);
  571.             }
  572.         }
  573.         else usage(argv[0]);        /* not a dash */
  574.         i++;
  575.     }
  576.  
  577.     if ((fp = fopen(cfilename,"r")) == NULL) {
  578.         fprintf(stderr,"Forth: Could not open %s\n", cfilename);
  579.         exit(1);
  580.     }
  581.     if (fread(&size, sizeof(size), 1, fp) != 1) {
  582.         fprintf(stderr,"Forth: %s is empty.\n",cfilename);
  583.         exit(1) ;
  584.     }
  585.  
  586.     if ((mem = (short *)calloc(size, sizeof(*mem))) == NULL) {
  587.         fprintf(stderr, "Forth: unable to malloc(%d,%d)\n",
  588.             size, sizeof(*mem));
  589.         exit(1);
  590.     }
  591.  
  592.     mem[LIMIT] = size;
  593.  
  594.     if (fread(mem+1, sizeof(*mem), size-1, fp) != size-1) {
  595.         fprintf(stderr, "Forth: not %d bytes on %s.\n",
  596.             size, cfilename);
  597.         exit(1);
  598.     }
  599.  
  600.     fclose(fp);
  601.  
  602.     initsignals();
  603.  
  604.     getblockfile();
  605.  
  606.     if (!nobuf) setbuf(stdout,NULL);
  607.  
  608.     if (ip = mem[SAVEDIP]) {    /* if savedip != 0, that is */
  609.         csp = mem[SAVEDSP];
  610.         rsp = mem[SAVEDRP];
  611.         puts("restarting a saved FORTH image");
  612.     }
  613.     else {
  614.         ip = mem[COLDIP];    /* this is the ip passed from nf.c */
  615.             /* ip now points to a word holding the CFA of COLD */
  616.         rsp = INITR0;        /* initialize return stack */
  617.         csp = INITS0;
  618.     }
  619.     next();
  620.     /* never returns */
  621. }
  622.  
  623. usage(s)
  624. char *s;
  625. {
  626.     fprintf(stderr, "usage:\n");
  627.     fprintf(stderr, "%s [-t[n]] [-d[n]] [-p xxxx] [-n]\n",s);
  628.     fputs(stderr, "\t[-c corename] [-b blockname] [-s savename]\n");
  629.     fputs(stderr, "Where:\n");
  630.     fputs(stderr,
  631. "-t[n]\t\tsets trace mode\n");
  632.     fputs(stderr,
  633. "-d[n]\t\tsets trace mode and debug mode (waits for newline)");
  634.     fputs(stderr,
  635. "\t\t[n] above sets stack depth to display. Single digit, 0-9. Default 0.\n");
  636.     fputs(stderr,
  637. "-p xxxx\t\tsets a breakpoint at xxxx (in hex), shows stack when reached\n");
  638.     fputs(stderr,
  639. "-n\t\tleaves stdout line-buffered\n");
  640.     fprintf(stderr,
  641. "-c corename\tuses corename as the core image (default %s without -c)\n",
  642.         COREFILE);
  643.     fprintf(stderr,
  644. "-b blockname\tuses blockname as the blockfile (default %s without -b)\n",
  645.         BLOCKFILE);
  646.     fprintf(stderr,
  647. "-s savename\tuses savename as the save-image file (default %s without -s)\n",
  648.         SAVEFILE);
  649. }
  650.  
  651. memdump()        /* dump core. */
  652. {
  653.     int i;    /* top of RAM */
  654.     int temp, tempb, firstzero, nonzero;
  655.     char chars[9], outline[80], tstr[6];
  656.     FILE *dumpfile;
  657.  
  658.     dumpfile = fopen(DUMPFILE,"w");
  659.  
  660.     fprintf(dumpfile,
  661.         "CSP = 0x%x  RSP = 0x%x  IP = 0x%x  W = 0x%x  DP = 0x%x\n",
  662.         csp, rsp, ip, w, mem[DP]);
  663.  
  664.     for (temp = 0; temp < mem[LIMIT]; temp += 8) {
  665.         nonzero = FALSE;
  666.         sprintf(outline, "%04x:", temp);
  667.         for (i=temp; i<temp+8; i++) {
  668.             sprintf(tstr," %04x", (unsigned short)mem[i]);
  669.             strcat(outline, tstr);
  670.             tempb = mem[i] & 0x7f;
  671.             if (tempb < 0x7f && tempb >= ' ')
  672.                 chars[i%8] = tempb;
  673.             else
  674.                 chars[i%8] = '.';
  675.             nonzero |= mem[i];
  676.         }
  677.         if (nonzero) {
  678.             fprintf(dumpfile,"%s %s\n",outline,chars);
  679.             firstzero = TRUE;
  680.         }
  681.         else if (firstzero) {
  682.             fprintf(dumpfile, "----- ZERO ----\n");
  683.             firstzero = FALSE;
  684.         }
  685.     }
  686.     fclose(dumpfile);
  687. }
  688.  
  689. X/* here is where ctype.h is used */
  690.  
  691. xtoi(s)
  692. char *s;
  693. {                /*  convert hex ascii to integer */
  694.     int temp = 0;
  695.  
  696.     while (isxdigit (*s)) {    /* first non-hex char ends */
  697.     temp <<= 4;        /* mul by 16 */
  698.     if (isupper (*s))
  699.         temp += (*s - 'A') + 10;
  700.     else
  701.         if (islower (*s))
  702.         temp += (*s - 'a') + 10;
  703.         else
  704.         temp += (*s - '0');
  705.     s++;
  706.     }
  707.     return temp;
  708. }
  709.  
  710. X/*
  711.  * Interrupt (^C) handling: If the user hits ^C once, the next pqterm call
  712.  * will return TRUE. If he hits ^C again before pqterm is called, there will
  713.  * be a forced jump to ABORT next time we hit next(). If it is a primitive
  714.  * that is caught in an infinite loop, this won't help any.
  715.  */
  716.  
  717. sig_int()
  718. {
  719.     if (qtermflag) {        /* second time? */
  720.         forceip = mem[ABORTIP];    /* checked each time through next */
  721.         qtermflag = FALSE;
  722.         trace = FALSE;        /* stop tracing; reset */
  723.     }
  724.     else qtermflag = TRUE;
  725. }
  726.  
  727. initsignals()
  728. {
  729.     signal(SIGINT,sig_int);
  730. }
  731.  
  732. getblockfile()
  733. {
  734.     /* recall that opening with mode "a+" opens for reading and writing */
  735.     /* with the pointer positioned at the end; this is so ftell returns */
  736.     /* the size of the file.                        */
  737.  
  738.     if ((blockfile = fopen(bfilename, "a+")) == NULL)
  739.         errexit("Can't open blockfile \"%s\"\n", bfilename);
  740.     bfilesize = ftell(blockfile);
  741.  
  742.     printf("Block file has %d blocks.\n",(int) (bfilesize/1024) - 1);
  743. }
  744. //go.sysin dd *
  745. echo 'x - forth.dict'
  746. sed 's/^X//' <<'//go.sysin dd *' >forth.dict
  747. PRIM EXECUTE        0    ( cfa -- <execute word> )
  748. PRIM LIT        1    ( push the next value to the stack )
  749. PRIM BRANCH        2    ( branch by offset in next word )
  750. PRIM 0BRANCH        3    ( branch if zero by off. in next word )
  751. PRIM (LOOP)        4    ( end of a <DO> )
  752. PRIM (+LOOP)        5    ( inc -- <end of a <DO> w/increment != 1 )
  753. PRIM (DO)        6    ( limit init -- <begin a DO loop> )
  754. PRIM I            7    ( get loop index <R> )
  755. PRIM DIGIT        8    ( c -- DIGIT 1 | 0 <convert digit> )
  756. PRIM (FIND)        9    ( s -- s 0 | s NFA 1 <find word s> )
  757. PRIM ENCLOSE        10    ( addr c -- addr next first last <not quite> )
  758. PRIM KEY        11    ( -- c <get next char from input> )
  759. PRIM (EMIT)        12    ( c -- <put char to output> )
  760. PRIM ?TERMINAL        13    ( see if op. interrupted <like w/^C> )
  761. PRIM CMOVE        14    ( src dest count -- <move words>)
  762. PRIM U*            15    ( unsigned multiply )
  763. PRIM U/            16    ( unsigned divide )
  764. PRIM AND        17    ( a b -- a&b )
  765. PRIM OR            18    ( a b -- a|b )
  766. PRIM XOR        19    ( a b -- a%b )
  767. PRIM SP@        20    ( -- sp )
  768. PRIM SP!        21    ( -- <store empty value to sp> )
  769. PRIM RP@        22    ( -- rp )
  770. PRIM RP!        23    ( -- <store empty value to rp> )
  771. PRIM ;S            24    ( -- <pop r stack <end colon def'n>> )
  772. PRIM LEAVE        25    ( -- <set index = limit for a loop> )
  773. PRIM >R            26    ( a -- <push a to r stack> )
  774. PRIM R>            27    ( -- a <pop a from r stack )
  775. PRIM 0=            28    ( a -- !a <logical not> )
  776. PRIM 0<            29    ( a -- a<0 )
  777. PRIM +            30    ( a b -- a+b )
  778. PRIM D+            31    ( ahi alo bhi blo -- a+bhi a+blo )
  779. PRIM MINUS        32    ( a -- -a )
  780. PRIM DMINUS        33    ( ahi alo -- <-a>hi <-a>lo )
  781. PRIM OVER        34    ( a b -- a b a )
  782. PRIM DROP        35    ( a -- )
  783. PRIM SWAP        36    ( a b -- b a )
  784. PRIM DUP        37    ( a -- a a )
  785. PRIM 2DUP        38    ( a b -- a b a b )
  786. PRIM +!            39    ( val addr -- < *addr += val > )
  787. PRIM TOGGLE        40    ( addr mask -- <*addr %= mask> )
  788. PRIM @            41    ( addr -- *addr )
  789. PRIM C@            42    ( addr -- *addr )
  790. PRIM 2@            43    ( addr -- *addr+1 *addr )
  791. PRIM !            44    ( val addr -- <*addr = val> )
  792. PRIM C!            45    ( val addr -- <*addr = val> )
  793. PRIM 2!            46    ( bhi blo addr -- <*addr=blo, *addr+1=bhi )
  794. PRIM DOCOL        47    ( goes into CF of : definitions )
  795. PRIM DOCON        48    ( goes into CF of constants )
  796. PRIM DOVAR        49    ( goes into CF of variables )
  797. PRIM DOUSE        50    ( goes into CF of user variables )
  798. PRIM -            51    ( a b -- a-b )
  799. PRIM =            52    ( a b -- a==b)
  800. PRIM !=            53    ( a b -- a!=b)
  801. PRIM <            54    ( a b -- a<b )
  802. PRIM ROT        55    ( a b c -- c a b )
  803. PRIM DODOES        56    ( place holder; this value goes into CF )
  804. PRIM DOVOC        57
  805. PRIM R            58    ( same as I, but must be a primitive )
  806. PRIM ALLOT        59    ( primitive because of mem. management )
  807. PRIM (BYE)        60    ( executes exit <pop[]>; )
  808. PRIM TRON        61    ( depth -- trace to this depth )
  809. PRIM TROFF        62    ( stop tracing )
  810. PRIM DOTRACE        63    ( trace once )
  811. PRIM (R/W)        64    ( BUFFER FLAG ADDR -- read if flag=1, write/0 )
  812. PRIM (SAVE)        65    ( Save current environment )
  813. PRIM (COLD)        66
  814.  
  815. ( end of primitives )
  816.  
  817. CONST 0 0
  818. CONST 1 1
  819. CONST 2 2
  820. CONST 3 3
  821. CONST -1 -1
  822. CONST BL 32        ( A SPACE, OR BLANK )
  823. CONST C/L 64
  824. CONST B/BUF 1024
  825. CONST B/SCR 1
  826. CONST #BUFF 5        ( IMPLEMENTATION DEPENDENT )
  827.  
  828. CONST WORDSIZE 1    ( EXTENSION: WORDSIZE IS THE NUMBER OF BYTES IN A WORD.
  829.               USUALLY, THIS IS TWO, BUT WITH PSEUDO-MEMORY
  830.               ADDRESSED AS AN ARRAY OF WORDS, IT'S ONE. )
  831.  
  832. CONST FIRST 0        ( ADDRESS OF THE FIRST BUFFER AND END OF BUFFER SPACE )
  833. CONST LIMIT 0        ( the reader fills these in with INITR0 and DPBASE )
  834.  
  835. USER S0        24
  836. USER R0        25
  837. USER TIB    26
  838. USER WIDTH    27
  839. USER WARNING    28
  840. USER FENCE    29
  841. USER DP        30
  842. USER VOC-LINK    31
  843. USER BLK    32
  844. USER IN        33
  845. USER ERRBLK    34
  846. USER ERRIN    35
  847. USER OUT    36
  848. USER SCR    37
  849. USER OFFSET    38
  850. USER CONTEXT    39
  851. USER CURRENT    40
  852. USER STATE    41
  853. USER BASE    42
  854. USER DPL    43
  855. USER FLD    44
  856. USER CSP    45
  857. USER R#        46
  858. USER HLD    47
  859.  
  860. VAR USE 0        ( These two are filled in by COLD )
  861. VAR PREV 0        ( to the same as the constant FIRST )
  862. CONST SEC/BLK 1
  863.  
  864. : EMIT
  865.   (EMIT)
  866.   1 OUT +! ;
  867.  
  868. : CR
  869.   LIT 13 EMIT
  870.   LIT 10 EMIT
  871.   0 OUT ! ;
  872.  
  873. : NOP ;    ( DO-NOTHING )
  874.  
  875. : +ORIGIN ;    ( ADD ORIGIN OF SYSTEM; IN THIS CASE, 0 )
  876.  
  877. : 1+
  878.   1 + ;
  879.  
  880. : 2+
  881.   2 + ;
  882.  
  883. : 1-
  884.   1 - ;
  885.  
  886. : ++        ( ADDR -- <INCREMENTS VAL AT ADDR> )
  887.   1 SWAP +! ;    ( MY OWN EXTENSION )
  888.  
  889. : --        ( ADDR -- <DECREMENTS VAL AT ADDR> )
  890.   -1 SWAP +! ;    ( MY OWN EXTENSION )
  891.  
  892. : HERE        ( -- DP )
  893.   DP @ ;
  894.  
  895. : ,        ( V -- <PLACES V AT DP AND INCREMENTS DP>)
  896.   HERE !
  897.   WORDSIZE ALLOT ;    ( CHANGE FROM MODEL FOR WORDSIZE )
  898.  
  899. : C,        ( C -- <COMPILE A CHARACTER. SAME AS , WHEN WORDSIZE=1> )
  900.   HERE C!
  901.   1 ALLOT ;
  902.  
  903. : U<        ( THIS IS TRICKY. )
  904.     2DUP XOR 0<    ( SIGNS DIFFERENT? )
  905.     0BRANCH U1    ( NO: GO TO U1 )
  906.     DROP 0< 0=    ( YES; ANSWER IS [SECOND > 0] )
  907.     BRANCH U2    ( SKIP TO U2 <END OF WORD> )
  908. LABEL U1
  909.     - 0<    ( SIGNS ARE THE SAME. JUST SUBTRACT
  910.           AND TEST NORMALLY )
  911. LABEL U2
  912.     ;
  913.  
  914. : >        ( CHEAP TRICK )
  915.   SWAP < ;
  916.  
  917. : <>        ( NOT-EQUAL )
  918.   != ;
  919.  
  920. : SPACE        ( EMIT A SPACE )
  921.   BL EMIT
  922. ;
  923.  
  924. : -DUP        ( V -- V | V V <DUPLICATE IF V != 0> )
  925.   DUP
  926.   0BRANCH DDUP1    ( SKIP TO END IF IT WAS ZERO )
  927.   DUP
  928. LABEL DDUP1
  929. ;
  930.  
  931. : TRAVERSE    ( A DIR -- A <TRAVERSE A WORD FROM NFA TO LFA
  932.           <DIR = 1> OR LFA TO NFA <DIR = -1> )
  933.     SWAP
  934. LABEL T1
  935.     OVER    ( BEGIN )
  936.     +
  937.     LIT 0x7F OVER C@ <    ( HIGH BIT CLEAR? )
  938.     0BRANCH T1        ( UNTIL )
  939.     SWAP DROP ;
  940.  
  941. : LATEST        ( NFA OF LAST WORD DEFINED )
  942.   CURRENT @ @ ;
  943.  
  944. : LFA            ( GO FROM PFA TO LFA )
  945.   2 - ;            ( 2 IS WORDSIZE*2 )
  946.  
  947. : CFA            ( GO FROM PFA TO CFA )
  948.   WORDSIZE - ;
  949.  
  950. : NFA            ( GO FROM PFA TO NFA )
  951.   3 -            ( NOW AT LAST CHAR )
  952.   -1 TRAVERSE ;        ( 3 IS WORDSIZE*3 )
  953.  
  954. : PFA            ( GO FROM NFA TO PFA )
  955.   1 TRAVERSE        ( NOW AT LAST CHAR )
  956.   3 + ;            ( 3 IS WORDSIZE*3 )
  957.  
  958. : !CSP            ( SAVE CSP AT USER VAR CSP )
  959.   SP@ CSP ! ;
  960.  
  961. : (ABORT)
  962.   ABORT
  963. ;
  964.  
  965. : ERROR            ( N -- <ISSUE ERROR #N> )
  966.   WARNING @ 0<        ( WARNING < 0 MEANS <ABORT> )
  967.   0BRANCH E1
  968.   (ABORT)        ( IF )
  969. LABEL E1
  970.   HERE COUNT TYPE (.") "?"    ( THEN )
  971.   MESSAGE
  972.   SP!            ( EMPTY THE STACK )
  973.   BLK @ -DUP        ( IF LOADING, STORE IN & BLK )
  974.   0BRANCH E2
  975.   ERRBLK ! IN @ ERRIN !    ( IF )
  976. LABEL E2
  977.   QUIT            ( THEN )
  978. ;
  979.  
  980. : ?ERROR        ( F N -- <IF F, DO ERROR #N> )
  981.   SWAP
  982.   0BRANCH QERR1
  983.   ERROR            ( IF <YOU CAN'T RETURN FROM ERROR> )
  984. LABEL QERR1
  985.   DROP            ( THEN )
  986. ;
  987.  
  988. : ?COMP            ( GIVE ERR#17 IF NOT COMPILING )
  989.   STATE @ 0= LIT 17 ?ERROR
  990. ;
  991.  
  992. : ?EXEC            ( GIVE ERR#18 IF NOT EXECUTING )
  993.   STATE @ LIT 18 ?ERROR
  994. ;
  995.  
  996. : ?PAIRS        ( GIVE ERR#19 IF PAIRS DON'T MATCH )
  997.   - LIT 19 ?ERROR
  998. ;
  999.  
  1000. : ?CSP            ( GIVE ERR#20 IF CSP & SP DON'T MATCH )
  1001.   SP@ CSP @ - LIT 20 ?ERROR
  1002. ;
  1003.  
  1004. : ?LOADING        ( GIVE ERR#21 IF NOT LOADING )
  1005.   BLK @ 0= LIT 22 ?ERROR
  1006. ;
  1007.  
  1008. : COMPILE        ( COMPILE THE CFA OF THE NEXT WORD TO DICT )
  1009.   ?COMP
  1010.   R> DUP        ( GET OUR RETURN ADDRESS )
  1011.   WORDSIZE + >R        ( SKIP NEXT; ORIG. ADDR STILL ON TOS )
  1012.   @ ,
  1013. ;
  1014.  
  1015. : [            ( BEGIN EXECUTING )
  1016.   0 STATE !
  1017. ;*
  1018.  
  1019. : ]            ( END EXECUTING )
  1020.   LIT 0xC0 STATE !
  1021. ;*
  1022.  
  1023. : SMUDGE        ( TOGGLE COMPLETION BIT OF LATEST WORD )
  1024.   LATEST        ( WHEN THIS BIT=1, WORD CAN'T BE FOUND )
  1025.   LIT 0x20 TOGGLE
  1026. ;
  1027.  
  1028. : :
  1029.             ( DEFINE A WORD )
  1030.   ?EXEC
  1031.   !CSP
  1032.   CURRENT @ CONTEXT !
  1033.   CREATE ]        ( MAKE THE WORD HEADER AND BEGIN COMPILING )
  1034.   (;CODE) DOCOL
  1035. ;*
  1036.  
  1037. : ;            ( END A DEFINITION )
  1038.   ?CSP            ( CHECK THAT WE'RE DONE )
  1039.   COMPILE ;S        ( PLACE ;S AT THE END )
  1040.   SMUDGE [        ( MAKE THE WORD FINDABLE AND BEGIN INTERPRETING )
  1041. ;*
  1042.  
  1043. : CONSTANT
  1044.   CREATE SMUDGE ,
  1045.   (;CODE) DOCON
  1046. ;
  1047.  
  1048. : VARIABLE
  1049.   CONSTANT
  1050.   (;CODE) DOVAR
  1051. ;
  1052.  
  1053. : USER
  1054.   CONSTANT
  1055.   (;CODE) DOUSE
  1056. ;
  1057.  
  1058. : HEX            ( GO TO HEXADECIMAL BASE )
  1059.   LIT 0x10 BASE ! ;
  1060.  
  1061. : DECIMAL        ( GO TO DECIMAL BASE )
  1062.   LIT 0x0A BASE !
  1063. ;
  1064.  
  1065. : ;CODE                ( unused without an assembler )
  1066.   ?CSP COMPILE (;CODE) [ NOP    ( "ASSEMBLER" might go where nop is )
  1067. ;*
  1068.  
  1069. : (;CODE)            ( differs from the normal def'n )
  1070.   R> @ @ LATEST PFA CFA !
  1071. ;
  1072.  
  1073. : <BUILDS        ( UNSURE )
  1074.   0 CONSTANT ;        ( NOTE CONSTANT != CONST )
  1075.  
  1076. : DOES>            ( UNSURE )
  1077.   R> LATEST PFA !
  1078.   (;CODE) DODOES
  1079. ;
  1080.  
  1081. : COUNT            ( ADDR -- ADDR+1 COUNT )
  1082.   DUP 1+ SWAP C@ ;    ( CONVERTS THE <STRING> ADDR TO A FORM SUITABLE
  1083.               FOR "TYPE" )
  1084.  
  1085. : TYPE
  1086.   -DUP
  1087.   0BRANCH TYPE1
  1088.   OVER + SWAP        ( GET START .. END ADDRS )
  1089.   (DO)
  1090. LABEL TYPE2
  1091.     I C@ EMIT
  1092.   (LOOP) TYPE2
  1093.   BRANCH TYPE3
  1094. LABEL TYPE1
  1095.   DROP
  1096. LABEL TYPE3
  1097. ;
  1098.  
  1099. : -TRAILING        ( addr count -- addr count <count adjusted to
  1100.               exclude trailing blanks> )
  1101.   DUP 0 (DO)        ( DO )
  1102. LABEL TRAIL1
  1103.     OVER OVER + 1 - C@ BL -
  1104.     0BRANCH TRAIL2
  1105.     LEAVE BRANCH TRAIL3    ( IF )
  1106. LABEL TRAIL2
  1107.     1 -            ( ELSE )
  1108. LABEL TRAIL3
  1109.   (LOOP) TRAIL1        ( THEN LOOP )
  1110. ;
  1111.  
  1112. : (.")            ( PRINT A COMPILED STRING )
  1113.   R COUNT
  1114.   DUP 1+ R> + >R TYPE
  1115. ;
  1116.  
  1117. : ."            ( COMPILE A STRING IF COMPILING,
  1118.               OR PRINT A STRING IF INTERPRETING )
  1119.   LIT '"'
  1120.   STATE @
  1121.   0BRANCH QUOTE1
  1122.   COMPILE (.") WORD HERE C@ 1+ ALLOT    ( IF )
  1123.   BRANCH QUOTE2
  1124. LABEL QUOTE1
  1125.   WORD HERE COUNT TYPE            ( ELSE )
  1126. LABEL QUOTE2
  1127. ;*                    ( THEN )
  1128.  
  1129. : EXPECT        ( MODIFIED EXPECT lets UNIX input editing & echoing )
  1130.             ( change EMIT to DROP below if not -echo )
  1131.   OVER + OVER        ( start of input buffer is on top of stack )
  1132.   DUP 0 SWAP C!        ( smack a zero at the start to catch empty lines )
  1133.   (DO)            ( above is an added departure <read "hack"> )
  1134. LABEL EXPEC1
  1135.     KEY
  1136.             ( Comment this region out if using stty cooked )
  1137.     DUP LIT 8 = 0BRANCH EXPEC2
  1138.     DROP DUP I = DUP R> 2 - + >R 0BRANCH EXPEC6
  1139.     LIT 7 BRANCH EXPEC7
  1140. LABEL EXPEC6
  1141.     LIT 8        ( output for backspace )
  1142. LABEL EXPEC7
  1143.     BRANCH EXPEC3
  1144.             ( End of region to comment out for stty cooked )
  1145. LABEL EXPEC2
  1146.     DUP LIT '\n' = 0BRANCH EXPEC4    ( IF )
  1147.     LEAVE DROP BL 0 BRANCH EXPEC5
  1148. LABEL EXPEC4                ( ELSE )
  1149.     DUP
  1150. LABEL EXPEC5                ( THEN )
  1151.     I C! 0 I 1+ !
  1152. LABEL EXPEC3
  1153.     EMIT        ( use DROP here for stty echo, EMIT for -echo )
  1154.     (LOOP) EXPEC1
  1155.     DROP
  1156. ;
  1157.  
  1158. : QUERY
  1159.   TIB @            ( ADDRESS OF BUFFER )
  1160.   B/BUF            ( SIZE OF BUFFER )
  1161.   EXPECT        ( GET A LINE )
  1162.   0 IN !        ( PREPARE FOR INTERPRET )
  1163. ;
  1164.  
  1165. : {NUL}            ( THIS GETS TRANSLATED INTO A SINGLE NULL BYTE )
  1166.   BLK @
  1167.   0BRANCH NULL1
  1168.   BLK ++ 0 IN !        ( IF )
  1169.   BLK @ B/SCR 1 - AND 0=
  1170.   0BRANCH NULL2
  1171.   ?EXEC
  1172.   R>            ( IF )
  1173.   DROP
  1174. LABEL NULL2
  1175.   BRANCH NULL3        ( ENDIF ELSE )
  1176. LABEL NULL1
  1177.   R> DROP
  1178. LABEL NULL3        ( ENDIF )
  1179. ;*
  1180.  
  1181. : FILL            ( START COUNT VALUE -- <FILL COUNT WORDS, FROM START,
  1182.               WITH VALUE )
  1183.   SWAP -DUP
  1184.   0BRANCH FILL1
  1185.   SWAP ROT SWAP OVER C!    ( IF <NON-NULL COUNT> )
  1186.   DUP 1+ ROT 1 -
  1187.   CMOVE
  1188.   BRANCH FILL2
  1189. LABEL FILL1
  1190.   DROP DROP
  1191. LABEL FILL2
  1192. ;
  1193.  
  1194. : ERASE            ( START COUNT -- <ZERO OUT MEMORY> )
  1195.   0 FILL
  1196. ;
  1197.  
  1198. : BLANKS        ( START COUNT -- <FILL WITH BLANKS> )
  1199.   BL FILL
  1200. ;
  1201.  
  1202. : HOLD            ( C -- <PLACE C AT --HLD> )
  1203.   HLD -- HLD @ C!
  1204. ;
  1205.  
  1206. : PAD            ( -- ADDR <OF PAD SPACE> )
  1207.   HERE LIT 0x44 +
  1208. ;
  1209.  
  1210. : WORD            ( C -- <GET NEXT WORD TO END OF DICTIONARY,
  1211.               DELIMITED WITH C OR NULL )
  1212.         ( LOADING PART OF THIS IS COMMENTED OUT )
  1213.   BLK @ -DUP
  1214.   0BRANCH W1
  1215.       BLOCK        ( IF loading )
  1216.       BRANCH W2 
  1217. LABEL W1
  1218.     TIB @        ( ELSE )
  1219. LABEL W2        ( ENDIF )
  1220.   IN @ + SWAP ENCLOSE    ( GET THE WORD )
  1221.   HERE LIT 0x22 BLANKS    ( BLANK SPACE AFTER WORD )
  1222.   IN +! OVER - >R R HERE C! + HERE 1+ R> CMOVE
  1223. ;
  1224.  
  1225. : (NUMBER)
  1226. LABEL NUM1
  1227.   1+
  1228.   DUP >R C@ BASE @ DIGIT
  1229.   0BRANCH NUM2        ( WHILE )
  1230.   SWAP BASE @ U* DROP
  1231.   ROT BASE @ U* D+
  1232.   DPL @ 1+
  1233.   0BRANCH NUM3
  1234.   DPL ++        ( IF )
  1235. LABEL NUM3
  1236.   R>            ( ENDIF )
  1237.   BRANCH NUM1        ( REPEAT )
  1238. LABEL NUM2
  1239.   R>
  1240. ;
  1241.  
  1242. : NUMBER
  1243.   0 0 ROT DUP 1+ C@
  1244.   LIT '-' = DUP >R + -1
  1245. LABEL N1        ( BEGIN )
  1246.   DPL ! (NUMBER) DUP C@ BL !=
  1247.   0BRANCH N2        ( WHILE )
  1248.   DUP C@ LIT '0' != 0 ?ERROR 0    ( . )
  1249.   BRANCH N1        ( REPEAT )
  1250. LABEL N2
  1251.   DROP R>
  1252.   0BRANCH N3        ( IF )
  1253.   DMINUS
  1254. LABEL N3        ( ENDIF )
  1255. ;
  1256.  
  1257. : -FIND
  1258.   BL WORD ( HERE CONTEXT @ @ <FIND> DUP 0= 0BRANCH FIND1 DROP )
  1259.   HERE LATEST (FIND)
  1260. ( LABEL FIND1 )
  1261. ;
  1262.  
  1263. : ID.            ( NFA -- <PRINT ID OF A WORD > )
  1264.   PAD LIT 0x5F BLANKS
  1265.   DUP PFA LFA OVER - PAD SWAP CMOVE
  1266.   PAD COUNT LIT 0x1F AND TYPE SPACE
  1267. ;
  1268.  
  1269. : CREATE        ( MAKE A HEADER FOR THE NEXT WORD )
  1270.   -FIND
  1271.   0BRANCH C1
  1272.   DROP NFA ID. LIT 4 MESSAGE SPACE    ( NOT UNIQUE )
  1273. LABEL C1
  1274.   HERE DUP C@ WIDTH @ MIN 1+ ALLOT    ( MAKE ROOM )
  1275.   DUP LIT 0xA0 TOGGLE            ( MAKE IT UNFINDABLE )
  1276.   HERE 1 - LIT 0x80 TOGGLE        ( SET HI BIT )
  1277.   LATEST ,            ( DO LF )
  1278.   CURRENT @ !            ( UPDATE FOR LATEST )
  1279.   LIT 999 ,            ( COMPILE ILLEGAL VALUE TO CODE FIELD )
  1280. ;
  1281.  
  1282. : [COMPILE]        ( COMPILE THE NEXT WORD, EVEN IF IT'S IMMEDIATE )
  1283.   -FIND 0= 0 ?ERROR DROP CFA ,
  1284. ;*
  1285.  
  1286. : LITERAL
  1287.   STATE @
  1288.   0BRANCH L1
  1289.   COMPILE LIT ,
  1290. LABEL L1
  1291. ;*
  1292.  
  1293. : DLITERAL
  1294.   STATE @
  1295.   0BRANCH D1
  1296.   SWAP LITERAL LITERAL
  1297. LABEL D1
  1298. ;*
  1299.  
  1300. : ?STACK        ( ERROR IF STACK OVERFLOW OR UNDERFLOW )
  1301.   S0 @ SP@ U< 1 ?ERROR    ( SP > S0 MEANS UNDERFLOW )
  1302.   SP@ TIB @ U< LIT 7 ?ERROR  ( SP < R0 MEANS OVERFLOW: THIS IS IMPLEMENTATION-
  1303.                 DEPENDENT; I KNOW THAT THE CS IS JUST 
  1304.                 ABOVE THE TIB. )
  1305. ;
  1306.  
  1307. : INTERPRET
  1308. LABEL I1
  1309.   -FIND            ( BEGIN )
  1310.   0BRANCH I2
  1311.   STATE @ <        ( IF )
  1312.   0BRANCH I3
  1313.   CFA ,            ( IF )
  1314.   BRANCH I4
  1315. LABEL I3
  1316.   CFA EXECUTE        ( ELSE )
  1317. LABEL I4
  1318.   ?STACK        ( ENDIF )
  1319.   BRANCH I5
  1320. LABEL I2
  1321.   HERE NUMBER DPL @ 1+
  1322.   0BRANCH I6
  1323.   DLITERAL        ( IF )
  1324.   BRANCH I7
  1325. LABEL I6
  1326.   DROP LITERAL        ( ELSE )
  1327. LABEL I7
  1328.   ?STACK        ( ENDIF ENDIF )
  1329. LABEL I5
  1330.   BRANCH I1        ( AGAIN )
  1331. ;
  1332.  
  1333. : IMMEDIATE        ( MAKE MOST-RECENT WORD IMMEDIATE )
  1334.   LATEST LIT 0x40 TOGGLE
  1335. ;
  1336.  
  1337. ( *** These are commented out because we don't handle vocabularies ***
  1338.  
  1339. : VOCABULARY
  1340.   <BUILDS LIT 0xA081 ,
  1341.   CURRENT @ CFA , HERE VOC-LINK @ , VOC-LINK ! DOES>
  1342.   WORDSIZE + CONTEXT !
  1343. ;
  1344.  
  1345. : DEFINITIONS
  1346.   CONTEXT @ CURRENT !
  1347. ;
  1348. *** End of commenting-out *** )
  1349.  
  1350. : (        ( COMMENT )
  1351.   LIT ')'    ( CLOSING PAREN )
  1352.   WORD
  1353. ;*
  1354.  
  1355. : QUIT
  1356.   0 BLK ! [
  1357. LABEL Q1
  1358.   RP! CR QUERY INTERPRET    ( BEGIN )
  1359.   STATE @ 0=
  1360.   0BRANCH Q2
  1361.   (.") "OK"            ( IF )
  1362. LABEL Q2
  1363.   BRANCH Q1            ( ENDIF AGAIN )
  1364. ;
  1365.  
  1366. : ABORT
  1367.   SP! DECIMAL ?STACK CR
  1368.   .CPU                ( PRINT THE GREETING )
  1369.   ( FORTH )
  1370.   QUIT
  1371. ;
  1372.  
  1373. : COLD
  1374.   (COLD)
  1375.   VOC-LINK @ CONTEXT !        ( INITIALIZE CONTEXT )
  1376.   CONTEXT @ CURRENT !        ( MAKE CONTEXT CURRENT )
  1377.   FIRST USE !
  1378.   FIRST PREV !
  1379.   EMPTY-BUFFERS
  1380.   1 WARNING !            ( USE SCREEN 4 FOR ERROR MESSAGES )
  1381.   ABORT
  1382. ;
  1383.  
  1384. : WARM
  1385.   EMPTY-BUFFERS
  1386.   ABORT
  1387. ;
  1388.  
  1389. : S->D
  1390.   DUP 0<
  1391.   0BRANCH S2D1
  1392.   -1            ( HIGH WORD IS ALL 1S )
  1393.   BRANCH S2D2
  1394. LABEL S2D1
  1395.   0
  1396. LABEL S2D2
  1397. ;
  1398.  
  1399. : +-
  1400.   0<
  1401.   0BRANCH PM1
  1402.   MINUS
  1403. LABEL PM1
  1404. ;
  1405.  
  1406. : D+-
  1407.   0<
  1408.   0BRANCH DPM1
  1409.   DMINUS
  1410. LABEL DPM1
  1411. ;
  1412.  
  1413. : ABS
  1414.   DUP +-
  1415. ;
  1416.  
  1417. : DABS
  1418.   DUP D+-
  1419. ;
  1420.  
  1421. : MIN
  1422.   2DUP >
  1423.   0BRANCH MIN1
  1424.   SWAP
  1425. LABEL MIN1
  1426.   DROP
  1427. ;
  1428.  
  1429. : MAX
  1430.   2DUP <
  1431.   0BRANCH MAX1
  1432.   SWAP
  1433. LABEL MAX1
  1434.   DROP
  1435. ;
  1436.  
  1437. ( MATH STUFF )
  1438.  
  1439. : M*
  1440.   2DUP XOR >R ABS SWAP ABS U* R> D+-
  1441. ;
  1442.  
  1443. : M/
  1444.   OVER >R >R DABS R ABS U/
  1445.   R> R XOR +- SWAP
  1446.   R> +- SWAP
  1447. ;
  1448.  
  1449. : *        ( MULTIPLY, OF COURSE )
  1450.   M* DROP
  1451. ;
  1452.  
  1453. : /MOD
  1454.   >R S->D R> M/
  1455. ;
  1456.  
  1457. : /            ( DIVIDE <AND CONQUOR> )
  1458.   /MOD SWAP DROP
  1459. ;
  1460.  
  1461. : MOD
  1462.   /MOD DROP
  1463. ;
  1464.  
  1465. : */MOD
  1466.   >R M* R> M/
  1467. ;
  1468.  
  1469. : */
  1470.   */MOD
  1471.   SWAP DROP
  1472. ;
  1473.  
  1474. : M/MOD
  1475.   >R 0 R U/ R> SWAP >R U/ R>
  1476. ;
  1477.  
  1478. ( END OF MATH STUFF )
  1479.  
  1480. : (LINE)        ( LINE SCR -- ADDR C/L )
  1481.   >R C/L B/BUF */MOD R> B/SCR * + BLOCK +
  1482.   C/L
  1483. ;
  1484.  
  1485. : .LINE            ( LINE SCR -- )
  1486.   (LINE) -TRAILING TYPE
  1487. ;
  1488.  
  1489. : MESSAGE
  1490.   WARNING @ 0BRANCH MSG1
  1491.   -DUP 0BRANCH MSG2        ( message # 0 is no message at all )
  1492.   LIT 4 OFFSET @ B/SCR / - .LINE SPACE ( messages are on screen 4 )
  1493.   BRANCH MSG2
  1494. LABEL MSG1
  1495.   (.") "MSG # " .
  1496. LABEL MSG2
  1497. ;
  1498.  
  1499. ( DISK-ORIENTED WORDS )
  1500.  
  1501. : +BUF
  1502.   LIT 1028            ( 1K PLUS 4 BYTES OVERHEAD, CO from defines )
  1503.   + DUP LIMIT = 0BRANCH P1
  1504.   DROP FIRST
  1505. LABEL P1
  1506.   DUP PREV @ -
  1507. ;
  1508.  
  1509. : UPDATE             ( MARK BUFFER AS MODIFIED )
  1510.   PREV @ @ LIT 0X8000 OR PREV @ !
  1511. ;
  1512.  
  1513. : EMPTY-BUFFERS
  1514.   FIRST LIMIT OVER - ERASE
  1515. ;
  1516.  
  1517. : BUFFER
  1518.   USE @ DUP >R
  1519. LABEL BUF1
  1520.   +BUF 0BRANCH BUF1        ( LOOP UNTIL +BUF RETURNS NONZERO )
  1521.   USE ! R @ 0< 0BRANCH BUF2    ( SEE IF IT'S DIRTY <sign bit is dirty bit> )
  1522.   R 2+ R @ LIT 0X7FFF AND 0 R/W    ( WRITE THIS DIRTY BUFFER )
  1523. LABEL BUF2
  1524.   R !
  1525.   R PREV !
  1526.   R> 2+
  1527. ;
  1528.  
  1529. : BLOCK
  1530.   OFFSET @ + >R PREV @ DUP @ R - DUP +
  1531.   0BRANCH BLOCK1
  1532. LABEL BLOCK2
  1533.   +BUF 0=
  1534.   0BRANCH BLOCK3
  1535.   DROP R BUFFER DUP R 1 R/W 2 -
  1536. LABEL BLOCK3
  1537.   DUP @ R - DUP + 0= 0BRANCH BLOCK2
  1538.   DUP PREV ! 
  1539. LABEL BLOCK1
  1540.   R> DROP 2+
  1541. ;
  1542.  
  1543. : R/W                ( ADDR F BUFNO -- read if F=1, write if 0 )
  1544.   (R/W)
  1545.   
  1546. ;
  1547.  
  1548. : FLUSH
  1549.   #BUFF 1+ 0 (DO) 
  1550. LABEL FLUSH1
  1551.       0 BUFFER DROP 
  1552.   (LOOP) FLUSH1
  1553. ;
  1554.  
  1555. : LOAD
  1556.   BLK @ >R IN @ >R 0 IN !
  1557.   B/SCR * BLK !
  1558.   INTERPRET
  1559.   R> IN ! R> BLK !
  1560. ;
  1561.  
  1562. : -->
  1563.   (.") "--> "
  1564.   ?LOADING 0 IN ! B/SCR BLK @ OVER MOD - BLK +!
  1565. ;*
  1566.  
  1567. : '
  1568.   -FIND 0= 0 ?ERROR DROP LITERAL
  1569. ;*
  1570.  
  1571. : FORGET
  1572.   CURRENT @ CONTEXT @ - LIT 24 ?ERROR
  1573.   ' DUP FENCE @ < LIT 21 ?ERROR
  1574.   DUP NFA DP ! LFA @ CONTEXT @ !
  1575. ;
  1576.  
  1577. ( COMPILING WORDS )
  1578.  
  1579. : BACK
  1580.   HERE - ,
  1581. ;
  1582.  
  1583. : BEGIN
  1584.   ?COMP HERE 1
  1585. ;*
  1586.  
  1587. : ENDIF
  1588.   ?COMP 2 ?PAIRS HERE OVER - SWAP !
  1589. ;*
  1590.  
  1591. : THEN
  1592.   ENDIF
  1593. ;*
  1594.  
  1595. : DO
  1596.   COMPILE (DO) HERE LIT 3
  1597. ;*
  1598.  
  1599. : LOOP
  1600.   LIT 3 ?PAIRS COMPILE (LOOP) BACK
  1601. ;*
  1602.  
  1603. : +LOOP
  1604.   LIT 3 ?PAIRS ?COMP COMPILE (+LOOP) BACK
  1605. ;*
  1606.  
  1607. : UNTIL
  1608.   1 ?PAIRS COMPILE 0BRANCH BACK
  1609. ;*
  1610.  
  1611. : END
  1612.   UNTIL
  1613. ;*
  1614.  
  1615. : AGAIN
  1616.   ?COMP
  1617.   1 ?PAIRS COMPILE BRANCH BACK
  1618. ;*
  1619.  
  1620. : REPEAT
  1621.   ?COMP
  1622.   >R >R AGAIN R> R> 2 -
  1623.   ENDIF
  1624. ;*
  1625.  
  1626. : IF
  1627.   COMPILE 0BRANCH HERE 0 , 2
  1628. ;*
  1629.  
  1630. : ELSE
  1631.   2 ?PAIRS COMPILE BRANCH HERE 0 , SWAP 2 ENDIF 2
  1632. ;*
  1633.  
  1634. : WHILE
  1635.   IF 2+
  1636. ;*
  1637.  
  1638. : SPACES
  1639.   0 MAX -DUP 0BRANCH SPACES1
  1640.   0 (DO) 
  1641. LABEL SPACES2
  1642.       SPACE 
  1643.   (LOOP) SPACES2
  1644. LABEL SPACES1
  1645. ;
  1646.  
  1647. : <#
  1648.   PAD HLD !
  1649. ;
  1650.  
  1651. : #>
  1652.   DROP DROP HLD @ PAD OVER -
  1653. ;
  1654.  
  1655. : SIGN
  1656.   ROT 0< 0BRANCH SIGN1
  1657.   LIT '-'  HOLD
  1658. LABEL SIGN1
  1659. ;
  1660.  
  1661. : #
  1662.   BASE @ M/MOD ROT LIT 9 OVER < 0BRANCH #1
  1663.   LIT 7 +        ( 7 is offset to make 'A' come after '9')
  1664. LABEL #1
  1665.   LIT '0' + HOLD
  1666. ;
  1667.  
  1668. : #S
  1669. LABEL #S1
  1670.   # 2DUP OR 0= 0BRANCH #S1
  1671. ;
  1672.  
  1673. : D.R
  1674.   >R SWAP OVER DABS <# #S SIGN #> R> OVER - SPACES TYPE
  1675. ;
  1676.  
  1677. : .R
  1678.   >R S->D R> D.R
  1679. ;
  1680.  
  1681. : D.
  1682.   0 D.R SPACE
  1683. ;
  1684.  
  1685. : .
  1686.   S->D D.
  1687. ;
  1688.  
  1689. : ?
  1690.   @ .
  1691. ;
  1692.  
  1693. : U.
  1694.   0 D.
  1695. ;
  1696.  
  1697. : VLIST
  1698.   C/L 1+ OUT !  CONTEXT @ @
  1699. LABEL VLIST1            ( BEGIN )
  1700.   OUT @ C/L > 0BRANCH VLIST2    ( IF )
  1701.   CR
  1702. LABEL VLIST2            ( THEN )
  1703.   DUP ID. SPACE PFA LFA @
  1704.   DUP 0= ?TERMINAL OR 0BRANCH VLIST1    ( UNTIL )
  1705.   DROP
  1706. ;
  1707.  
  1708. : .CPU
  1709.   (.") "C-CODED FORTH INTERPRETER"    ( special string handling )
  1710. ;
  1711.  
  1712. : BYE
  1713.   CR (.") "EXIT FORTH" CR
  1714.   0 (BYE)
  1715. ;
  1716.  
  1717. : LIST
  1718.   DECIMAL CR
  1719.   DUP SCR ! (.") "SCR # " .
  1720.   LIT 16 0 (DO)
  1721. LABEL LIST1
  1722.     CR I 3 .R SPACE
  1723.     I SCR @ .LINE
  1724.     ?TERMINAL 0BRANCH LIST2
  1725.       LEAVE
  1726. LABEL LIST2
  1727.   (LOOP) LIST1
  1728.   CR
  1729. ;
  1730.  
  1731. : CASE
  1732.   ?COMP CSP @ !CSP LIT 4
  1733. ;*
  1734.  
  1735. : OF
  1736.   ?COMP LIT 4 ?PAIRS
  1737.   COMPILE OVER COMPILE = COMPILE 0BRANCH 
  1738.   HERE 0 ,
  1739.   COMPILE DROP
  1740.   LIT 5
  1741. ;*
  1742.  
  1743. : ENDOF
  1744.   ?COMP
  1745.   LIT 5 ?PAIRS
  1746.   COMPILE BRANCH
  1747.   HERE 0 ,
  1748.   SWAP 2 ENDIF LIT 4
  1749. ;*
  1750.  
  1751. : ENDCASE
  1752.   ?COMP
  1753.   LIT 4 ?PAIRS
  1754.   COMPILE DROP
  1755. LABEL ENDC1            ( BEGIN )
  1756.   SP@ CSP @ != 0BRANCH ENDC2    ( WHILE )
  1757.   2 ENDIF
  1758.   BRANCH ENDC1            ( REPEAT )
  1759. LABEL ENDC2
  1760.   CSP !
  1761. ;*
  1762.  
  1763. : \            ( REMAINER OF THE LINE IS A COMMENT )
  1764.   ?LOADING
  1765.   IN @ C/L / 1+ C/L * IN !
  1766. ;*
  1767.  
  1768. : ALIAS        ( usage: ALIAS NEW OLD; makes already-compiled references )
  1769.         ( to OLD refer to NEW. Restrictions: OLD must have been a )
  1770.         ( colon-definition, and it must not have been of the form )
  1771.         ( { : OLD ; } where the first word of the PFA is ;S .     )
  1772.   ' CFA
  1773.   ' DUP
  1774.   2 - @ LIT DOCOL != LIT 27 ?ERROR    ( ERROR IF NOT A COLON DEFINITION )
  1775.   DUP @    LIT ;S = LIT 28 ?ERROR        ( MAKE SURE ;S IS NOT THE FIRST WORD )
  1776.   DUP >R ! LIT ;S R> 2+ !
  1777. ;
  1778.  
  1779. : REFORTH        ( GET & EXECUTE ONE FORTH LINE <PERHAPS A NUMBER> )
  1780.   IN @ >R BLK @ >R
  1781.   0 IN ! 0 BLK !
  1782.   QUERY INTERPRET
  1783.   R> BLK ! R> IN !
  1784. ;
  1785.  
  1786.  
  1787. ( The vocabulary word FORTH will be compiled after the dictionary is read,
  1788.   with a pointer to the last word in the dictionary, which will be itself. )
  1789. //go.sysin dd *
  1790. echo 'x - forth.h'
  1791. sed 's/^X//' <<'//go.sysin dd *' >forth.h
  1792. X/*
  1793.  * forth.h -- define function numbers for primitives, and other constants,
  1794.  * externals, and globals used in forth.c and prims.c
  1795.  */
  1796.  
  1797. #define EXECUTE        0
  1798. #define LIT        1
  1799. #define BRANCH        2
  1800. #define ZBRANCH        3
  1801. #define PLOOP        4
  1802. #define PPLOOP        5
  1803. #define PDO        6
  1804. #define I        7
  1805. #define R        58
  1806. #define DIGIT        8
  1807. #define PFIND        9
  1808. #define ENCLOSE        10
  1809. #define KEY        11
  1810. #define PEMIT        12
  1811. #define QTERMINAL    13
  1812. #define CMOVE        14
  1813. #define USTAR        15
  1814. #define USLASH        16
  1815. #define AND        17
  1816. #define OR        18
  1817. #define XOR        19
  1818. #define SPFETCH        20
  1819. #define SPSTORE        21
  1820. #define RPFETCH        22
  1821. #define RPSTORE        23
  1822. #define SEMIS        24
  1823. #define LEAVE        25
  1824. #define TOR        26
  1825. #define FROMR        27
  1826. #define ZEQ        28
  1827. #define ZLESS        29
  1828. #define PLUS        30
  1829. #define DPLUS        31
  1830. #define MINUS        32
  1831. #define DMINUS        33
  1832. #define OVER        34
  1833. #define DROP        35
  1834. #define SWAP        36
  1835. #define DUP        37
  1836. #define TDUP        38
  1837. #define PSTORE        39
  1838. #define TOGGLE        40
  1839. #define FETCH        41
  1840. #define CFETCH        42
  1841. #define TFETCH        43
  1842. #define STORE        44
  1843. #define CSTORE        45
  1844. #define TSTORE        46
  1845. #define DOCOL        47
  1846. #define DOCON        48
  1847. #define DOVAR        49
  1848. #define DOUSE        50
  1849. #define SUBTRACT    51
  1850. #define EQUAL        52
  1851. #define NOTEQ        53
  1852. #define LESS        54
  1853. #define ROT        55
  1854. #define DODOES        56
  1855. #define DOVOC        57
  1856. X/* 58 is above */
  1857. #define ALLOT        59
  1858. #define PBYE        60
  1859. #define TRON        61
  1860. #define TROFF        62
  1861. #define DOTRACE        63
  1862. #define PRSLW        64
  1863. #define PSAVE        65
  1864. #define PCOLD        66
  1865.  
  1866. X/* memory */
  1867. #define GULPFRQ        256    /* if mem[LIMIT] - dp < GULPFRQ, then get */
  1868. #define GULPSIZE    1024    /* a block of GULPSIZE words          */
  1869.  
  1870. X/*
  1871.  * User variables and other locations
  1872.  */
  1873.  
  1874. #define S0    UP+0        /* csp when stack is empty */
  1875. #define R0    UP+1        /* rsp when r stack is empty */
  1876. #define TIB    UP+2        /* Terminal Input Buffer location */
  1877. #define WIDTH    UP+3        /* screen width */
  1878. #define WARNING    UP+4        /* print messages? */
  1879. #define FENCE    UP+5        /* can not forget below this mark */
  1880. #define DP    UP+6        /* points to first unallocated word */
  1881. #define VOCLINK UP+7        /* vocabulary link */
  1882.  
  1883. char *calloc(), *realloc(), *gets();
  1884. long lseek();
  1885.  
  1886. X/* GLOBALS */
  1887.  
  1888. X/* STACK POINTERS are registers of our FORTH machine. They, like everything
  1889.    else, point into memory (mem[]). They are read by sp@ and rp@, set by sp!
  1890.    and rp!. They are initialized by COLD. */
  1891.  
  1892. extern unsigned short csp;
  1893. extern unsigned short rsp;
  1894.  
  1895. X/* This variable is all-important. It will be set to the top of the 
  1896.    data area by sbrk, and more memory will be allocated. All memory is
  1897.    addressed as a subscript to this address -- mem[0] is the first memory 
  1898.    element, mem[1] is second, and so on. 
  1899. */
  1900.  
  1901. extern short *mem;    /* points to the number of bytes in mem[0], as read
  1902.                from COREFILE at startup */
  1903.  
  1904. X/* two more machine registers: the interpretive pointer */
  1905. extern unsigned short ip;    /* for an explanation of these, look in */
  1906. extern unsigned short w;    /* interp.doc */
  1907.  
  1908. extern int trace, debug;    /* global for tracing in next() */
  1909. extern int tracedepth, breakenable, breakpoint, qtermflag, forceip, nobuf;
  1910. extern FILE *blockfile;
  1911. extern long bfilesize;
  1912. extern char *bfilename;
  1913. extern char *cfilename;
  1914. extern char *sfilename;
  1915. //go.sysin dd *
  1916. echo 'x - forth.lex'
  1917. sed 's/^X//' <<'//go.sysin dd *' >forth.lex
  1918. %{
  1919. X/* LEX input for FORTH input file scanner */
  1920. X/* 
  1921.     Specifications are as follows:
  1922.     This file must be run through "sed" to change 
  1923.         yylex () {
  1924.     to
  1925.         TOKEN *yylex () {
  1926.     where the sed script is
  1927.         sed "s/yylex () {/TOKEN *yylex () {/" lex.yy.c
  1928.  
  1929.     Note that spaces have been included above so these lines won't be
  1930.     mangled by sed; in actuality, the two blanks surrounding () are
  1931.     removed.
  1932.  
  1933.     The function "yylex()" always returns a pointer to a structure:
  1934.  
  1935.         struct tokenrec {
  1936.         int type;
  1937.         char *text;
  1938.         }
  1939.         #define TOKEN struct tokenrec
  1940.  
  1941.     where the type is a hint as to the word's type:
  1942.         DECIMAL for decimal literal        d+
  1943.         OCTAL for octal literal        0d*
  1944.         HEX for hex literal        0xd+ or 0Xd+
  1945.         C_BS for a literal Backspace    '\b'
  1946.         C_FF for a literal Form Feed    '\f'
  1947.         C_NL for a literal Newline    '\n'
  1948.         C_CR for a literal Carriage Return '\r'
  1949.         C_TAB for a literal Tab '\t'
  1950.         C_BSLASH for a literal backslash '\\'
  1951.         C_IT for an other character literal 'x' where x is possibly '
  1952.         STRING_LIT for a string literal (possibly containing \")
  1953.         COMMENT for a left-parenthesis (possibly beginning a comment)
  1954.         PRIM for "PRIM"
  1955.         CONST for "CONST"
  1956.         VAR for "VAR"
  1957.         USER for "USER"
  1958.         LABEL for "LABEL"
  1959.         COLON for ":"
  1960.         SEMICOLON for ";"
  1961.         SEMISTAR for ";*" (used to make words IMMEDIATE)
  1962.         NUL for the token {NUL}, which gets compiled as a null byte;
  1963.             this special interpretation takes place in the COLON
  1964.             code.
  1965.         LIT for the word "LIT" (treated like OTHER, except that
  1966.             no warning is generated when a literal follows this)
  1967.         OTHER for an other word not recognized above
  1968.  
  1969.     Note that this is just a hint: the meaning of any string of characters
  1970.     depends on the context.
  1971.  
  1972. */
  1973. %}
  1974.  
  1975. decimal    [0-9]
  1976. hex    [0-9A-Fa-f]
  1977. octal    [0-7]
  1978. white    [ \t\n\r\f]
  1979. tail    /{white}
  1980.  
  1981. %{
  1982. #include "forth.lex.h"
  1983. TOKEN token;
  1984. %}
  1985.  
  1986. %%
  1987. {white}*    /* whitespace -- keep looping */ ;
  1988.  
  1989. -?[1-9]{decimal}*{tail}        { token.type = DECIMAL; token.text = yytext;
  1990.                     return &token; }
  1991. -?0{octal}*{tail}        { token.type = OCTAL; token.text = yytext;
  1992.                     return &token; }
  1993. -?0[xX]{hex}+{tail}        { token.type = HEX; token.text = yytext;
  1994.                     return &token; }
  1995.  
  1996. \'\\b\'{tail}    { token.type = C_BS; token.text = yytext; return &token; }
  1997. \'\\f\'{tail}    { token.type = C_FF; token.text = yytext; return &token; }
  1998. \'\\n\'{tail}    { token.type = C_NL; token.text = yytext; return &token; }
  1999. \'\\r\'{tail}    { token.type = C_CR; token.text = yytext; return &token; }
  2000. \'\\t\'{tail}    { token.type = C_TAB; token.text = yytext; return &token; }
  2001. \'\\\\\'{tail}    { token.type = C_BSLASH; token.text = yytext; return &token; }
  2002. \'.\'{tail}    { token.type = C_LIT; token.text = yytext; return &token; }
  2003.  
  2004. \"(\\\"|[^"])*\"{tail}    { token.type = STRING_LIT; token.text = yytext; 
  2005.                 return &token; }
  2006.  
  2007. "("{tail}        { token.type = COMMENT; token.text = yytext;
  2008.                 return &token; }
  2009.  
  2010. "PRIM"{tail}        { token.type = PRIM; token.text = yytext;
  2011.                 return &token; }
  2012.  
  2013. "CONST"{tail}        { token.type = CONST; token.text = yytext;
  2014.                 return &token; }
  2015.  
  2016. "VAR"{tail}        { token.type = VAR; token.text = yytext;
  2017.                 return &token; }
  2018.  
  2019. "USER"{tail}        { token.type = USER; token.text = yytext;
  2020.                 return &token; }
  2021.  
  2022. "LABEL"{tail}        { token.type = LABEL; token.text = yytext;
  2023.                 return &token; }
  2024.  
  2025. ":"{tail}        { token.type = COLON; token.text = yytext;
  2026.                 return &token; }
  2027.  
  2028. ";"{tail}        { token.type = SEMICOLON; token.text = yytext;
  2029.                 return &token; }
  2030.  
  2031. ";*"{tail}        { token.type = SEMISTAR; token.text = yytext;
  2032.                 return &token; }
  2033.  
  2034. "{NUL}"{tail}        { token.type = NUL; token.text = yytext;
  2035.                 return &token; }
  2036.  
  2037. "LIT"{tail}        { token.type = LIT; token.text = yytext;
  2038.                 return &token; }
  2039.  
  2040. [^ \n\t\r\f]+{tail}    { token.type = OTHER; token.text = yytext;
  2041.                 return &token; }
  2042. %%
  2043. //go.sysin dd *
  2044. echo 'x - forth.lex.h'
  2045. sed 's/^X//' <<'//go.sysin dd *' >forth.lex.h
  2046. X/* this is my best effort at a reconstruction of this file - it was not
  2047. **  included with the distribution, and I cannot reach the author via
  2048. **   electronic mail!
  2049. ** John Nelson  (decvax!genrad!john)  [moderator, mod.sources]
  2050. */
  2051.  
  2052. struct tokenrec {
  2053.     int type;
  2054.     char *text;
  2055. };
  2056.  
  2057. #define TOKEN struct tokenrec
  2058.  
  2059. TOKEN *yylex();
  2060.  
  2061. #define DECIMAL        1
  2062. #define OCTAL        2
  2063. #define HEX        3
  2064. #define C_BS        4
  2065. #define C_FF        5
  2066. #define C_NL        6
  2067. #define C_CR        7
  2068. #define C_TAB        8
  2069. #define C_BSLASH    9
  2070. #define C_LIT        10
  2071. #define STRING_LIT    11
  2072. #define COMMENT        12
  2073. #define PRIM        13
  2074. #define CONST        14
  2075. #define VAR        15
  2076. #define USER        16
  2077. #define LABEL        17
  2078. #define COLON        18
  2079. #define SEMICOLON    19
  2080. #define SEMISTAR    20
  2081. #define NUL        21
  2082. #define LIT        22
  2083. #define OTHER        23
  2084. //go.sysin dd *
  2085. echo 'x - forth.line'
  2086. sed 's/^X//' <<'//go.sysin dd *' >forth.line
  2087. ------------------ SCREEN 0 ------------------
  2088.  
  2089.  
  2090. ================================================================
  2091. ||      C-CODED FIG-FORTH for UNIX* systems by ALLAN PRATT    ||
  2092. ||                                                            ||
  2093. ||      INCLUDES \ COMMENTS,                                  ||
  2094. ||               CASE..OF..ENDOF..ENDCASE                     ||
  2095. ||               UNTHREAD, EDITOR                             ||
  2096. ||               REFORTH,                                     ||
  2097. ||               "ALIAS NEW OLD"                              ||
  2098. ||      AND OTHER NICE THINGS.                                ||
  2099. || ( * UNIX is a trademark of Bell Labs )                     ||
  2100. ================================================================
  2101.  
  2102.  
  2103.  
  2104. ------------------ SCREEN 1 ------------------
  2105. ( UNTHREAD VERSION 2 / SCREEN 1 OF 3 )
  2106. : DOQUOTE                       \ AFTER (.")
  2107.   34 EMIT WORDSIZE + DUP C@ OVER 1+ SWAP TYPE
  2108.   34 EMIT SPACE DUP C@ + 1+ ;
  2109.  
  2110. : DOLIT         \ AFTER LIT, BRANCHES, AND (LOOP)S
  2111.   WORDSIZE + DUP @ . WORDSIZE + ;
  2112.  
  2113.  
  2114.  
  2115.  
  2116. -->
  2117.  
  2118.  
  2119.  
  2120.  
  2121. ------------------ SCREEN 2 ------------------
  2122. ( UNTHREAD VERSION 2 / SCREEN 2 OF 3 )
  2123. : DOWORD        \ MAIN UNTHREADER
  2124.   DUP @ WORDSIZE + DUP NFA ID.  CASE
  2125.     ' LIT       OF DOLIT        ENDOF
  2126.     ' 0BRANCH   OF DOLIT        ENDOF
  2127.     ' BRANCH    OF DOLIT        ENDOF
  2128.     ' (LOOP)    OF DOLIT        ENDOF
  2129.     ' (+LOOP)   OF DOLIT        ENDOF
  2130.     ' (.")      OF DOQUOTE      ENDOF
  2131.     ' ;S        OF DROP 0       ENDOF \ LEAVE 0
  2132.     DUP         OF WORDSIZE +   ENDOF \ DEFAULT
  2133.   ENDCASE ;
  2134.  
  2135. -->
  2136.  
  2137.  
  2138. ------------------ SCREEN 3 ------------------
  2139. ( UNTHREAD VERSION 2 / SCREEN 3 OF 3 )
  2140. : UNTHREAD      \ USAGE: UNTHREAD WORD
  2141.   [COMPILE] ' DUP CFA @
  2142.   ' DOWORD CFA @ <> 27 ?ERROR   \ NOT THREADED
  2143.   CR ." : " DUP NFA ID. SPACE
  2144.   BEGIN
  2145.     DOWORD
  2146.     OUT @ C/L > IF CR THEN
  2147.     -DUP WHILE
  2148.   REPEAT ;
  2149.  
  2150. CR ." UNTHREAD READY"
  2151.  
  2152. ;S
  2153.  
  2154.  
  2155. ------------------ SCREEN 4 ------------------
  2156. ( ERROR MESSAGES )
  2157. EMPTY STACK
  2158.  
  2159.  
  2160. ISN'T UNIQUE
  2161.  
  2162.  
  2163. XFULL STACK
  2164.  
  2165.  
  2166.  
  2167.  
  2168.  
  2169.  
  2170.  
  2171. C-CODED figFORTH by ALLAN PRATT / APRIL 1985
  2172. ------------------ SCREEN 5 ------------------
  2173. MSG # 16
  2174. MUST BE COMPILING
  2175. MUST BE EXECUTING
  2176. UNMATCHED STRUCTURES
  2177. DEFINITION NOT FINISHED
  2178. WORD IS PROTECTED BY FENCE
  2179. MUST BE LOADING
  2180.  
  2181. CONTEXT ISN'T CURRENT
  2182.  
  2183.  
  2184. ALIAS: NOT A COLON DEFINITION
  2185. ALIAS: CAN'T ALIAS A NULL WORD
  2186.  
  2187.  
  2188.  
  2189. ------------------ SCREEN 6 ------------------
  2190. X." LOADING EDITOR FOR VT100" CR
  2191.  
  2192. : CLS                        \ clear screen and home cursor
  2193.   27 EMIT ." [2J" 27 EMIT ." [H"
  2194. ;
  2195.  
  2196. : LOCATE   \ 0 16 LOCATE positions cursor at line 16, column 0
  2197.   27 EMIT 91 EMIT 1+ 1 .R 59 EMIT 1+ 1 .R 72 EMIT ;
  2198.  
  2199. : STANDOUT                   \ This can be a null word
  2200.   27 EMIT ." [7m" ;
  2201.  
  2202. : STANDEND                   \ This can be a null word, too.
  2203.   27 EMIT ." [m" ;
  2204.  
  2205. ;S   \ CONTINUE LOADING EDITOR
  2206. ------------------ SCREEN 7 ------------------
  2207. X." LOADING EDITOR FOR ADM5" CR
  2208.  
  2209. : CLS 26 EMIT ;
  2210.  
  2211. : LOCATE
  2212.   27 EMIT 61 EMIT
  2213.   32 + EMIT 32 + EMIT ;
  2214.  
  2215.  
  2216. : STANDOUT
  2217.   27 EMIT 71 EMIT ;
  2218.  
  2219. : STANDEND
  2220.   27 EMIT 71 EMIT ;
  2221.  
  2222. ;S   \ continue loading editor
  2223. ------------------ SCREEN 8 ------------------
  2224. ( Reserved for more terminals; set the name of the terminal
  2225.   as a constant in screen 10 )
  2226. ;S
  2227.  
  2228.  
  2229.  
  2230.  
  2231.  
  2232.  
  2233.  
  2234.  
  2235.  
  2236.  
  2237.  
  2238.  
  2239.  
  2240. ------------------ SCREEN 9 ------------------
  2241. ( Reserved for more terminals. Set the name of the terminal
  2242.   as a constant in screen 10 )
  2243. ;S
  2244.  
  2245.  
  2246.  
  2247.  
  2248.  
  2249.  
  2250.  
  2251.  
  2252.  
  2253.  
  2254.  
  2255.  
  2256.  
  2257. ------------------ SCREEN 10 ------------------
  2258. ( EDITOR -- SCREEN 1 OF 19 -- VARIABLES )
  2259. DECIMAL
  2260. 0 VARIABLE ROW          0 VARIABLE COL
  2261. 0 VARIABLE EDIT-SCR     0 VARIABLE SCREEN-IS-MODIFIED
  2262. 0 VARIABLE MUST-UPDATE  0 VARIABLE LAST-KEY-STRUCK
  2263. 0 VARIABLE CURSOR-IS-DIRTY
  2264.  
  2265. 0 VARIABLE KEYMAP  WORDSIZE 255 *  ALLOT
  2266.            KEYMAP  WORDSIZE 256 *  ERASE
  2267.  
  2268. 0 VARIABLE SCR-BUFFER B/BUF B/SCR * WORDSIZE - ALLOT
  2269.  
  2270. ( TERMINAL CONSTANTS -- VALUE IS SCREEN NUMBER TO LOAD )
  2271. 6 CONSTANT VT100   7 CONSTANT ADM5
  2272.  
  2273. -->
  2274. ------------------ SCREEN 11 ------------------
  2275. ( EDITOR -- SCREEN 2 OF 19 -- SCREEN STUFF )
  2276.  
  2277. CR ." ENTER THE TYPE OF TERMINAL YOU ARE USING. TYPE ONE OF:"
  2278. CR ."      VT100   ADM5" CR   \ list the constants from scr 10
  2279.  
  2280. REFORTH          \ this word gets & interprets one line.
  2281. LOAD             \ load the right screen; VT100 = 6, ADM5 = 7
  2282.  
  2283. : EXIT-EDIT
  2284.   0 16 LOCATE QUIT ;
  2285. : ABORT-EDIT
  2286.   0 15 LOCATE MESSAGE ;
  2287.  
  2288. : BIND-ADDR          ( C -- ADDR where binding is stored )
  2289.   WORDSIZE * KEYMAP + ;
  2290. -->
  2291. ------------------ SCREEN 12 ------------------
  2292. ( EDITOR -- SCREEN 3 OF 19 -- I/O )
  2293.  
  2294. : ^EMIT        ( OUTPUT W/ESC AND ^ )
  2295.   DUP 127 > IF ." ESC-" 128 - THEN
  2296.   DUP 32  < IF ." ^" 64 + THEN
  2297.   EMIT ;
  2298.  
  2299. : BACK-WRAP     ( DECR EDIT SCR. AND PUT CURSOR AT BOTTOM )
  2300.   EDIT-SCR -- C/L 1- COL ! 15     ROW ! 1 MUST-UPDATE ! ;
  2301. : FORWARD-WRAP  ( INCR EDIT SCR. AND PUT CURSOR AT TOP )
  2302.   EDIT-SCR ++ 0 COL ! 0 ROW ! 1 MUST-UPDATE ! ;
  2303. : ED-KEY       ( INPUT W/ESC FOR HI BIT )
  2304.   KEY DUP 27 = IF DROP KEY 128 + THEN
  2305.   DUP LAST-KEY-STRUCK ! ;
  2306.  
  2307. -->
  2308. ------------------ SCREEN 13 ------------------
  2309. ( EDITOR -- SCREEN 4 OF 19 -- BINDING WORDS )
  2310. : (BIND)         ( CFA K -- STORES INTO KEYMAP )
  2311.   BIND-ADDR !
  2312. ;
  2313.  
  2314. : BIND-TO-KEY    ( "BIND-TO-KEY NAME" ASKS FOR KEY )
  2315.   [COMPILE] ' CFA
  2316.   ." KEY: " ED-KEY DUP ^EMIT SPACE
  2317.   (BIND) ;
  2318.  
  2319. : DESCRIBE-KEY
  2320.   ." KEY: " ED-KEY DUP ^EMIT SPACE
  2321.   BIND-ADDR @ -DUP IF NFA ID.
  2322.                         ELSE ." SELF-INSERT"
  2323.                         THEN SPACE ;
  2324. -->
  2325. ------------------ SCREEN 14 ------------------
  2326. ( EDITOR -- SCREEN 5 OF 19 -- PRIMITIVE OPS )
  2327.  
  2328. : PREV-LINE ROW @      IF ROW -- 1 CURSOR-IS-DIRTY !
  2329.                        ELSE BACK-WRAP THEN ;
  2330. : NEXT-LINE ROW @ 15 < IF ROW ++ 1 CURSOR-IS-DIRTY !
  2331.                        ELSE FORWARD-WRAP THEN ;
  2332. : BEGINNING-OF-LINE 0 COL ! 1 CURSOR-IS-DIRTY ! ;
  2333. : END-OF-LINE      C/L 1- COL ! 1 CURSOR-IS-DIRTY ! ;
  2334. : EDIT-CR NEXT-LINE BEGINNING-OF-LINE ;
  2335. : PREV-CHAR COL @ IF COL -- 1 CURSOR-IS-DIRTY !
  2336.                   ELSE END-OF-LINE PREV-LINE
  2337.                   THEN ;
  2338. : NEXT-CHAR COL @ C/L 1- < IF COL ++ 1 CURSOR-IS-DIRTY !
  2339.                            ELSE EDIT-CR
  2340.                            THEN ;
  2341. -->
  2342. ------------------ SCREEN 15 ------------------
  2343. ( EDITOR -- SCREEN 6 OF 19 -- MORE LOW-LEVEL )
  2344. : THIS-CHAR
  2345.   ROW @ EDIT-SCR @ (LINE) DROP COL @ + ;
  2346.  
  2347. : PUT-CHAR THIS-CHAR C! 1 MUST-UPDATE ! ;
  2348.  
  2349. : INSERT-CHAR PUT-CHAR NEXT-CHAR ;
  2350.  
  2351. : SELF-INSERT
  2352.   LAST-KEY-STRUCK @ DUP THIS-CHAR C! EMIT
  2353.   NEXT-CHAR
  2354. ;
  2355.  
  2356. DECIMAL -->
  2357.  
  2358.  
  2359. ------------------ SCREEN 16 ------------------
  2360. ( EDITOR -- SCREEN  7 OF 19 -- DISPLAY STUFF )
  2361. HEX
  2362. : SHOWSCR         ( N -- SHOWS SCREEN N )
  2363.    CLS
  2364.    0 10 LOCATE STANDOUT ." SCREEN " DUP . STANDEND
  2365.    10 0 DO
  2366.         0 I LOCATE
  2367.            I OVER .LINE
  2368.         LOOP DROP ;
  2369.  
  2370. : REDRAW EDIT-SCR @ SHOWSCR ;
  2371.  
  2372. : ?REDRAW
  2373.   MUST-UPDATE @ IF REDRAW 0 MUST-UPDATE !
  2374.                           1 CURSOR-IS-DIRTY ! THEN ;
  2375. DECIMAL -->
  2376. ------------------ SCREEN 17 ------------------
  2377. ( EDITOR -- SCREEN  8 OF 19 -- EXECUTE-KEY )
  2378.  
  2379. : EXECUTE-KEY        ( K -- EXECUTE THE KEY )
  2380.   WORDSIZE * KEYMAP + @ -DUP IF
  2381.                            EXECUTE
  2382.                         ELSE
  2383.                            SELF-INSERT
  2384.                         THEN
  2385. ;
  2386. : ?PLACE-CURSOR
  2387.   CURSOR-IS-DIRTY @ IF
  2388.     COL @ ROW @ LOCATE
  2389.     0 CURSOR-IS-DIRTY !
  2390.   THEN
  2391. ;
  2392. -->
  2393. ------------------ SCREEN 18 ------------------
  2394. ( EDITOR -- SCREEN  9 OF 19 -- TOP-LEVEL )
  2395. : TOP-LEVEL
  2396.   BEGIN
  2397.     ?REDRAW ?PLACE-CURSOR ED-KEY EXECUTE-KEY
  2398.   AGAIN
  2399. ;
  2400.  
  2401.  
  2402. : EDIT
  2403.   EDIT-SCR ! CLS
  2404.   0 ROW ! 0 COL ! 1 MUST-UPDATE !
  2405.   TOP-LEVEL
  2406. ;
  2407.  
  2408.  
  2409. -->
  2410. ------------------ SCREEN 19 ------------------
  2411. ( EDITOR -- SCREEN 10 OF 19 -- HIGH-LEVEL KEY WORDS )
  2412.  
  2413. : UPDATE-SCR                 ( BOUND TO ^U )
  2414.   EDIT-SCR @ B/SCR * DUP B/SCR + SWAP DO
  2415.     I BLOCK DROP UPDATE
  2416.   LOOP ;
  2417.  
  2418.  
  2419. : NEXT-SCR                   ( ^C and ESC-C )
  2420.   EDIT-SCR ++   1 MUST-UPDATE !
  2421. ;
  2422.  
  2423. : PREV-SCR                   ( ^R and ESC-R )
  2424.   EDIT-SCR @ 0= IF EDIT-SCR ++ THEN
  2425.   EDIT-SCR --   1 MUST-UPDATE ! ;
  2426. -->
  2427. ------------------ SCREEN 20 ------------------
  2428. ( EDITOR -- SCREEN 11 OF 19 -- HIGH-LEVEL )
  2429. HEX
  2430. : TAB-KEY        ( INCREMENT TO NEXT TAB STOP )
  2431.   COL @ 8 + F8 AND DUP C/L < IF COL ! THEN ;
  2432.  
  2433. DECIMAL
  2434.  
  2435. : REEDIT         ( RESTART EDITING )
  2436.   EDIT-SCR @ EDIT ;
  2437.  
  2438. : ERRCONV
  2439.   ERRBLK @ DUP B/SCR / SWAP B/SCR MOD DUP +
  2440.   ERRIN @ C/L @ / + ;
  2441. : ERREDIT ERRCONV ROW ! EDIT-SCR ! BEGINNING-OF-LINE
  2442.   1 MUST-UPDATE ! CLS TOP-LEVEL ;
  2443. -->
  2444. ------------------ SCREEN 21 ------------------
  2445. ( EDITOR -- SCREEN 12 OF 19 -- )
  2446.  
  2447. : UPDATE-AND-FLUSH
  2448.   UPDATE-SCR FLUSH ;
  2449.  
  2450. : DEL-TO-END-OF-LINE
  2451.   COL @ ROW @ EDIT-SCR @  ( SAVE THESE )
  2452.   C/L COL @ DO BL INSERT-CHAR LOOP
  2453.   EDIT-SCR ! ROW ! COL !  ( RESTORE SAVED VALUES )
  2454. ;
  2455.  
  2456.  
  2457.  
  2458.  
  2459.  
  2460. -->
  2461. ------------------ SCREEN 22 ------------------
  2462. ( EDITOR -- SCREEN 13 OF 19 -- MORE HIGH-LEVEL )
  2463.  
  2464. : CLEAR-SCREEN
  2465.   EDIT-SCR @ B/SCR * DUP B/SCR + SWAP DO
  2466.      I BLOCK B/BUF BLANKS
  2467.   LOOP
  2468.   1 MUST-UPDATE !
  2469. ;
  2470.  
  2471. : DESCRIBE-BINDINGS     ( SHOWS ALL BINDINGS )
  2472.   256 0 DO              ( INTERESTING ONES, ANYWAY )
  2473.     I BIND-ADDR @
  2474.     -DUP IF CR I ^EMIT SPACE NFA ID. THEN
  2475.     ?TERMINAL IF LEAVE THEN
  2476.   LOOP CR ;
  2477. -->
  2478. ------------------ SCREEN 23 ------------------
  2479. ( EDITOR -- SCREEN 14 OF 19 -- WORD MOVEMENT )
  2480. : NEXT-WORD
  2481.   THIS-CHAR C@ BL = IF PREV-CHAR THEN   ( BUG FIX )
  2482.   BEGIN NEXT-CHAR THIS-CHAR C@ BL = UNTIL
  2483.   BEGIN NEXT-CHAR THIS-CHAR C@ BL <> UNTIL ;
  2484.  
  2485. : PREV-WORD
  2486.   BEGIN PREV-CHAR THIS-CHAR C@ BL <> UNTIL
  2487.   BEGIN PREV-CHAR THIS-CHAR C@ BL = UNTIL
  2488.   NEXT-CHAR ;
  2489.  
  2490.  
  2491.  
  2492.  
  2493.  
  2494. -->
  2495. ------------------ SCREEN 24 ------------------
  2496. ( EDITOR -- SCREEN 15 OF 19 -- BUFFER CONTROL )
  2497. : TO-BUFFER             ( COPY FROM HERE TO BUFFER )
  2498.   EDIT-SCR @ 16 0 DO
  2499.     I OVER (LINE) I C/L * SCR-BUFFER + SWAP CMOVE
  2500.   LOOP DROP
  2501. ;
  2502.  
  2503. : FROM-BUFFER           ( COPY FROM BUFFER TO HERE )
  2504.   EDIT-SCR @ 16 0 DO
  2505.     I OVER (LINE) DROP I C/L * SCR-BUFFER + SWAP C/L CMOVE
  2506.   LOOP DROP 1 MUST-UPDATE !
  2507. ;
  2508.  
  2509.  
  2510.  
  2511. -->
  2512. ------------------ SCREEN 25 ------------------
  2513. ( EDITOR -- SCREEN 16 OF 19 -- MORE BUFFERS )
  2514. : SCR-COPY      ( SRC DEST -- COPIES A SCREEN )
  2515.   EDIT-SCR @ ROT ROT    ( OLD IS THIRD )
  2516.   SWAP EDIT-SCR ! TO-BUFFER     ( OLD IS SECOND/DEST IS FIRST )
  2517.   EDIT-SCR ! FROM-BUFFER UPDATE-SCR
  2518.   EDIT-SCR !
  2519. ;
  2520.  
  2521. : QUOTE-NEXT
  2522.   ED-KEY INSERT-CHAR
  2523. ;
  2524.  
  2525. : EXECUTE-FORTH-LINE
  2526.   0 17 LOCATE 27 EMIT 84 EMIT REFORTH
  2527.   1 MUST-UPDATE ! TOP-LEVEL ;
  2528. -->
  2529. ------------------ SCREEN 26 ------------------
  2530. ( EDITOR -- SCREEN 17 OF 19 -- )
  2531.  
  2532.  
  2533.  
  2534.  
  2535.  
  2536.  
  2537.  
  2538.  
  2539.  
  2540.  
  2541.  
  2542.  
  2543.  
  2544.  
  2545. -->
  2546. ------------------ SCREEN 27 ------------------
  2547. ( EDITOR -- SCREEN 18 OF 19 -- INITIALIZE BINDINGS )
  2548.  
  2549.   ' PREV-LINE CFA 11 (BIND)  ( ^K )
  2550.   ' NEXT-LINE CFA 10 (BIND)  ( ^J )
  2551.   ' PREV-CHAR CFA  8 (BIND)  ( ^H )
  2552.   ' NEXT-CHAR CFA 12 (BIND)  ( ^L )
  2553.   ' NEXT-SCR  CFA  3 (BIND)  ( ^C )
  2554.   ' PREV-SCR  CFA 18 (BIND)  ( ^R )
  2555.   ' EXIT-EDIT CFA 209 (BIND)  ( ESC-Q )
  2556.   ' EDIT-CR   CFA 13 (BIND)  ( ^M )
  2557.   ' TAB-KEY   CFA  9 (BIND)  ( ^I )
  2558.   ' UPDATE-SCR CFA 21 (BIND) ( ^U )
  2559.   ' NEXT-WORD CFA  6 (BIND)  ( ^F )
  2560.   ' PREV-WORD CFA  1 (BIND)  ( ^A )
  2561.   ' UPDATE-AND-FLUSH CFA 198 (BIND) ( ESC-F )
  2562. -->
  2563. ------------------ SCREEN 28 ------------------
  2564. ( EDITOR -- SCREEN 19 OF 19 -- MORE BINDINGS )
  2565.  
  2566.   ' DEL-TO-END-OF-LINE CFA 25 (BIND)  ( ^Y )
  2567.   ' PREV-CHAR CFA 19 (BIND)     ( ^S )
  2568.   ' PREV-LINE CFA 5 (BIND)      ( ^E )
  2569.   ' NEXT-LINE CFA 24 (BIND)     ( ^X )
  2570.   ' NEXT-CHAR CFA 4 (BIND)      ( ^D )
  2571.   ' TO-BUFFER CFA 190 (BIND)    ( ESC-> )
  2572.   ' FROM-BUFFER CFA 188 (BIND)  ( ESC-< )
  2573.   ' NEXT-SCREEN CFA 195 (BIND)  ( ESC-C )
  2574.   ' PREV-SCREEN CFA 210 (BIND)  ( ESC-R )
  2575.   ' QUOTE-NEXT CFA 16 (BIND)    ( ^P )
  2576.   ' EXECUTE-FORTH-LINE CFA 155 (BIND) ( ESC-ESC )
  2577.  
  2578. CR ." EDITOR READY "
  2579. ;S
  2580. ------------------ SCREEN 29 ------------------
  2581. //go.sysin dd *
  2582.