home *** CD-ROM | disk | FTP | other *** search
/ Technotools / Technotools (Chestnut CD-ROM)(1993).ISO / unix / cforth / cforth.zoo / nf.c < prev    next >
Encoding:
C/C++ Source or Header  |  1988-06-08  |  17.5 KB  |  753 lines
  1. /* nf.c -- this program can be run to generate a new environment for the
  2.  * FORTH interpreter forth.c. It takes the dictionary from the standard input.
  3.  * Normally, this dictionary is in the file "forth.dict", so 
  4.  *    nf < forth.dict
  5.  * will do the trick.
  6.  */
  7.  
  8. #include <stdio.h>
  9. #include <ctype.h>
  10. #include "common.h"
  11. #include "forth.lex.h"        /* #defines for lexical analysis */
  12.  
  13. #define isoctal(c)    (c >= '0' && c <= '7')    /* augument ctype.h */
  14.  
  15. #define assert(c,s)    (!(c) ? failassert(s) : 1)
  16. #define chklit()    (!prev_lit ? dictwarn("Qustionable literal") : 1)
  17.  
  18. #define LINK struct linkrec
  19. #define CHAIN struct chainrec
  20.  
  21. struct chainrec {
  22.     char chaintext[32];
  23.     int defloc;                /* CFA or label loc */
  24.     int chaintype;            /* 0=undef'd, 1=absolute, 2=relative */
  25.     CHAIN *nextchain;
  26.     LINK *firstlink;
  27. };
  28.  
  29. struct linkrec {
  30.     int loc;
  31.     LINK *nextlink;
  32. };
  33.  
  34. CHAIN firstchain;
  35.  
  36. #define newchain()    (CHAIN *)(calloc(1,sizeof(CHAIN)))
  37. #define newlink()    (LINK *)(calloc(1,sizeof(LINK)))
  38.  
  39. CHAIN *find();
  40. CHAIN *lastchain();
  41. LINK *lastlink();
  42.  
  43. char *strcat();
  44. char *calloc();
  45.  
  46. int dp = DPBASE;
  47. int latest;
  48.  
  49. short mem[INITMEM];
  50.  
  51. FILE *outf, *fopen();
  52.  
  53. main(argc, argv)
  54. int argc;
  55. char *argv[];
  56. {
  57. #ifdef DEBUG
  58.     puts("Opening output file");
  59. #endif DEBUG
  60.  
  61.     strcpy(firstchain.chaintext," ** HEADER **");
  62.     firstchain.nextchain = NULL;
  63.     firstchain.firstlink = NULL;
  64.  
  65. #ifdef DEBUG
  66.     puts("call builddict");
  67. #endif DEBUG
  68.     builddict();
  69. #ifdef DEBUG
  70.     puts("Make FORTH and COLDIP");
  71. #endif DEBUG
  72.     mkrest();
  73. #ifdef DEBUG
  74.     puts("Call Buildcore");
  75. #endif DEBUG
  76.     buildcore();
  77. #ifdef DEBUG
  78.     puts("call checkdict");
  79. #endif DEBUG
  80.     checkdict();
  81. #ifdef DEBUG
  82.     puts("call writedict");
  83. #endif DEBUG
  84.     writedict();
  85.  
  86.     printf("%s: done.\n", argv[0]); 
  87.     return 0;
  88. }
  89.  
  90. buildcore()            /* set up low core */
  91. {
  92.     mem[USER_DEFAULTS+0] = INITS0;            /* initial S0 */
  93.     mem[USER_DEFAULTS+1] = INITR0;            /* initial R0 */
  94.     mem[USER_DEFAULTS+2] = TIB_START;        /* initial TIB */
  95.     mem[USER_DEFAULTS+3] = MAXWIDTH;        /* initial WIDTH */
  96.     mem[USER_DEFAULTS+4] = 0;            /* initial WARNING */
  97.     mem[USER_DEFAULTS+5] = dp;            /* initial FENCE */
  98.     mem[USER_DEFAULTS+6] = dp;            /* initial DP */
  99.     mem[USER_DEFAULTS+7] = instance("FORTH") + 3;    /* initial CONTEXT */
  100.  
  101.     mem[SAVEDIP] = 0;                /* not a saved FORTH */
  102. }
  103.  
  104. builddict()            /* read the dictionary */
  105. {
  106.     int prev_lit = 0, lit_flag = 0;
  107.     int temp;
  108.     char s[256];
  109.     TOKEN *token;
  110.  
  111.     while ((token = yylex()) != NULL) {    /* EOF returned as a null pointer */
  112. #ifdef DEBUG
  113.     printf("\ntoken: %s: %d ",token->text, token->type);
  114. #endif DEBUG
  115.     switch (token->type) {
  116.  
  117.     case PRIM:
  118. #ifdef DEBUG
  119.         printf("primitive ");
  120. #endif DEBUG
  121.         if ((token = yylex()) == NULL)    /* get the next word */
  122.         dicterr("No word following PRIM");
  123.         strcpy (s,token->text);
  124. #ifdef DEBUG
  125.         printf(".%s. ",s);
  126. #endif DEBUG
  127.         if ((token == yylex()) == NULL)    /* get the value */
  128.         dicterr("No value following PRIM <word>");
  129.         mkword(s,mkval(token));
  130.         break;
  131.  
  132.     case CONST:
  133. #ifdef DEBUG
  134.         printf("constant ");
  135. #endif DEBUG
  136.         if ((token = yylex()) == NULL)    /* get the word */
  137.         dicterr("No word following CONST");
  138.         strcpy (s,token->text);        /* s holds word */
  139. #ifdef DEBUG
  140.         printf(".%s. ",s);
  141. #endif DEBUG
  142.         if (!find("DOCON"))
  143.         dicterr ("Constant definition before DOCON: %s",s);
  144.                 /* put the CF of DOCON into this word's CF */
  145.         mkword(s,(int)mem[instance("DOCON")]);
  146.         if ((token = yylex()) == NULL)    /* get the value */
  147.         dicterr("No value following CONST <word>");
  148.         temp = mkval(token);
  149.  
  150.         /* two special-case constants */
  151.         if (strcmp(s,"FIRST") == 0) temp = INITR0;
  152.         else if (strcmp(s,"LIMIT") == 0) temp = DPBASE;
  153.  
  154.         comma(temp);
  155.         break;
  156.  
  157.     case VAR:
  158. #ifdef DEBUG
  159.         printf("variable ");
  160. #endif DEBUG
  161.         if ((token = yylex()) == NULL)    /* get the variable name */
  162.         dicterr("No word following VAR");
  163.         strcpy (s,token->text);
  164. #ifdef DEBUG
  165.         printf(".%s. ",s);
  166. #endif DEBUG
  167.         if (!find("DOVAR"))
  168.         dicterr("Variable declaration before DOVAR: %s",s);
  169.         mkword (s, (int)mem[instance("DOVAR")]);
  170.         if ((token = yylex()) == NULL)    /* get the value */
  171.         dicterr("No value following VAR <word>");
  172.         comma(mkval(token));
  173.         break;
  174.  
  175.     case USER:
  176. #ifdef DEBUG
  177.         printf("uservar ");
  178. #endif DEBUG
  179.         if ((token = yylex()) == NULL)    /* get uservar name */
  180.         dicterr("No name following USER");
  181.         strcpy (s,token->text);
  182. #ifdef DEBUG
  183.         printf(".%s. ",s);
  184. #endif DEBUG
  185.         if (!find("DOUSE"))
  186.         dicterr("User variable declared before DOUSE: %s",s);
  187.         mkword (s, (int)mem[instance("DOUSE")]);
  188.         if ((token = yylex()) == NULL)    /* get the value */
  189.         dicterr("No value following USER <word>");
  190.         comma(mkval(token));
  191.         break;
  192.  
  193.     case COLON:
  194. #ifdef DEBUG
  195.         printf("colon def'n ");
  196. #endif DEBUG
  197.         if ((token = yylex()) == NULL)    /* get name of word */
  198.         dicterr("No word following : in definition");
  199.         strcpy (s,token->text);
  200. #ifdef DEBUG
  201.         printf(".%s.\n",s);
  202. #endif DEBUG
  203.         if (!find("DOCOL"))
  204.         dicterr("Colon definition appears before DOCOL: %s",s);
  205.  
  206.         if (token->type == NUL) {    /* special zero-named word */
  207.         int here = dp;        /* new latest */
  208. #ifdef DEBUG
  209.         printf("NULL WORD AT 0x%04x\n");
  210. #endif DEBUG
  211.         comma(0xC1);
  212.         comma(0x80);
  213.         comma(latest);
  214.         latest = here;
  215.         comma((int)mem[instance("DOCOL")]);
  216.         }
  217.         else {
  218.         mkword (s, (int)mem[instance("DOCOL")]);
  219.         }
  220.         break;
  221.  
  222.     case SEMICOLON:
  223. #ifdef DEBUG
  224.         puts("end colon def'n");
  225. #endif DEBUG
  226.         comma (instance(";S"));
  227.         break;
  228.  
  229.     case SEMISTAR:
  230. #ifdef DEBUG
  231.         printf("end colon w/IMMEDIATE ");
  232. #endif DEBUG
  233.         comma (instance (";S"));    /* compile cfA of ;S, not CF */
  234.         mem[latest] |= IMMEDIATE;    /* make the word immediate */
  235.         break;
  236.  
  237.     case STRING_LIT:
  238. #ifdef DEBUG
  239.         printf("string literal ");
  240. #endif DEBUG
  241.         strcpy(s,token->text);
  242.         mkstr(s);        /* mkstr compacts the string in place */
  243. #ifdef DEBUG
  244.         printf("string=(%d) \"%s\" ",strlen(s),s);
  245. #endif DEBUG
  246.         comma(strlen(s));
  247.         {
  248.         char *stemp;
  249.         stemp = s;
  250.         while (*stemp) comma(*stemp++);
  251.         }
  252.         break;
  253.     
  254.     case COMMENT:
  255. #ifdef DEBUG
  256.         printf("comment ");
  257. #endif DEBUG
  258.         skipcomment();
  259.         break;
  260.  
  261.     case LABEL:
  262. #ifdef DEBUG
  263.         printf("label: ");
  264. #endif DEBUG
  265.         if ((token = yylex()) == NULL)
  266.         dicterr("No name following LABEL");
  267. #ifdef DEBUG
  268.         printf(".%s. ", token->text);
  269. #endif DEBUG
  270.         define(token->text,2);    /* place in sym. table w/o compiling
  271.                        anything into dictionary; 2 means
  272.                        defining a label */
  273.         break;
  274.  
  275.     case LIT:
  276.         lit_flag = 1;        /* and fall through to the rest */
  277.  
  278.     default:
  279.         if (find(token->text) != NULL) {    /* is word defined? */
  280. #ifdef DEBUG
  281.         printf("  normal: %s\n",token->text);
  282. #endif DEBUG
  283.             comma (instance (token->text));
  284.         break;
  285.         }
  286.  
  287.         /* else */
  288.         /* the literal types all call chklit(). This macro checks to
  289.            if the previous word was "LIT"; if not, it warns */
  290.         switch(token->type) {
  291.         case DECIMAL: chklit(); comma(mkdecimal(token->text)); break;
  292.         case HEX: chklit(); comma(mkhex(token->text)); break;
  293.         case OCTAL: chklit(); comma(mkoctal(token->text)); break;
  294.         case C_BS: chklit(); comma('\b'); break;
  295.         case C_FF: chklit(); comma('\f'); break;
  296.         case C_NL: chklit(); comma('\n'); break;
  297.         case C_CR: chklit(); comma('\r'); break;
  298.         case C_TAB: chklit(); comma('\t'); break;
  299.         case C_BSLASH: chklit(); comma(0x5c); break;  /* ASCII backslash */
  300.         case C_LIT: chklit(); comma(*((token->text)+1)); break;
  301.  
  302.         default:
  303. #ifdef DEBUG
  304.         printf("forward reference");
  305. #endif DEBUG
  306.         comma (instance (token->text));        /* create an instance,
  307.                         to be resolved at definition */
  308.         }
  309.     }
  310. #ifdef DEBUG
  311.     if (lit_flag) puts("expect a literal");
  312. #endif DEBUG
  313.     prev_lit = lit_flag;    /* to be used by chklit() next time */
  314.     lit_flag = 0;
  315.     }
  316. }
  317.  
  318. comma(i)            /* put at mem[dp]; increment dp */
  319. {
  320.     mem[dp++] = (unsigned short)i;
  321.     if (dp > INITMEM) dicterr("DICTIONARY OVERFLOW");
  322. }
  323.  
  324. /*
  325.  * make a word in the dictionary.  the new word will have name *s, its CF
  326.  * will contain v. Also, resolve any previously-unresolved references by
  327.  * calling define()
  328.  */
  329.  
  330. mkword(s, v)
  331. char *s;
  332. short v;
  333. {
  334.     int here, count = 0;
  335.     char *olds;
  336.     olds = s;        /* preserve this for resolving references */
  337.  
  338. #ifdef DEBUG
  339.     printf("%s ",s);
  340. #endif DEBUG
  341.  
  342.     here = dp;        /* hold this value to place length byte */
  343.  
  344.     while (*s) {        /* for each character */
  345.         mem[++dp] = (unsigned short)*s;
  346.         count++; s++;
  347.     }
  348.  
  349.     if (count >= MAXWIDTH) dicterr("Input word name too long");
  350.  
  351.                 /* set MSB on */
  352.     mem[here] = (short)(count | 0x80);
  353.  
  354.     mem[dp++] |= 0x80;    /* set hi bit of last char in name */
  355.     
  356.     mem[dp++] = (short)latest;    /* the link field */
  357.  
  358.     latest = here;        /* update the link */
  359.  
  360.     mem[dp] = v;        /* code field; leave dp = CFA */
  361.  
  362.     define(olds,1);        /* place in symbol table. 1 == "not a label" */
  363.     dp++;            /* now leave dp holding PFA */
  364.  
  365.     /* that's all. Now dp points (once again) to the first UNallocated
  366.            spot in mem, and everybody's happy. */
  367. }
  368.  
  369. mkrest()            /* Write out the word FORTH as a no-op with
  370.                    DOCOL as CF, ;S as PF, followed by
  371.                    0xA081, and latest in its PF.
  372.                    Also, Put the CFA of ABORT at 
  373.                    mem[COLDIP] */
  374. {
  375.     int temp;
  376.  
  377.     mem[COLDIP] = dp;    /* the cold-start IP is here, and the word
  378.                    which will be executed is COLD */
  379.     if ((mem[dp++] = instance("COLD")) == 0)
  380.         dicterr("COLD must be defined to take control at startup");
  381.  
  382.     mem[ABORTIP] = dp;    /* the abort-start IP is here, and the word
  383.                    which will be executed is ABORT */
  384.     if ((mem[dp++] = instance("ABORT")) == 0)
  385.         dicterr("ABORT must be defined to take control at interrupt");
  386.  
  387.     mkword("FORTH",mem[instance("DOCOL")]);
  388.     comma(instance(";S"));
  389.     comma(0xA081);    /* magic number for vocabularies */
  390.     comma(latest);        /* NFA of last word in dictionary: FORTH */
  391.  
  392.     mem[LIMIT] = dp + 1024;
  393.     if (mem[LIMIT] >= INITMEM) mem[LIMIT] = INITMEM-1;
  394. }
  395.  
  396. writedict()            /* write memory to COREFILE and map 
  397.                       to MAPFILE */
  398. {
  399.     FILE   *outfile;
  400.     int     i, temp, tempb, firstzero, nonzero;
  401.     char    chars[9], outline[80], tstr[6];
  402.  
  403.     outfile = fopen(MAPFILE,"w");
  404.  
  405.     for (temp = 0; temp < dp; temp += 8) {
  406.     nonzero = FALSE;
  407.     sprintf (outline, "%04x:", temp);
  408.     for (i = temp; i < temp + 8; i++) {
  409.         sprintf (tstr, " %04x", (unsigned short) mem[i]);
  410.         strcat (outline, tstr);
  411.         tempb = mem[i] & 0x7f;
  412.         if (tempb < 0x7f && tempb >= ' ')
  413.         chars[i % 8] = tempb;
  414.         else
  415.         chars[i % 8] = '.';
  416.         nonzero |= mem[i];
  417.     }
  418.     if (nonzero) {
  419.         fprintf (outfile, "%s %s\n", outline, chars);
  420.         firstzero = TRUE;
  421.     }
  422.     else
  423.         if (firstzero) {
  424.         fprintf (outfile, "----- ZERO ----\n");
  425.         firstzero = FALSE;
  426.         }
  427.     }
  428.     fclose (outfile);
  429.  
  430.  
  431.     printf ("Writing %s; DPBASE=%d; dp=%d\n", COREFILE, DPBASE, dp);
  432.  
  433.     if ((outf = fopen (COREFILE, "w")) == NULL) {
  434.     printf ("nf: can't open %s for output.\n", COREFILE);
  435.     exit (1);
  436.     }
  437.  
  438.     if (fwrite (mem, sizeof (*mem), mem[LIMIT], outf) != mem[LIMIT]) {
  439.     fprintf (stderr, "Error writing to %s\n", COREFILE);
  440.     exit (1);
  441.     }
  442.  
  443.     if (fclose (outf) == EOF) {
  444.     fprintf (stderr, "Error closing %s\n", COREFILE);
  445.     exit (1);
  446.     }
  447. }
  448.  
  449. mkval(t)            /* convert t->text to integer based on type */
  450. TOKEN *t;
  451. {
  452.     char *s = t->text;
  453.     int sign = 1;
  454.  
  455.     if (*s == '-') {
  456.         sign = -1;
  457.         s++;
  458.     }
  459.  
  460.     switch (t->type) {
  461.     case DECIMAL:
  462.         return (sign * mkdecimal(s));
  463.     case HEX:
  464.         return (sign * mkhex(s));
  465.     case OCTAL:
  466.         return (sign * mkoctal(s));
  467.     default:
  468.         dicterr("Bad value following PRIM, CONST, VAR, or USER");
  469.     }
  470. }
  471.  
  472. mkhex(s)
  473. char *s;
  474. {                /*  convert hex ascii to integer */
  475.     int     temp;
  476.     temp = 0;
  477.  
  478.     s += 2;            /* skip over '0x' */
  479.     while (isxdigit (*s)) {    /* first non-hex char ends */
  480.     temp <<= 4;        /* mul by 16 */
  481.     if (isupper (*s))
  482.         temp += (*s - 'A') + 10;
  483.     else
  484.         if (islower (*s))
  485.         temp += (*s - 'a') + 10;
  486.         else
  487.         temp += (*s - '0');
  488.     s++;
  489.     }
  490.     return temp;
  491. }
  492.  
  493. mkoctal(s)
  494. char *s;
  495. {                /*  convert Octal ascii to integer */
  496.     int     temp;
  497.     temp = 0;
  498.  
  499.     while (isoctal (*s)) {    /* first non-octal char ends */
  500.     temp = temp * 8 + (*s - '0');
  501.     s++;
  502.     }
  503.     return temp;
  504. }
  505.  
  506. mkdecimal(s)            /* convert ascii to decimal */
  507. char *s;
  508. {
  509.     return (atoi(s));    /* alias */
  510. }
  511.  
  512. dicterr(s,p1)
  513. char *s;
  514. int p1;        /* might be char * -- printf uses it */
  515. {
  516.     fprintf(stderr,s,p1);
  517.     fprintf(stderr,"\nLast word defined was ");
  518.     printword(latest);
  519. /*    fprintf(stderr, "; last word read was \"%s\"", token->text); */
  520.     fprintf(stderr,"\n");
  521.     exit(1);
  522. }
  523.  
  524. dictwarn(s)        /* almost like dicterr, but don't exit */
  525. char *s;
  526. {
  527.     fprintf(stderr,"\nWarning: %s\nLast word read was ",s);
  528.     printword(latest);
  529.     putc('\n',stderr);
  530. }
  531.     
  532. printword(n)
  533. int n;
  534. {
  535.     int count, tmp;
  536.     count = mem[n] & 0x1f;
  537.     for (n++;count;count--,n++) {
  538.     tmp = mem[n] & ~0x80;        /* mask eighth bit off */
  539.     if (tmp >= ' ' && tmp <= '~') putc(tmp, stderr);
  540.     }
  541. }
  542.  
  543. skipcomment()
  544. {
  545.     while(getchar() != ')');
  546. }
  547.  
  548. mkstr(s)            /* modifies a string in place with escapes
  549.                    compacted. Strips leading & trailing \" */
  550. char *s;
  551. {
  552.     char *source;
  553.     char *dest;
  554.  
  555.     source = dest = s;
  556.     source++;            /* skip leading quote */
  557.     while (*source != '"') {    /* string ends with unescaped \" */
  558.     if (*source == '\\') {    /* literal next */
  559.         source++;
  560.     }
  561.     *dest++ = *source++;
  562.     }
  563.     *dest = '\0';
  564. }
  565.  
  566. failassert(s)
  567. char *s;
  568. {
  569.     puts(s);
  570.     exit(1);
  571. }
  572.  
  573. checkdict()            /* check for unresolved references */
  574. {
  575.     CHAIN *ch = &firstchain;
  576.  
  577. #ifdef DEBUG
  578.     puts("\nCheck for unresolved references");
  579. #endif DEBUG
  580.     while (ch != NULL) {
  581. #ifdef DEBUG
  582.     printf("ch->chaintext = .%s. - ",ch->chaintext);
  583. #endif DEBUG
  584.     if ((ch->firstlink) != NULL) {
  585.         fprintf(stderr,"Unresolved forward reference: %s\n",ch->chaintext);
  586. #ifdef DEBUG
  587.         puts("still outstanding");
  588. #endif DEBUG
  589.     }
  590. #ifdef DEBUG
  591.     else puts("clean.");
  592. #endif DEBUG
  593.     ch = ch->nextchain;
  594.     }
  595. }
  596.  
  597.     
  598. /********* structure-handling functions find(s), define(s,t), instance(s) **/
  599.  
  600. CHAIN *find(s)        /* returns a pointer to the chain named s */
  601. char *s;
  602. {
  603.     CHAIN *ch;
  604.     ch = &firstchain;
  605.     while (ch != NULL) {
  606.         if (strcmp (s, ch->chaintext) == 0) return ch;
  607.         else ch = ch->nextchain;
  608.     }
  609.     return NULL;    /* not found */
  610. }
  611.  
  612. /* define must create a symbol table entry if none exists, with type t.
  613.    if one does exist, it must have type 0 -- it is an error to redefine
  614.    something at this stage. Change to type t, and fill in the outstanding
  615.    instances, with the current dp if type=1, or relative if type=2. */
  616.  
  617. define(s,t)        /* define s at current dp */
  618. char *s;
  619. int t;
  620. {
  621.     CHAIN *ch;
  622.     LINK *ln, *templn;
  623.  
  624. #ifdef DEBUG
  625.     printf("define(%s,%d)\n",s,t);
  626. #endif DEBUG
  627.  
  628.     if (t < 1 || t > 2)    /* range check */
  629.         dicterr("Program error: type in define() not 1 or 2.");
  630.  
  631.     if ((ch = find(s)) != NULL) {        /* defined or instanced? */
  632.         if (ch -> chaintype != 0)    /* already defined! */
  633.             dicterr("Word already defined: %s",s);
  634.         else {
  635. #ifdef DEBUG
  636.             printf("there are forward refs: ");
  637. #endif DEBUG
  638.             ch->chaintype = t;
  639.             ch->defloc = dp;
  640.         }
  641.     }
  642.     else {                /* must create a (blank) chain */
  643. #ifdef DEBUG
  644.         puts("no forward refs");
  645. #endif DEBUG
  646.         /* create a new chain, link it in, leave ch pointing to it */
  647.         ch = ((lastchain() -> nextchain) = newchain());
  648.         strcpy(ch->chaintext, s);
  649.         ch->chaintype = t;
  650.         ch->defloc = dp;    /* fill in for future references */
  651.     }
  652.  
  653.     /* now ch points to the chain (possibly) containing forward refs */
  654.     if ((ln = ch->firstlink) == NULL) return;    /* no links! */
  655.  
  656.     while (ln != NULL) {
  657. #ifdef DEBUG
  658.         printf("    Forward ref at 0x%x\n",ln->loc);
  659. #endif DEBUG
  660.         switch (ch->chaintype) {
  661.         case 1: mem[ln->loc] = (short)dp;    /* absolute */
  662.             break;
  663.         case 2: mem[ln->loc] = (short)(dp - ln->loc);    /* relative */
  664.             break;
  665.         default: dicterr ("Bad type field in define()");
  666.         }
  667.  
  668.         /* now skip to the next link & free this one */
  669.         templn = ln;
  670.         ln = ln->nextlink;
  671.         free(templn);
  672.     }
  673.     ch->firstlink = NULL;    /* clean up that last pointer */
  674. }
  675.  
  676. /*
  677.    instance must return a value to be compiled into the dictionary at
  678.    dp, consistent with the symbol s: if s is undefined, it returns 0,
  679.    and adds this dp to the chain for s (creating that chain if necessary).
  680.    If s IS defined, it returns <s> (absolute) or (s-dp) (relative), 
  681.    where <s> was the dp when s was defined.
  682. */
  683.  
  684. instance(s)
  685. char *s;
  686. {
  687.     CHAIN *ch;
  688.     LINK *ln;
  689.  
  690. #ifdef DEBUG
  691.     printf("instance(%s):\n",s);
  692. #endif DEBUG
  693.  
  694.     if ((ch = find(s)) == NULL) {    /* not defined yet at all */
  695. #ifdef DEBUG
  696.         puts("entirely new -- create a new chain");
  697. #endif DEBUG
  698.         /* create a new chain, link it in, leave ch pointing to it */
  699.         ch = ((lastchain() -> nextchain) = newchain());
  700.  
  701.         strcpy(ch->chaintext, s);
  702.         ln = newlink();        /* make its link */
  703.         ch->firstlink = ln;
  704.         ln->loc = dp;        /* store this location there */
  705.         return 0;        /* all done */
  706.     }
  707.     else {
  708.         switch(ch->chaintype) {
  709.         case 0:            /* not defined yet */
  710. #ifdef DEBUG
  711.             puts("still undefined -- add a link");
  712. #endif DEBUG
  713.             /* create a new link, point the last link to it, and
  714.                fill in the loc field with the current dp */
  715.             (lastlink(ch)->nextlink = newlink()) -> loc = dp;
  716.             return 0;
  717.         case 1:            /* absolute */
  718. #ifdef DEBUG
  719.             puts("defined absolute.");
  720. #endif DEBUG
  721.             return ch->defloc;
  722.         case 2:            /* relative */
  723. #ifdef DEBUG
  724.             puts("defined relative.");
  725. #endif DEBUG
  726.             return ch->defloc - dp;
  727.         default:
  728.             dicterr("Program error: bad type for chain");
  729.         }
  730.     }
  731. }
  732.  
  733. CHAIN *lastchain()    /* starting from firstchain, find the last chain */
  734. {
  735.     CHAIN *ch = &firstchain;
  736.     while (ch->nextchain != NULL) ch = ch->nextchain;
  737.     return ch;
  738. }
  739.  
  740. LINK *lastlink(ch)    /* return the last link in the chain */
  741. CHAIN *ch;        /* CHAIN MUST HAVE AT LEAST ONE LINK */
  742. {
  743.     LINK *ln = ch->firstlink;
  744.  
  745.     while (ln->nextlink != NULL) ln = ln->nextlink;
  746.     return ln;
  747. }
  748.  
  749. yywrap()    /* called by yylex(). returning 1 means "all finished" */
  750. {
  751.     return 1;
  752. }
  753.