home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume1 / cforth / part3 < prev    next >
Internet Message Format  |  1986-11-30  |  48KB
  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 3 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 - l2b.c'
  9. sed 's/^X//' <<'//go.sysin dd *' >l2b.c
  10. X/* usage: line2block < linefile > blockfile
  11.  * takes a file (like one generated by block2line) of the form:
  12.  *    <header line>
  13.  *    < 16 screen lines >
  14.  *    ...
  15.  * and produces a block file with exactly 64 characters on each line, having
  16.  * removed the header lines. This file is suitable for use with FORTH as a
  17.  * block file.
  18.  */
  19.  
  20. #include <stdio.h>
  21.  
  22. main()
  23. {
  24.     int i;
  25.     char buf[65];
  26.     char *spaces =    /* 64 spaces, below */
  27.     "                                                                ";
  28.             /* 64 spaces, above */
  29.     while (1) {
  30.         gets(buf);            /* header line */
  31.         for (i=0; i<16; i++) {
  32.             if (gets(buf) == NULL) exit(0);
  33.             printf("%s%s",buf,spaces+strlen(buf));
  34.         }
  35.     }
  36. }
  37.             
  38. //go.sysin dd *
  39. echo 'x - lex.yy.c'
  40. sed 's/^X//' <<'//go.sysin dd *' >lex.yy.c
  41. # include "stdio.h"
  42. # define U(x) x
  43. # define NLSTATE yyprevious=YYNEWLINE
  44. # define BEGIN yybgin = yysvec + 1 +
  45. # define INITIAL 0
  46. # define YYLERR yysvec
  47. # define YYSTATE (yyestate-yysvec-1)
  48. # define YYOPTIM 1
  49. # define YYLMAX 200
  50. # define output(c) putc(c,yyout)
  51. # define input() (((yytchar=yysptr>yysbuf?U(*--yysptr):getc(yyin))==10?(yylineno++,yytchar):yytchar)==EOF?0:yytchar)
  52. # define unput(c) {yytchar= (c);if(yytchar=='\n')yylineno--;*yysptr++=yytchar;}
  53. # define yymore() (yymorfg=1)
  54. # define ECHO fprintf(yyout, "%s",yytext)
  55. # define REJECT { nstr = yyreject(); goto yyfussy;}
  56. int yyleng; extern char yytext[];
  57. int yymorfg;
  58. extern char *yysptr, yysbuf[];
  59. int yytchar;
  60. XFILE *yyin ={stdin}, *yyout ={stdout};
  61. extern int yylineno;
  62. struct yysvf { 
  63.     struct yywork *yystoff;
  64.     struct yysvf *yyother;
  65.     int *yystops;};
  66. struct yysvf *yyestate;
  67. extern struct yysvf yysvec[], *yybgin;
  68. X/* LEX input for FORTH input file scanner */
  69. X/* 
  70.     Specifications are as follows:
  71.     This file must be run through "sed" to change 
  72.         yylex () {
  73.     to
  74.         TOKEN *yylex () {
  75.     where the sed script is
  76.         sed "s/yylex () {/TOKEN *yylex () {/" lex.yy.c
  77.  
  78.     Note that spaces have been included above so these lines won't be
  79.     mangled by sed; in actuality, the two blanks surrounding () are
  80.     removed.
  81.  
  82.     The function "yylex()" always returns a pointer to a structure:
  83.  
  84.         struct tokenrec {
  85.         int type;
  86.         char *text;
  87.         }
  88.         #define TOKEN struct tokenrec
  89.  
  90.     where the type is a hint as to the word's type:
  91.         DECIMAL for decimal literal        d+
  92.         OCTAL for octal literal        0d*
  93.         HEX for hex literal        0xd+ or 0Xd+
  94.         C_BS for a literal Backspace    '\b'
  95.         C_FF for a literal Form Feed    '\f'
  96.         C_NL for a literal Newline    '\n'
  97.         C_CR for a literal Carriage Return '\r'
  98.         C_TAB for a literal Tab '\t'
  99.         C_BSLASH for a literal backslash '\\'
  100.         C_IT for an other character literal 'x' where x is possibly '
  101.         STRING_LIT for a string literal (possibly containing \")
  102.         COMMENT for a left-parenthesis (possibly beginning a comment)
  103.         PRIM for "PRIM"
  104.         CONST for "CONST"
  105.         VAR for "VAR"
  106.         USER for "USER"
  107.         LABEL for "LABEL"
  108.         COLON for ":"
  109.         SEMICOLON for ";"
  110.         SEMISTAR for ";*" (used to make words IMMEDIATE)
  111.         NUL for the token {NUL}, which gets compiled as a null byte;
  112.             this special interpretation takes place in the COLON
  113.             code.
  114.         LIT for the word "LIT" (treated like OTHER, except that
  115.             no warning is generated when a literal follows this)
  116.         OTHER for an other word not recognized above
  117.  
  118.     Note that this is just a hint: the meaning of any string of characters
  119.     depends on the context.
  120.  
  121. */
  122. #include "forth.lex.h"
  123. TOKEN token;
  124. # define YYNEWLINE 10
  125. TOKEN *yylex(){
  126. int nstr; extern int yyprevious;
  127. while((nstr = yylook()) >= 0)
  128. yyfussy: switch(nstr){
  129. case 0:
  130. if(yywrap()) return(0); break;
  131. case 1:
  132. X/* whitespace -- keep looping */ ;
  133. break;
  134. case 2:
  135.     { token.type = DECIMAL; token.text = yytext;
  136.                     return &token; }
  137. break;
  138. case 3:
  139.     { token.type = OCTAL; token.text = yytext;
  140.                     return &token; }
  141. break;
  142. case 4:
  143.     { token.type = HEX; token.text = yytext;
  144.                     return &token; }
  145. break;
  146. case 5:
  147. { token.type = C_BS; token.text = yytext; return &token; }
  148. break;
  149. case 6:
  150. { token.type = C_FF; token.text = yytext; return &token; }
  151. break;
  152. case 7:
  153. { token.type = C_NL; token.text = yytext; return &token; }
  154. break;
  155. case 8:
  156. { token.type = C_CR; token.text = yytext; return &token; }
  157. break;
  158. case 9:
  159. { token.type = C_TAB; token.text = yytext; return &token; }
  160. break;
  161. case 10:
  162. { token.type = C_BSLASH; token.text = yytext; return &token; }
  163. break;
  164. case 11:
  165. { token.type = C_LIT; token.text = yytext; return &token; }
  166. break;
  167. case 12:
  168. { token.type = STRING_LIT; token.text = yytext; 
  169.                 return &token; }
  170. break;
  171. case 13:
  172.     { token.type = COMMENT; token.text = yytext;
  173.                 return &token; }
  174. break;
  175. case 14:
  176.     { token.type = PRIM; token.text = yytext;
  177.                 return &token; }
  178. break;
  179. case 15:
  180.     { token.type = CONST; token.text = yytext;
  181.                 return &token; }
  182. break;
  183. case 16:
  184.     { token.type = VAR; token.text = yytext;
  185.                 return &token; }
  186. break;
  187. case 17:
  188.     { token.type = USER; token.text = yytext;
  189.                 return &token; }
  190. break;
  191. case 18:
  192.     { token.type = LABEL; token.text = yytext;
  193.                 return &token; }
  194. break;
  195. case 19:
  196.     { token.type = COLON; token.text = yytext;
  197.                 return &token; }
  198. break;
  199. case 20:
  200.     { token.type = SEMICOLON; token.text = yytext;
  201.                 return &token; }
  202. break;
  203. case 21:
  204.     { token.type = SEMISTAR; token.text = yytext;
  205.                 return &token; }
  206. break;
  207. case 22:
  208.     { token.type = NUL; token.text = yytext;
  209.                 return &token; }
  210. break;
  211. case 23:
  212.     { token.type = LIT; token.text = yytext;
  213.                 return &token; }
  214. break;
  215. case 24:
  216. { token.type = OTHER; token.text = yytext;
  217.                 return &token; }
  218. break;
  219. case -1:
  220. break;
  221. default:
  222. fprintf(yyout,"bad switch yylook %d",nstr);
  223. } return(0); }
  224. X/* end of yylex */
  225. int yyvstop[] ={
  226. 0,
  227.  
  228. 1,
  229. 0,
  230.  
  231. 1,
  232. 0,
  233.  
  234. -24,
  235. 0,
  236.  
  237. 1,
  238. 0,
  239.  
  240. -24,
  241. 0,
  242.  
  243. -24,
  244. 0,
  245.  
  246. -13,
  247. -24,
  248. 0,
  249.  
  250. -24,
  251. 0,
  252.  
  253. -3,
  254. -24,
  255. 0,
  256.  
  257. -2,
  258. -24,
  259. 0,
  260.  
  261. -19,
  262. -24,
  263. 0,
  264.  
  265. -20,
  266. -24,
  267. 0,
  268.  
  269. -24,
  270. 0,
  271.  
  272. -24,
  273. 0,
  274.  
  275. -24,
  276. 0,
  277.  
  278. -24,
  279. 0,
  280.  
  281. -24,
  282. 0,
  283.  
  284. -24,
  285. 0,
  286.  
  287. 24,
  288. 0,
  289.  
  290. 24,
  291. 0,
  292.  
  293. -12,
  294. -24,
  295. 0,
  296.  
  297. -24,
  298. 0,
  299.  
  300. -24,
  301. 0,
  302.  
  303. 24,
  304. 0,
  305.  
  306. -24,
  307. 0,
  308.  
  309. 13,
  310. 24,
  311. 0,
  312.  
  313. 3,
  314. 24,
  315. 0,
  316.  
  317. -3,
  318. -24,
  319. 0,
  320.  
  321. -24,
  322. 0,
  323.  
  324. 2,
  325. 24,
  326. 0,
  327.  
  328. 19,
  329. 24,
  330. 0,
  331.  
  332. 20,
  333. 24,
  334. 0,
  335.  
  336. -21,
  337. -24,
  338. 0,
  339.  
  340. -24,
  341. 0,
  342.  
  343. -24,
  344. 0,
  345.  
  346. -24,
  347. 0,
  348.  
  349. -24,
  350. 0,
  351.  
  352. -24,
  353. 0,
  354.  
  355. -24,
  356. 0,
  357.  
  358. -24,
  359. 0,
  360.  
  361. -12,
  362. 0,
  363.  
  364. 12,
  365. 24,
  366. 0,
  367.  
  368. -12,
  369. -24,
  370. 0,
  371.  
  372. -11,
  373. -24,
  374. 0,
  375.  
  376. -11,
  377. 0,
  378.  
  379. -24,
  380. 0,
  381.  
  382. -24,
  383. 0,
  384.  
  385. -24,
  386. 0,
  387.  
  388. -24,
  389. 0,
  390.  
  391. -24,
  392. 0,
  393.  
  394. -24,
  395. 0,
  396.  
  397. -4,
  398. -24,
  399. 0,
  400.  
  401. 21,
  402. 24,
  403. 0,
  404.  
  405. -24,
  406. 0,
  407.  
  408. -24,
  409. 0,
  410.  
  411. -23,
  412. -24,
  413. 0,
  414.  
  415. -24,
  416. 0,
  417.  
  418. -24,
  419. 0,
  420.  
  421. -16,
  422. -24,
  423. 0,
  424.  
  425. -24,
  426. 0,
  427.  
  428. 12,
  429. 0,
  430.  
  431. -12,
  432. 0,
  433.  
  434. 12,
  435. 24,
  436. 0,
  437.  
  438. 11,
  439. 24,
  440. 0,
  441.  
  442. 11,
  443. 0,
  444.  
  445. -10,
  446. -24,
  447. 0,
  448.  
  449. -5,
  450. -24,
  451. 0,
  452.  
  453. -6,
  454. -24,
  455. 0,
  456.  
  457. -7,
  458. -24,
  459. 0,
  460.  
  461. -8,
  462. -24,
  463. 0,
  464.  
  465. -9,
  466. -24,
  467. 0,
  468.  
  469. 4,
  470. 24,
  471. 0,
  472.  
  473. -24,
  474. 0,
  475.  
  476. -24,
  477. 0,
  478.  
  479. 23,
  480. 24,
  481. 0,
  482.  
  483. -14,
  484. -24,
  485. 0,
  486.  
  487. -17,
  488. -24,
  489. 0,
  490.  
  491. 16,
  492. 24,
  493. 0,
  494.  
  495. -24,
  496. 0,
  497.  
  498. 12,
  499. 0,
  500.  
  501. 10,
  502. 24,
  503. 0,
  504.  
  505. 5,
  506. 24,
  507. 0,
  508.  
  509. 6,
  510. 24,
  511. 0,
  512.  
  513. 7,
  514. 24,
  515. 0,
  516.  
  517. 8,
  518. 24,
  519. 0,
  520.  
  521. 9,
  522. 24,
  523. 0,
  524.  
  525. -15,
  526. -24,
  527. 0,
  528.  
  529. -18,
  530. -24,
  531. 0,
  532.  
  533. 14,
  534. 24,
  535. 0,
  536.  
  537. 17,
  538. 24,
  539. 0,
  540.  
  541. -22,
  542. -24,
  543. 0,
  544.  
  545. 15,
  546. 24,
  547. 0,
  548.  
  549. 18,
  550. 24,
  551. 0,
  552.  
  553. 22,
  554. 24,
  555. 0,
  556. 0};
  557. # define YYTYPE char
  558. struct yywork { YYTYPE verify, advance; } yycrank[] ={
  559. 0,0,    0,0,    1,3,    0,0,    
  560. 0,0,    0,0,    0,0,    0,0,    
  561. 0,0,    0,0,    1,4,    1,4,    
  562. 0,0,    4,4,    4,4,    0,0,    
  563. 4,4,    4,4,    7,26,    7,26,    
  564. 11,31,    11,31,    21,44,    21,44,    
  565. 0,0,    12,32,    12,32,    33,55,    
  566. 33,55,    0,0,    42,63,    42,63,    
  567. 0,0,    42,63,    42,63,    1,5,    
  568. 4,4,    46,66,    46,66,    0,0,    
  569. 1,6,    1,7,    22,45,    3,3,    
  570. 23,46,    24,47,    1,8,    48,68,    
  571. 49,69,    1,9,    1,10,    3,19,    
  572. 3,19,    42,63,    50,70,    2,6,    
  573. 2,7,    1,10,    12,33,    1,11,    
  574. 1,12,    2,8,    5,5,    51,71,    
  575. 6,23,    52,72,    1,3,    43,64,    
  576. 1,13,    35,57,    5,20,    5,20,    
  577. 6,24,    6,19,    2,11,    2,12,    
  578. 3,3,    1,14,    37,59,    38,60,    
  579. 18,40,    1,15,    13,34,    2,13,    
  580. 15,37,    16,38,    1,16,    1,17,    
  581. 34,56,    1,3,    3,3,    3,3,    
  582. 2,14,    9,27,    9,27,    5,21,    
  583. 2,15,    6,23,    3,3,    36,58,    
  584. 22,22,    2,16,    2,17,    10,30,    
  585. 10,30,    8,9,    8,10,    3,3,    
  586. 39,61,    5,5,    5,5,    6,23,    
  587. 6,23,    8,10,    14,3,    40,62,    
  588. 41,43,    5,5,    53,73,    6,23,    
  589. 28,27,    28,27,    14,19,    14,19,    
  590. 1,18,    43,43,    5,5,    56,75,    
  591. 6,23,    57,76,    3,3,    59,78,    
  592. 9,28,    9,28,    45,65,    45,65,    
  593. 58,77,    58,77,    60,79,    2,18,    
  594. 29,54,    29,54,    10,10,    10,10,    
  595. 62,81,    25,46,    65,43,    14,3,    
  596. 29,54,    5,5,    10,10,    6,23,    
  597. 75,89,    5,22,    76,90,    6,25,    
  598. 81,93,    29,54,    82,43,    28,28,    
  599. 28,28,    14,3,    14,3,    0,0,    
  600. 47,67,    47,67,    0,0,    47,67,    
  601. 47,67,    14,3,    61,80,    61,80,    
  602. 9,29,    64,82,    64,82,    0,0,    
  603. 17,3,    0,0,    14,35,    14,3,    
  604. 14,3,    14,3,    14,3,    14,3,    
  605. 17,19,    17,19,    14,36,    47,67,    
  606. 68,83,    68,83,    69,84,    69,84,    
  607. 70,85,    70,85,    71,86,    71,86,    
  608. 72,87,    72,87,    25,48,    73,88,    
  609. 73,88,    14,3,    78,91,    78,91,    
  610. 25,49,    79,92,    79,92,    0,0,    
  611. 25,50,    17,3,    14,3,    14,3,    
  612. 14,3,    14,3,    14,3,    14,3,    
  613. 25,51,    45,22,    89,94,    89,94,    
  614. 25,52,    0,0,    25,53,    17,3,    
  615. 17,3,    90,95,    90,95,    93,96,    
  616. 93,96,    0,0,    0,0,    17,3,    
  617. 0,0,    0,0,    0,0,    0,0,    
  618. 0,0,    0,0,    20,41,    0,0,    
  619. 17,39,    17,3,    17,3,    17,3,    
  620. 17,3,    17,3,    20,41,    20,41,    
  621. 54,74,    54,74,    0,0,    0,0,    
  622. 0,0,    0,0,    0,0,    0,0,    
  623. 64,43,    0,0,    0,0,    0,0,    
  624. 0,0,    0,0,    0,0,    17,3,    
  625. 0,0,    0,0,    0,0,    0,0,    
  626. 0,0,    0,0,    0,0,    20,42,    
  627. 17,3,    17,3,    17,3,    17,3,    
  628. 17,3,    17,3,    0,0,    0,0,    
  629. 0,0,    0,0,    0,0,    0,0,    
  630. 0,0,    20,41,    20,41,    54,54,    
  631. 54,54,    0,0,    0,0,    0,0,    
  632. 0,0,    20,41,    0,0,    54,54,    
  633. 0,0,    0,0,    0,0,    0,0,    
  634. 0,0,    0,0,    20,41,    0,0,    
  635. 54,54,    0,0,    0,0,    0,0,    
  636. 0,0,    0,0,    0,0,    0,0,    
  637. 0,0,    0,0,    0,0,    0,0,    
  638. 0,0,    0,0,    0,0,    0,0,    
  639. 0,0,    0,0,    0,0,    0,0,    
  640. 0,0,    20,41,    0,0,    0,0,    
  641. 0,0,    20,43,    0,0,    0,0,    
  642. 0,0};
  643. struct yysvf yysvec[] ={
  644. 0,    0,    0,
  645. yycrank+-1,    0,        yyvstop+1,
  646. yycrank+-16,    yysvec+1,    yyvstop+3,
  647. yycrank+-42,    0,        yyvstop+5,
  648. yycrank+4,    0,        yyvstop+7,
  649. yycrank+-61,    0,        yyvstop+9,
  650. yycrank+-63,    0,        yyvstop+11,
  651. yycrank+-9,    yysvec+3,    yyvstop+13,
  652. yycrank+-57,    yysvec+3,    yyvstop+16,
  653. yycrank+-84,    yysvec+3,    yyvstop+18,
  654. yycrank+-94,    yysvec+3,    yyvstop+21,
  655. yycrank+-11,    yysvec+3,    yyvstop+24,
  656. yycrank+-16,    yysvec+3,    yyvstop+27,
  657. yycrank+-3,    yysvec+3,    yyvstop+30,
  658. yycrank+-113,    0,        yyvstop+32,
  659. yycrank+-2,    yysvec+3,    yyvstop+34,
  660. yycrank+-2,    yysvec+3,    yyvstop+36,
  661. yycrank+-175,    0,        yyvstop+38,
  662. yycrank+-2,    yysvec+3,    yyvstop+40,
  663. yycrank+0,    0,        yyvstop+42,
  664. yycrank+-237,    0,        yyvstop+44,
  665. yycrank+-13,    yysvec+3,    yyvstop+46,
  666. yycrank+-8,    yysvec+5,    yyvstop+49,
  667. yycrank+-5,    yysvec+3,    yyvstop+51,
  668. yycrank+6,    0,        yyvstop+53,
  669. yycrank+-106,    yysvec+3,    yyvstop+55,
  670. yycrank+0,    0,        yyvstop+57,
  671. yycrank+0,    0,        yyvstop+60,
  672. yycrank+-111,    yysvec+3,    yyvstop+63,
  673. yycrank+-92,    yysvec+3,    yyvstop+66,
  674. yycrank+0,    0,        yyvstop+68,
  675. yycrank+0,    0,        yyvstop+71,
  676. yycrank+0,    0,        yyvstop+74,
  677. yycrank+-18,    yysvec+3,    yyvstop+77,
  678. yycrank+-10,    yysvec+3,    yyvstop+80,
  679. yycrank+-3,    yysvec+3,    yyvstop+82,
  680. yycrank+-15,    yysvec+3,    yyvstop+84,
  681. yycrank+-5,    yysvec+3,    yyvstop+86,
  682. yycrank+-10,    yysvec+3,    yyvstop+88,
  683. yycrank+-26,    yysvec+3,    yyvstop+90,
  684. yycrank+-30,    yysvec+3,    yyvstop+92,
  685. yycrank+-24,    yysvec+20,    0,    
  686. yycrank+21,    0,        yyvstop+94,
  687. yycrank+-33,    yysvec+20,    0,    
  688. yycrank+0,    0,        yyvstop+96,
  689. yycrank+-125,    yysvec+5,    yyvstop+99,
  690. yycrank+-28,    yysvec+3,    yyvstop+102,
  691. yycrank+155,    0,        yyvstop+105,
  692. yycrank+-8,    yysvec+3,    yyvstop+107,
  693. yycrank+-9,    yysvec+3,    yyvstop+109,
  694. yycrank+-15,    yysvec+3,    yyvstop+111,
  695. yycrank+-24,    yysvec+3,    yyvstop+113,
  696. yycrank+-26,    yysvec+3,    yyvstop+115,
  697. yycrank+-79,    yysvec+3,    yyvstop+117,
  698. yycrank+-239,    yysvec+3,    yyvstop+119,
  699. yycrank+0,    0,        yyvstop+122,
  700. yycrank+-44,    yysvec+3,    yyvstop+125,
  701. yycrank+-60,    yysvec+3,    yyvstop+127,
  702. yycrank+-127,    yysvec+3,    yyvstop+129,
  703. yycrank+-54,    yysvec+3,    yyvstop+132,
  704. yycrank+-56,    yysvec+3,    yyvstop+134,
  705. yycrank+-161,    yysvec+3,    yyvstop+136,
  706. yycrank+-68,    yysvec+3,    yyvstop+139,
  707. yycrank+0,    0,        yyvstop+141,
  708. yycrank+-164,    yysvec+20,    yyvstop+143,
  709. yycrank+-54,    yysvec+20,    yyvstop+145,
  710. yycrank+0,    0,        yyvstop+148,
  711. yycrank+0,    0,        yyvstop+151,
  712. yycrank+-179,    yysvec+3,    yyvstop+153,
  713. yycrank+-181,    yysvec+3,    yyvstop+156,
  714. yycrank+-183,    yysvec+3,    yyvstop+159,
  715. yycrank+-185,    yysvec+3,    yyvstop+162,
  716. yycrank+-187,    yysvec+3,    yyvstop+165,
  717. yycrank+-190,    yysvec+3,    yyvstop+168,
  718. yycrank+0,    0,        yyvstop+171,
  719. yycrank+-68,    yysvec+3,    yyvstop+174,
  720. yycrank+-78,    yysvec+3,    yyvstop+176,
  721. yycrank+0,    0,        yyvstop+178,
  722. yycrank+-193,    yysvec+3,    yyvstop+181,
  723. yycrank+-196,    yysvec+3,    yyvstop+184,
  724. yycrank+0,    0,        yyvstop+187,
  725. yycrank+-31,    yysvec+3,    yyvstop+190,
  726. yycrank+-66,    yysvec+20,    yyvstop+192,
  727. yycrank+0,    0,        yyvstop+194,
  728. yycrank+0,    0,        yyvstop+197,
  729. yycrank+0,    0,        yyvstop+200,
  730. yycrank+0,    0,        yyvstop+203,
  731. yycrank+0,    0,        yyvstop+206,
  732. yycrank+0,    0,        yyvstop+209,
  733. yycrank+-209,    yysvec+3,    yyvstop+212,
  734. yycrank+-216,    yysvec+3,    yyvstop+215,
  735. yycrank+0,    0,        yyvstop+218,
  736. yycrank+0,    0,        yyvstop+221,
  737. yycrank+-218,    yysvec+3,    yyvstop+224,
  738. yycrank+0,    0,        yyvstop+227,
  739. yycrank+0,    0,        yyvstop+230,
  740. yycrank+0,    0,        yyvstop+233,
  741. 0,    0,    0};
  742. struct yywork *yytop = yycrank+329;
  743. struct yysvf *yybgin = yysvec+1;
  744. char yymatch[] ={
  745. 00  ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
  746. 01  ,011 ,012 ,01  ,011 ,011 ,01  ,01  ,
  747. 01  ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
  748. 01  ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
  749. 011 ,01  ,'"' ,01  ,01  ,01  ,01  ,01  ,
  750. 01  ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
  751. '0' ,'1' ,'1' ,'1' ,'1' ,'1' ,'1' ,'1' ,
  752. '8' ,'8' ,01  ,01  ,01  ,01  ,01  ,01  ,
  753. 01  ,'A' ,'A' ,'A' ,'A' ,'A' ,'A' ,01  ,
  754. 01  ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
  755. 01  ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
  756. 'X' ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
  757. 01  ,'A' ,'A' ,'A' ,'A' ,'A' ,'A' ,01  ,
  758. 01  ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
  759. 01  ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
  760. 'X' ,01  ,01  ,01  ,01  ,01  ,01  ,01  ,
  761. 0};
  762. char yyextra[] ={
  763. 0,0,1,1,1,1,1,1,
  764. 1,1,1,1,1,1,1,1,
  765. 1,1,1,1,1,1,1,1,
  766. 1,0,0,0,0,0,0,0,
  767. 0};
  768. X/*    ncform    4.1    83/08/11    */
  769.  
  770. int yylineno =1;
  771. # define YYU(x) x
  772. # define NLSTATE yyprevious=YYNEWLINE
  773. char yytext[YYLMAX];
  774. struct yysvf *yylstate [YYLMAX], **yylsp, **yyolsp;
  775. char yysbuf[YYLMAX];
  776. char *yysptr = yysbuf;
  777. int *yyfnd;
  778. extern struct yysvf *yyestate;
  779. int yyprevious = YYNEWLINE;
  780. yylook(){
  781.     register struct yysvf *yystate, **lsp;
  782.     register struct yywork *yyt;
  783.     struct yysvf *yyz;
  784.     int yych;
  785.     struct yywork *yyr;
  786. # ifdef LEXDEBUG
  787.     int debug;
  788. # endif
  789.     char *yylastch;
  790.     /* start off machines */
  791. # ifdef LEXDEBUG
  792.     debug = 0;
  793. # endif
  794.     if (!yymorfg)
  795.         yylastch = yytext;
  796.     else {
  797.         yymorfg=0;
  798.         yylastch = yytext+yyleng;
  799.         }
  800.     for(;;){
  801.         lsp = yylstate;
  802.         yyestate = yystate = yybgin;
  803.         if (yyprevious==YYNEWLINE) yystate++;
  804.         for (;;){
  805. # ifdef LEXDEBUG
  806.             if(debug)fprintf(yyout,"state %d\n",yystate-yysvec-1);
  807. # endif
  808.             yyt = yystate->yystoff;
  809.             if(yyt == yycrank){        /* may not be any transitions */
  810.                 yyz = yystate->yyother;
  811.                 if(yyz == 0)break;
  812.                 if(yyz->yystoff == yycrank)break;
  813.                 }
  814.             *yylastch++ = yych = input();
  815.         tryagain:
  816. # ifdef LEXDEBUG
  817.             if(debug){
  818.                 fprintf(yyout,"char ");
  819.                 allprint(yych);
  820.                 putchar('\n');
  821.                 }
  822. # endif
  823.             yyr = yyt;
  824.             if ( (int)yyt > (int)yycrank){
  825.                 yyt = yyr + yych;
  826.                 if (yyt <= yytop && yyt->verify+yysvec == yystate){
  827.                     if(yyt->advance+yysvec == YYLERR)    /* error transitions */
  828.                         {unput(*--yylastch);break;}
  829.                     *lsp++ = yystate = yyt->advance+yysvec;
  830.                     goto contin;
  831.                     }
  832.                 }
  833. # ifdef YYOPTIM
  834.             else if((int)yyt < (int)yycrank) {        /* r < yycrank */
  835.                 yyt = yyr = yycrank+(yycrank-yyt);
  836. # ifdef LEXDEBUG
  837.                 if(debug)fprintf(yyout,"compressed state\n");
  838. # endif
  839.                 yyt = yyt + yych;
  840.                 if(yyt <= yytop && yyt->verify+yysvec == yystate){
  841.                     if(yyt->advance+yysvec == YYLERR)    /* error transitions */
  842.                         {unput(*--yylastch);break;}
  843.                     *lsp++ = yystate = yyt->advance+yysvec;
  844.                     goto contin;
  845.                     }
  846.                 yyt = yyr + YYU(yymatch[yych]);
  847. # ifdef LEXDEBUG
  848.                 if(debug){
  849.                     fprintf(yyout,"try fall back character ");
  850.                     allprint(YYU(yymatch[yych]));
  851.                     putchar('\n');
  852.                     }
  853. # endif
  854.                 if(yyt <= yytop && yyt->verify+yysvec == yystate){
  855.                     if(yyt->advance+yysvec == YYLERR)    /* error transition */
  856.                         {unput(*--yylastch);break;}
  857.                     *lsp++ = yystate = yyt->advance+yysvec;
  858.                     goto contin;
  859.                     }
  860.                 }
  861.             if ((yystate = yystate->yyother) && (yyt= yystate->yystoff) != yycrank){
  862. # ifdef LEXDEBUG
  863.                 if(debug)fprintf(yyout,"fall back to state %d\n",yystate-yysvec-1);
  864. # endif
  865.                 goto tryagain;
  866.                 }
  867. # endif
  868.             else
  869.                 {unput(*--yylastch);break;}
  870.         contin:
  871. # ifdef LEXDEBUG
  872.             if(debug){
  873.                 fprintf(yyout,"state %d char ",yystate-yysvec-1);
  874.                 allprint(yych);
  875.                 putchar('\n');
  876.                 }
  877. # endif
  878.             ;
  879.             }
  880. # ifdef LEXDEBUG
  881.         if(debug){
  882.             fprintf(yyout,"stopped at %d with ",*(lsp-1)-yysvec-1);
  883.             allprint(yych);
  884.             putchar('\n');
  885.             }
  886. # endif
  887.         while (lsp-- > yylstate){
  888.             *yylastch-- = 0;
  889.             if (*lsp != 0 && (yyfnd= (*lsp)->yystops) && *yyfnd > 0){
  890.                 yyolsp = lsp;
  891.                 if(yyextra[*yyfnd]){        /* must backup */
  892.                     while(yyback((*lsp)->yystops,-*yyfnd) != 1 && lsp > yylstate){
  893.                         lsp--;
  894.                         unput(*yylastch--);
  895.                         }
  896.                     }
  897.                 yyprevious = YYU(*yylastch);
  898.                 yylsp = lsp;
  899.                 yyleng = yylastch-yytext+1;
  900.                 yytext[yyleng] = 0;
  901. # ifdef LEXDEBUG
  902.                 if(debug){
  903.                     fprintf(yyout,"\nmatch ");
  904.                     sprint(yytext);
  905.                     fprintf(yyout," action %d\n",*yyfnd);
  906.                     }
  907. # endif
  908.                 return(*yyfnd++);
  909.                 }
  910.             unput(*yylastch);
  911.             }
  912.         if (yytext[0] == 0  /* && feof(yyin) */)
  913.             {
  914.             yysptr=yysbuf;
  915.             return(0);
  916.             }
  917.         yyprevious = yytext[0] = input();
  918.         if (yyprevious>0)
  919.             output(yyprevious);
  920.         yylastch=yytext;
  921. # ifdef LEXDEBUG
  922.         if(debug)putchar('\n');
  923. # endif
  924.         }
  925.     }
  926. yyback(p, m)
  927.     int *p;
  928. {
  929. if (p==0) return(0);
  930. while (*p)
  931.     {
  932.     if (*p++ == m)
  933.         return(1);
  934.     }
  935. return(0);
  936. }
  937.     /* the following are only used in the lex library */
  938. yyinput(){
  939.     return(input());
  940.     }
  941. yyoutput(c)
  942.   int c; {
  943.     output(c);
  944.     }
  945. yyunput(c)
  946.    int c; {
  947.     unput(c);
  948.     }
  949. //go.sysin dd *
  950. echo 'x - nf.c'
  951. sed 's/^X//' <<'//go.sysin dd *' >nf.c
  952. X/* nf.c -- this program can be run to generate a new environment for the
  953.  * FORTH interpreter forth.c. It takes the dictionary from the standard input.
  954.  * Normally, this dictionary is in the file "forth.dict", so 
  955.  *    nf < forth.dict
  956.  * will do the trick.
  957.  */
  958.  
  959. #include <stdio.h>
  960. #include <ctype.h>
  961. #include "common.h"
  962. #include "forth.lex.h"        /* #defines for lexical analysis */
  963.  
  964. #define isoctal(c)    (c >= '0' && c <= '7')    /* augument ctype.h */
  965.  
  966. #define assert(c,s)    (!(c) ? failassert(s) : 1)
  967. #define chklit()    (!prev_lit ? dictwarn("Qustionable literal") : 1)
  968.  
  969. #define LINK struct linkrec
  970. #define CHAIN struct chainrec
  971.  
  972. struct chainrec {
  973.     char chaintext[32];
  974.     int defloc;                /* CFA or label loc */
  975.     int chaintype;            /* 0=undef'd, 1=absolute, 2=relative */
  976.     CHAIN *nextchain;
  977.     LINK *firstlink;
  978. };
  979.  
  980. struct linkrec {
  981.     int loc;
  982.     LINK *nextlink;
  983. };
  984.  
  985. CHAIN firstchain;
  986.  
  987. #define newchain()    (CHAIN *)(calloc(1,sizeof(CHAIN)))
  988. #define newlink()    (LINK *)(calloc(1,sizeof(LINK)))
  989.  
  990. CHAIN *find();
  991. CHAIN *lastchain();
  992. LINK *lastlink();
  993.  
  994. char *strcat();
  995. char *calloc();
  996.  
  997. int dp = DPBASE;
  998. int latest;
  999.  
  1000. short mem[INITMEM];
  1001.  
  1002. XFILE *outf, *fopen();
  1003.  
  1004. main(argc, argv)
  1005. int argc;
  1006. char *argv[];
  1007. {
  1008. #ifdef DEBUG
  1009.     puts("Opening output file");
  1010. #endif DEBUG
  1011.  
  1012.     strcpy(firstchain.chaintext," ** HEADER **");
  1013.     firstchain.nextchain = NULL;
  1014.     firstchain.firstlink = NULL;
  1015.  
  1016. #ifdef DEBUG
  1017.     puts("call builddict");
  1018. #endif DEBUG
  1019.     builddict();
  1020. #ifdef DEBUG
  1021.     puts("Make FORTH and COLDIP");
  1022. #endif DEBUG
  1023.     mkrest();
  1024. #ifdef DEBUG
  1025.     puts("Call Buildcore");
  1026. #endif DEBUG
  1027.     buildcore();
  1028. #ifdef DEBUG
  1029.     puts("call checkdict");
  1030. #endif DEBUG
  1031.     checkdict();
  1032. #ifdef DEBUG
  1033.     puts("call writedict");
  1034. #endif DEBUG
  1035.     writedict();
  1036.  
  1037.     printf("%s: done.\n", argv[0]);
  1038. }
  1039.  
  1040. buildcore()            /* set up low core */
  1041. {
  1042.     mem[USER_DEFAULTS+0] = INITS0;            /* initial S0 */
  1043.     mem[USER_DEFAULTS+1] = INITR0;            /* initial R0 */
  1044.     mem[USER_DEFAULTS+2] = TIB_START;        /* initial TIB */
  1045.     mem[USER_DEFAULTS+3] = MAXWIDTH;        /* initial WIDTH */
  1046.     mem[USER_DEFAULTS+4] = 0;            /* initial WARNING */
  1047.     mem[USER_DEFAULTS+5] = dp;            /* initial FENCE */
  1048.     mem[USER_DEFAULTS+6] = dp;            /* initial DP */
  1049.     mem[USER_DEFAULTS+7] = instance("FORTH") + 3;    /* initial CONTEXT */
  1050.  
  1051.     mem[SAVEDIP] = 0;                /* not a saved FORTH */
  1052. }
  1053.  
  1054. builddict()            /* read the dictionary */
  1055. {
  1056.     int prev_lit = 0, lit_flag = 0;
  1057.     int temp;
  1058.     char s[256];
  1059.     TOKEN *token;
  1060.  
  1061.     while ((token = yylex()) != NULL) {    /* EOF returned as a null pointer */
  1062. #ifdef DEBUG
  1063.     printf("\ntoken: %s: %d ",token->text, token->type);
  1064. #endif DEBUG
  1065.     switch (token->type) {
  1066.  
  1067.     case PRIM:
  1068. #ifdef DEBUG
  1069.         printf("primitive ");
  1070. #endif DEBUG
  1071.         if ((token = yylex()) == NULL)    /* get the next word */
  1072.         dicterr("No word following PRIM");
  1073.         strcpy (s,token->text);
  1074. #ifdef DEBUG
  1075.         printf(".%s. ",s);
  1076. #endif DEBUG
  1077.         if ((token == yylex()) == NULL)    /* get the value */
  1078.         dicterr("No value following PRIM <word>");
  1079.         mkword(s,mkval(token));
  1080.         break;
  1081.  
  1082.     case CONST:
  1083. #ifdef DEBUG
  1084.         printf("constant ");
  1085. #endif DEBUG
  1086.         if ((token = yylex()) == NULL)    /* get the word */
  1087.         dicterr("No word following CONST");
  1088.         strcpy (s,token->text);        /* s holds word */
  1089. #ifdef DEBUG
  1090.         printf(".%s. ",s);
  1091. #endif DEBUG
  1092.         if (!find("DOCON"))
  1093.         dicterr ("Constant definition before DOCON: %s",s);
  1094.                 /* put the CF of DOCON into this word's CF */
  1095.         mkword(s,(int)mem[instance("DOCON")]);
  1096.         if ((token = yylex()) == NULL)    /* get the value */
  1097.         dicterr("No value following CONST <word>");
  1098.         temp = mkval(token);
  1099.  
  1100.         /* two special-case constants */
  1101.         if (strcmp(s,"FIRST") == 0) temp = INITR0;
  1102.         else if (strcmp(s,"LIMIT") == 0) temp = DPBASE;
  1103.  
  1104.         comma(temp);
  1105.         break;
  1106.  
  1107.     case VAR:
  1108. #ifdef DEBUG
  1109.         printf("variable ");
  1110. #endif DEBUG
  1111.         if ((token = yylex()) == NULL)    /* get the variable name */
  1112.         dicterr("No word following VAR");
  1113.         strcpy (s,token->text);
  1114. #ifdef DEBUG
  1115.         printf(".%s. ",s);
  1116. #endif DEBUG
  1117.         if (!find("DOVAR"))
  1118.         dicterr("Variable declaration before DOVAR: %s",s);
  1119.         mkword (s, (int)mem[instance("DOVAR")]);
  1120.         if ((token = yylex()) == NULL)    /* get the value */
  1121.         dicterr("No value following VAR <word>");
  1122.         comma(mkval(token));
  1123.         break;
  1124.  
  1125.     case USER:
  1126. #ifdef DEBUG
  1127.         printf("uservar ");
  1128. #endif DEBUG
  1129.         if ((token = yylex()) == NULL)    /* get uservar name */
  1130.         dicterr("No name following USER");
  1131.         strcpy (s,token->text);
  1132. #ifdef DEBUG
  1133.         printf(".%s. ",s);
  1134. #endif DEBUG
  1135.         if (!find("DOUSE"))
  1136.         dicterr("User variable declared before DOUSE: %s",s);
  1137.         mkword (s, (int)mem[instance("DOUSE")]);
  1138.         if ((token = yylex()) == NULL)    /* get the value */
  1139.         dicterr("No value following USER <word>");
  1140.         comma(mkval(token));
  1141.         break;
  1142.  
  1143.     case COLON:
  1144. #ifdef DEBUG
  1145.         printf("colon def'n ");
  1146. #endif DEBUG
  1147.         if ((token = yylex()) == NULL)    /* get name of word */
  1148.         dicterr("No word following : in definition");
  1149.         strcpy (s,token->text);
  1150. #ifdef DEBUG
  1151.         printf(".%s.\n",s);
  1152. #endif DEBUG
  1153.         if (!find("DOCOL"))
  1154.         dicterr("Colon definition appears before DOCOL: %s",s);
  1155.  
  1156.         if (token->type == NUL) {    /* special zero-named word */
  1157.         int here = dp;        /* new latest */
  1158. #ifdef DEBUG
  1159.         printf("NULL WORD AT 0x%04x\n");
  1160. #endif DEBUG
  1161.         comma(0xC1);
  1162.         comma(0x80);
  1163.         comma(latest);
  1164.         latest = here;
  1165.         comma((int)mem[instance("DOCOL")]);
  1166.         }
  1167.         else {
  1168.         mkword (s, (int)mem[instance("DOCOL")]);
  1169.         }
  1170.         break;
  1171.  
  1172.     case SEMICOLON:
  1173. #ifdef DEBUG
  1174.         puts("end colon def'n");
  1175. #endif DEBUG
  1176.         comma (instance(";S"));
  1177.         break;
  1178.  
  1179.     case SEMISTAR:
  1180. #ifdef DEBUG
  1181.         printf("end colon w/IMMEDIATE ");
  1182. #endif DEBUG
  1183.         comma (instance (";S"));    /* compile cfA of ;S, not CF */
  1184.         mem[latest] |= IMMEDIATE;    /* make the word immediate */
  1185.         break;
  1186.  
  1187.     case STRING_LIT:
  1188. #ifdef DEBUG
  1189.         printf("string literal ");
  1190. #endif DEBUG
  1191.         strcpy(s,token->text);
  1192.         mkstr(s);        /* mkstr compacts the string in place */
  1193. #ifdef DEBUG
  1194.         printf("string=(%d) \"%s\" ",strlen(s),s);
  1195. #endif DEBUG
  1196.         comma(strlen(s));
  1197.         {
  1198.         char *stemp;
  1199.         stemp = s;
  1200.         while (*stemp) comma(*stemp++);
  1201.         }
  1202.         break;
  1203.     
  1204.     case COMMENT:
  1205. #ifdef DEBUG
  1206.         printf("comment ");
  1207. #endif DEBUG
  1208.         skipcomment();
  1209.         break;
  1210.  
  1211.     case LABEL:
  1212. #ifdef DEBUG
  1213.         printf("label: ");
  1214. #endif DEBUG
  1215.         if ((token = yylex()) == NULL)
  1216.         dicterr("No name following LABEL");
  1217. #ifdef DEBUG
  1218.         printf(".%s. ", token->text);
  1219. #endif DEBUG
  1220.         define(token->text,2);    /* place in sym. table w/o compiling
  1221.                        anything into dictionary; 2 means
  1222.                        defining a label */
  1223.         break;
  1224.  
  1225.     case LIT:
  1226.         lit_flag = 1;        /* and fall through to the rest */
  1227.  
  1228.     default:
  1229.         if (find(token->text) != NULL) {    /* is word defined? */
  1230. #ifdef DEBUG
  1231.         printf("  normal: %s\n",token->text);
  1232. #endif DEBUG
  1233.             comma (instance (token->text));
  1234.         break;
  1235.         }
  1236.  
  1237.         /* else */
  1238.         /* the literal types all call chklit(). This macro checks to
  1239.            if the previous word was "LIT"; if not, it warns */
  1240.         switch(token->type) {
  1241.         case DECIMAL: chklit(); comma(mkdecimal(token->text)); break;
  1242.         case HEX: chklit(); comma(mkhex(token->text)); break;
  1243.         case OCTAL: chklit(); comma(mkoctal(token->text)); break;
  1244.         case C_BS: chklit(); comma('\b'); break;
  1245.         case C_FF: chklit(); comma('\f'); break;
  1246.         case C_NL: chklit(); comma('\n'); break;
  1247.         case C_CR: chklit(); comma('\r'); break;
  1248.         case C_TAB: chklit(); comma('\t'); break;
  1249.         case C_BSLASH: chklit(); comma(0x5c); break;  /* ASCII backslash */
  1250.         case C_LIT: chklit(); comma(*((token->text)+1)); break;
  1251.  
  1252.         default:
  1253. #ifdef DEBUG
  1254.         printf("forward reference");
  1255. #endif DEBUG
  1256.         comma (instance (token->text));        /* create an instance,
  1257.                         to be resolved at definition */
  1258.         }
  1259.     }
  1260. #ifdef DEBUG
  1261.     if (lit_flag) puts("expect a literal");
  1262. #endif DEBUG
  1263.     prev_lit = lit_flag;    /* to be used by chklit() next time */
  1264.     lit_flag = 0;
  1265.     }
  1266. }
  1267.  
  1268. comma(i)            /* put at mem[dp]; increment dp */
  1269. {
  1270.     mem[dp++] = (unsigned short)i;
  1271.     if (dp > INITMEM) dicterr("DICTIONARY OVERFLOW");
  1272. }
  1273.  
  1274. X/*
  1275.  * make a word in the dictionary.  the new word will have name *s, its CF
  1276.  * will contain v. Also, resolve any previously-unresolved references by
  1277.  * calling define()
  1278.  */
  1279.  
  1280. mkword(s, v)
  1281. char *s;
  1282. short v;
  1283. {
  1284.     int here, count = 0;
  1285.     char *olds;
  1286.     olds = s;        /* preserve this for resolving references */
  1287.  
  1288. #ifdef DEBUG
  1289.     printf("%s ",s);
  1290. #endif DEBUG
  1291.  
  1292.     here = dp;        /* hold this value to place length byte */
  1293.  
  1294.     while (*s) {        /* for each character */
  1295.         mem[++dp] = (unsigned short)*s;
  1296.         count++; s++;
  1297.     }
  1298.  
  1299.     if (count >= MAXWIDTH) dicterr("Input word name too long");
  1300.  
  1301.                 /* set MSB on */
  1302.     mem[here] = (short)(count | 0x80);
  1303.  
  1304.     mem[dp++] |= 0x80;    /* set hi bit of last char in name */
  1305.     
  1306.     mem[dp++] = (short)latest;    /* the link field */
  1307.  
  1308.     latest = here;        /* update the link */
  1309.  
  1310.     mem[dp] = v;        /* code field; leave dp = CFA */
  1311.  
  1312.     define(olds,1);        /* place in symbol table. 1 == "not a label" */
  1313.     dp++;            /* now leave dp holding PFA */
  1314.  
  1315.     /* that's all. Now dp points (once again) to the first UNallocated
  1316.            spot in mem, and everybody's happy. */
  1317. }
  1318.  
  1319. mkrest()            /* Write out the word FORTH as a no-op with
  1320.                    DOCOL as CF, ;S as PF, followed by
  1321.                    0xA081, and latest in its PF.
  1322.                    Also, Put the CFA of ABORT at 
  1323.                    mem[COLDIP] */
  1324. {
  1325.     int temp;
  1326.  
  1327.     mem[COLDIP] = dp;    /* the cold-start IP is here, and the word
  1328.                    which will be executed is COLD */
  1329.     if ((mem[dp++] = instance("COLD")) == 0)
  1330.         dicterr("COLD must be defined to take control at startup");
  1331.  
  1332.     mem[ABORTIP] = dp;    /* the abort-start IP is here, and the word
  1333.                    which will be executed is ABORT */
  1334.     if ((mem[dp++] = instance("ABORT")) == 0)
  1335.         dicterr("ABORT must be defined to take control at interrupt");
  1336.  
  1337.     mkword("FORTH",mem[instance("DOCOL")]);
  1338.     comma(instance(";S"));
  1339.     comma(0xA081);    /* magic number for vocabularies */
  1340.     comma(latest);        /* NFA of last word in dictionary: FORTH */
  1341.  
  1342.     mem[LIMIT] = dp + 1024;
  1343.     if (mem[LIMIT] >= INITMEM) mem[LIMIT] = INITMEM-1;
  1344. }
  1345.  
  1346. writedict()            /* write memory to COREFILE and map 
  1347.                       to MAPFILE */
  1348. {
  1349.     FILE   *outfile;
  1350.     int     i, temp, tempb, firstzero, nonzero;
  1351.     char    chars[9], outline[80], tstr[6];
  1352.  
  1353.     outfile = fopen(MAPFILE,"w");
  1354.  
  1355.     for (temp = 0; temp < dp; temp += 8) {
  1356.     nonzero = FALSE;
  1357.     sprintf (outline, "%04x:", temp);
  1358.     for (i = temp; i < temp + 8; i++) {
  1359.         sprintf (tstr, " %04x", (unsigned short) mem[i]);
  1360.         strcat (outline, tstr);
  1361.         tempb = mem[i] & 0x7f;
  1362.         if (tempb < 0x7f && tempb >= ' ')
  1363.         chars[i % 8] = tempb;
  1364.         else
  1365.         chars[i % 8] = '.';
  1366.         nonzero |= mem[i];
  1367.     }
  1368.     if (nonzero) {
  1369.         fprintf (outfile, "%s %s\n", outline, chars);
  1370.         firstzero = TRUE;
  1371.     }
  1372.     else
  1373.         if (firstzero) {
  1374.         fprintf (outfile, "----- ZERO ----\n");
  1375.         firstzero = FALSE;
  1376.         }
  1377.     }
  1378.     fclose (outfile);
  1379.  
  1380.  
  1381.     printf ("Writing %s; DPBASE=%d; dp=%d\n", COREFILE, DPBASE, dp);
  1382.  
  1383.     if ((outf = fopen (COREFILE, "w")) == NULL) {
  1384.     printf ("nf: can't open %s for output.\n", COREFILE);
  1385.     exit (1);
  1386.     }
  1387.  
  1388.     if (fwrite (mem, sizeof (*mem), mem[LIMIT], outf) != mem[LIMIT]) {
  1389.     fprintf (stderr, "Error writing to %s\n", COREFILE);
  1390.     exit (1);
  1391.     }
  1392.  
  1393.     if (fclose (outf) == EOF) {
  1394.     fprintf (stderr, "Error closing %s\n", COREFILE);
  1395.     exit (1);
  1396.     }
  1397. }
  1398.  
  1399. mkval(t)            /* convert t->text to integer based on type */
  1400. TOKEN *t;
  1401. {
  1402.     char *s = t->text;
  1403.     int sign = 1;
  1404.  
  1405.     if (*s == '-') {
  1406.         sign = -1;
  1407.         s++;
  1408.     }
  1409.  
  1410.     switch (t->type) {
  1411.     case DECIMAL:
  1412.         return (sign * mkdecimal(s));
  1413.     case HEX:
  1414.         return (sign * mkhex(s));
  1415.     case OCTAL:
  1416.         return (sign * mkoctal(s));
  1417.     default:
  1418.         dicterr("Bad value following PRIM, CONST, VAR, or USER");
  1419.     }
  1420. }
  1421.  
  1422. mkhex(s)
  1423. char *s;
  1424. {                /*  convert hex ascii to integer */
  1425.     int     temp;
  1426.     temp = 0;
  1427.  
  1428.     s += 2;            /* skip over '0x' */
  1429.     while (isxdigit (*s)) {    /* first non-hex char ends */
  1430.     temp <<= 4;        /* mul by 16 */
  1431.     if (isupper (*s))
  1432.         temp += (*s - 'A') + 10;
  1433.     else
  1434.         if (islower (*s))
  1435.         temp += (*s - 'a') + 10;
  1436.         else
  1437.         temp += (*s - '0');
  1438.     s++;
  1439.     }
  1440.     return temp;
  1441. }
  1442.  
  1443. mkoctal(s)
  1444. char *s;
  1445. {                /*  convert Octal ascii to integer */
  1446.     int     temp;
  1447.     temp = 0;
  1448.  
  1449.     while (isoctal (*s)) {    /* first non-octal char ends */
  1450.     temp = temp * 8 + (*s - '0');
  1451.     s++;
  1452.     }
  1453.     return temp;
  1454. }
  1455.  
  1456. mkdecimal(s)            /* convert ascii to decimal */
  1457. char *s;
  1458. {
  1459.     return (atoi(s));    /* alias */
  1460. }
  1461.  
  1462. dicterr(s,p1)
  1463. char *s;
  1464. int p1;        /* might be char * -- printf uses it */
  1465. {
  1466.     fprintf(stderr,s,p1);
  1467.     fprintf(stderr,"\nLast word defined was ");
  1468.     printword(latest);
  1469. X/*    fprintf(stderr, "; last word read was \"%s\"", token->text); */
  1470.     fprintf(stderr,"\n");
  1471.     exit(1);
  1472. }
  1473.  
  1474. dictwarn(s)        /* almost like dicterr, but don't exit */
  1475. char *s;
  1476. {
  1477.     fprintf(stderr,"\nWarning: %s\nLast word read was ",s);
  1478.     printword(latest);
  1479.     putc('\n',stderr);
  1480. }
  1481.     
  1482. printword(n)
  1483. int n;
  1484. {
  1485.     int count, tmp;
  1486.     count = mem[n] & 0x1f;
  1487.     for (n++;count;count--,n++) {
  1488.     tmp = mem[n] & ~0x80;        /* mask eighth bit off */
  1489.     if (tmp >= ' ' && tmp <= '~') putc(tmp, stderr);
  1490.     }
  1491. }
  1492.  
  1493. skipcomment()
  1494. {
  1495.     while(getchar() != ')');
  1496. }
  1497.  
  1498. mkstr(s)            /* modifies a string in place with escapes
  1499.                    compacted. Strips leading & trailing \" */
  1500. char *s;
  1501. {
  1502.     char *source;
  1503.     char *dest;
  1504.  
  1505.     source = dest = s;
  1506.     source++;            /* skip leading quote */
  1507.     while (*source != '"') {    /* string ends with unescaped \" */
  1508.     if (*source == '\\') {    /* literal next */
  1509.         source++;
  1510.     }
  1511.     *dest++ = *source++;
  1512.     }
  1513.     *dest = '\0';
  1514. }
  1515.  
  1516. failassert(s)
  1517. char *s;
  1518. {
  1519.     puts(s);
  1520.     exit(1);
  1521. }
  1522.  
  1523. checkdict()            /* check for unresolved references */
  1524. {
  1525.     CHAIN *ch = &firstchain;
  1526.  
  1527. #ifdef DEBUG
  1528.     puts("\nCheck for unresolved references");
  1529. #endif DEBUG
  1530.     while (ch != NULL) {
  1531. #ifdef DEBUG
  1532.     printf("ch->chaintext = .%s. - ",ch->chaintext);
  1533. #endif DEBUG
  1534.     if ((ch->firstlink) != NULL) {
  1535.         fprintf(stderr,"Unresolved forward reference: %s\n",ch->chaintext);
  1536. #ifdef DEBUG
  1537.         puts("still outstanding");
  1538. #endif DEBUG
  1539.     }
  1540. #ifdef DEBUG
  1541.     else puts("clean.");
  1542. #endif DEBUG
  1543.     ch = ch->nextchain;
  1544.     }
  1545. }
  1546.  
  1547.     
  1548. X/********* structure-handling functions find(s), define(s,t), instance(s) **/
  1549.  
  1550. CHAIN *find(s)        /* returns a pointer to the chain named s */
  1551. char *s;
  1552. {
  1553.     CHAIN *ch;
  1554.     ch = &firstchain;
  1555.     while (ch != NULL) {
  1556.         if (strcmp (s, ch->chaintext) == 0) return ch;
  1557.         else ch = ch->nextchain;
  1558.     }
  1559.     return NULL;    /* not found */
  1560. }
  1561.  
  1562. X/* define must create a symbol table entry if none exists, with type t.
  1563.    if one does exist, it must have type 0 -- it is an error to redefine
  1564.    something at this stage. Change to type t, and fill in the outstanding
  1565.    instances, with the current dp if type=1, or relative if type=2. */
  1566.  
  1567. define(s,t)        /* define s at current dp */
  1568. char *s;
  1569. int t;
  1570. {
  1571.     CHAIN *ch;
  1572.     LINK *ln, *templn;
  1573.  
  1574. #ifdef DEBUG
  1575.     printf("define(%s,%d)\n",s,t);
  1576. #endif DEBUG
  1577.  
  1578.     if (t < 1 || t > 2)    /* range check */
  1579.         dicterr("Program error: type in define() not 1 or 2.");
  1580.  
  1581.     if ((ch = find(s)) != NULL) {        /* defined or instanced? */
  1582.         if (ch -> chaintype != 0)    /* already defined! */
  1583.             dicterr("Word already defined: %s",s);
  1584.         else {
  1585. #ifdef DEBUG
  1586.             printf("there are forward refs: ");
  1587. #endif DEBUG
  1588.             ch->chaintype = t;
  1589.             ch->defloc = dp;
  1590.         }
  1591.     }
  1592.     else {                /* must create a (blank) chain */
  1593. #ifdef DEBUG
  1594.         puts("no forward refs");
  1595. #endif DEBUG
  1596.         /* create a new chain, link it in, leave ch pointing to it */
  1597.         ch = ((lastchain() -> nextchain) = newchain());
  1598.         strcpy(ch->chaintext, s);
  1599.         ch->chaintype = t;
  1600.         ch->defloc = dp;    /* fill in for future references */
  1601.     }
  1602.  
  1603.     /* now ch points to the chain (possibly) containing forward refs */
  1604.     if ((ln = ch->firstlink) == NULL) return;    /* no links! */
  1605.  
  1606.     while (ln != NULL) {
  1607. #ifdef DEBUG
  1608.         printf("    Forward ref at 0x%x\n",ln->loc);
  1609. #endif DEBUG
  1610.         switch (ch->chaintype) {
  1611.         case 1: mem[ln->loc] = (short)dp;    /* absolute */
  1612.             break;
  1613.         case 2: mem[ln->loc] = (short)(dp - ln->loc);    /* relative */
  1614.             break;
  1615.         default: dicterr ("Bad type field in define()");
  1616.         }
  1617.  
  1618.         /* now skip to the next link & free this one */
  1619.         templn = ln;
  1620.         ln = ln->nextlink;
  1621.         free(templn);
  1622.     }
  1623.     ch->firstlink = NULL;    /* clean up that last pointer */
  1624. }
  1625.  
  1626. X/*
  1627.    instance must return a value to be compiled into the dictionary at
  1628.    dp, consistent with the symbol s: if s is undefined, it returns 0,
  1629.    and adds this dp to the chain for s (creating that chain if necessary).
  1630.    If s IS defined, it returns <s> (absolute) or (s-dp) (relative), 
  1631.    where <s> was the dp when s was defined.
  1632. */
  1633.  
  1634. instance(s)
  1635. char *s;
  1636. {
  1637.     CHAIN *ch;
  1638.     LINK *ln;
  1639.  
  1640. #ifdef DEBUG
  1641.     printf("instance(%s):\n",s);
  1642. #endif DEBUG
  1643.  
  1644.     if ((ch = find(s)) == NULL) {    /* not defined yet at all */
  1645. #ifdef DEBUG
  1646.         puts("entirely new -- create a new chain");
  1647. #endif DEBUG
  1648.         /* create a new chain, link it in, leave ch pointing to it */
  1649.         ch = ((lastchain() -> nextchain) = newchain());
  1650.  
  1651.         strcpy(ch->chaintext, s);
  1652.         ln = newlink();        /* make its link */
  1653.         ch->firstlink = ln;
  1654.         ln->loc = dp;        /* store this location there */
  1655.         return 0;        /* all done */
  1656.     }
  1657.     else {
  1658.         switch(ch->chaintype) {
  1659.         case 0:            /* not defined yet */
  1660. #ifdef DEBUG
  1661.             puts("still undefined -- add a link");
  1662. #endif DEBUG
  1663.             /* create a new link, point the last link to it, and
  1664.                fill in the loc field with the current dp */
  1665.             (lastlink(ch)->nextlink = newlink()) -> loc = dp;
  1666.             return 0;
  1667.         case 1:            /* absolute */
  1668. #ifdef DEBUG
  1669.             puts("defined absolute.");
  1670. #endif DEBUG
  1671.             return ch->defloc;
  1672.         case 2:            /* relative */
  1673. #ifdef DEBUG
  1674.             puts("defined relative.");
  1675. #endif DEBUG
  1676.             return ch->defloc - dp;
  1677.         default:
  1678.             dicterr("Program error: bad type for chain");
  1679.         }
  1680.     }
  1681. }
  1682.  
  1683. CHAIN *lastchain()    /* starting from firstchain, find the last chain */
  1684. {
  1685.     CHAIN *ch = &firstchain;
  1686.     while (ch->nextchain != NULL) ch = ch->nextchain;
  1687.     return ch;
  1688. }
  1689.  
  1690. LINK *lastlink(ch)    /* return the last link in the chain */
  1691. CHAIN *ch;        /* CHAIN MUST HAVE AT LEAST ONE LINK */
  1692. {
  1693.     LINK *ln = ch->firstlink;
  1694.  
  1695.     while (ln->nextlink != NULL) ln = ln->nextlink;
  1696.     return ln;
  1697. }
  1698.  
  1699. yywrap()    /* called by yylex(). returning 1 means "all finished" */
  1700. {
  1701.     return 1;
  1702. }
  1703. //go.sysin dd *
  1704. echo 'x - prims.c'
  1705. sed 's/^X//' <<'//go.sysin dd *' >prims.c
  1706. X/*
  1707.  * prims.c -- code for the primitive functions declared in forth.dict
  1708.  */
  1709.  
  1710. #include <stdio.h>
  1711. #include <ctype.h>    /* used in "digit" */
  1712. #include "common.h"
  1713. #include "forth.h"
  1714. #include "prims.h"    /* macro primitives */
  1715.  
  1716. X/*
  1717.              ----------------------------------------------------
  1718.                             PRIMITIVE DEFINITIONS
  1719.              ----------------------------------------------------
  1720. */
  1721.  
  1722. zbranch()            /* add an offset (branch) if tos == 0 */
  1723. {
  1724.     if(pop() == 0) 
  1725.         ip += mem[ip];
  1726.     else
  1727.         ip++;        /* else skip over the offset */
  1728. }
  1729.  
  1730. ploop()                /* (loop) -- loop control */
  1731. {
  1732.     short index, limit;
  1733.     index = rpop()+1;
  1734.     if(index < (limit = rpop())) {   /* if the new index < the limit */
  1735.         rpush(limit);    /* restore the limit */
  1736.         rpush(index);    /* and the index (incremented) */
  1737.         branch();    /* and go back to the top of the loop */
  1738.     }
  1739.     else ip++;             /* skip over the offset, and exit, having
  1740.                    popped the limit & index */
  1741. }
  1742.  
  1743. pploop()            /* (+loop) -- almost the same */
  1744. {
  1745.     short index, limit;
  1746.     index = rpop()+pop();        /* get index & add increment */
  1747.     if(index < (limit = rpop())) {    /* if new index < limit */
  1748.         rpush (limit);        /* restore the limit */
  1749.         rpush (index);        /* restore the new index */
  1750.         branch();        /* and branch back to the top */
  1751.     }
  1752.     else {
  1753.         ip++;        /* skip over branch offset */
  1754.     }
  1755. }
  1756.  
  1757. pdo()            /* (do): limit init -- [pushed to rstack] */
  1758. {
  1759.     swap();
  1760.     rpush (pop());
  1761.     rpush (pop());
  1762. }
  1763.  
  1764. i()            /* copy top of return stack to cstack */
  1765. {
  1766.     int tmp;
  1767.     tmp = rpop();
  1768.     rpush(tmp);
  1769.     push(tmp);
  1770. }
  1771.  
  1772. r()        /* this must be a primitive as well as I because otherwise it
  1773.            always returns its own address */
  1774. {
  1775.     i();
  1776. }
  1777.  
  1778. digit()            /* digit: c -- FALSE or [v TRUE] */
  1779. {
  1780.     short c, base;        /* C is ASCII char, convert to val. BASE is
  1781.                    used for range checking */
  1782.     base = pop();
  1783.     c = pop();
  1784.     if (!isascii(c)) {
  1785.     push (FALSE);
  1786.     return;
  1787.     }
  1788.                  /* lc -> UC if necessary */
  1789.     if (islower(c)) c = toupper(c);
  1790.  
  1791.     if (c < '0' || (c > '9' && c < 'A') || c > 'Z') {
  1792.     push(FALSE);        /* not a digit */
  1793.     }
  1794.     else {            /* it is numeric or UC Alpha */
  1795.     if (c >= 'A') c -= 7;    /* put A-Z right after 0-9 */
  1796.  
  1797.     c -= '0';        /* now c is 0..35 */
  1798.  
  1799.     if (c >= base) {
  1800.         push (FALSE);    /* FALSE - not a digit */
  1801.     }
  1802.     else {            /* OKAY: push value, then TRUE */
  1803.         push (c);
  1804.         push (TRUE);
  1805.     }
  1806.     }
  1807. }
  1808.  
  1809. pfind()        /* WORD TOP -- xx FLAG, where TOP is NFA to start at;
  1810.            WORD is the word to find; xx is PFA of found word;
  1811.            yy is actual length of the word found;
  1812.            FLAG is 1 if found. If not found, 0 alone is stacked. */
  1813. {
  1814.     unsigned short  worka, workb, workc, current, word, match;
  1815.  
  1816.     current = pop ();
  1817.     word = pop ();
  1818.     while (current) {        /* stop at end of dictionary */
  1819.     if (!((mem[current] ^ mem[word]) & 0x3f)) {
  1820.                 /* match lengths & smudge */
  1821.         worka = current + 1;/* point to the first letter */
  1822.         workb = word + 1;
  1823.         workc = mem[word];    /* workc gets count */
  1824.         match = TRUE;    /* initally true, for looping */
  1825.         while (workc-- && match)
  1826.         match = ((mem[worka++] & 0x7f) == (mem[workb++] & 0x7f));
  1827.         if (match) {    /* exited with match TRUE -- FOUND IT */
  1828.         push (worka + 2);        /* worka=LFA; push PFA */
  1829.         push (mem[current]);        /* push length byte */
  1830.         push (TRUE);            /* and TRUE flag */
  1831.         return;
  1832.         }
  1833.     }
  1834.     /* failed to match */
  1835.     /* follow link field to next word */
  1836.     current = mem[current + (mem[current] & 0x1f) + 1];
  1837.     }
  1838.     push (FALSE);        /* current = 0; end of dict; not found */
  1839. }
  1840.  
  1841. enclose()
  1842. {
  1843.     int delim, current, offset;
  1844.  
  1845.     delim = pop();
  1846.     current = pop();
  1847.     push (current);
  1848.  
  1849.     offset = -1;
  1850.     current--;
  1851. encl1:
  1852.     current++;
  1853.     offset++;
  1854.     if (mem[current] == delim) goto encl1;
  1855.  
  1856.     push(offset);
  1857.     if (mem[current] == NULL) {
  1858.         offset++;
  1859.         push (offset);
  1860.         offset--;
  1861.         push (offset);
  1862.         return;
  1863.     }
  1864.  
  1865. encl2:
  1866.     current++;
  1867.     offset++;
  1868.     if (mem[current] == delim) goto encl4;
  1869.     if (mem[current] != NULL) goto encl2;
  1870.  
  1871.     /* mem[current] is null.. */
  1872.     push (offset);
  1873.     push (offset);
  1874.     return;
  1875.  
  1876. encl4:    /* found the trailing delimiter */
  1877.     push (offset);
  1878.     offset++;
  1879.     push (offset);
  1880.     return;
  1881. }
  1882.  
  1883. cmove()            /* cmove: source dest number -- */
  1884. {
  1885.     short source, dest, number, i;
  1886.     number = pop();
  1887.     dest = pop();
  1888.     source = pop();
  1889.     for ( ; number ; number-- ) mem[dest++] = mem[source++];
  1890. }
  1891.  
  1892. fill()            /* fill: c dest number -- */
  1893. {
  1894.     short dest, number, c;
  1895.     number = pop();
  1896.     dest = pop();
  1897.     c = pop();
  1898.  
  1899.     mem[dest] = c;        /* always at least one */
  1900.     if (number == 1) return;    /* return if only one */
  1901.  
  1902.     push (dest);        /* else push dest as source of cmove */
  1903.     push (dest + 1);        /* dest+1 as dest of cmove */
  1904.     push (number - 1);        /* number-1 as number of cmove */
  1905.     cmove();
  1906. }
  1907.  
  1908. ustar()                /* u*: a b -- a*b.hi a*b.lo */
  1909. {
  1910.     unsigned short a, b;
  1911.     unsigned long c;
  1912.     a = (unsigned short)pop();
  1913.     b = (unsigned short)pop();
  1914.     c = a * b;
  1915.  
  1916.     /* (short) -1 is probably FFFF, which is just what we want */
  1917.     push ((unsigned short)(c & (short) -1));          /* low word of product */
  1918.                              /* high word of product */
  1919.     push ((short)((c >> (8*sizeof(short))) & (short) -1));
  1920. }
  1921.  
  1922. uslash()            /* u/: NUM.LO NUM.HI DENOM -- REM QUOT */
  1923. {
  1924.     unsigned short numhi, numlo, denom;
  1925.     unsigned short quot, remainder;    /* the longs below are to be sure the
  1926.                        intermediate computation is done
  1927.                        long; the results are short */
  1928.     denom = pop();
  1929.     numhi = pop();
  1930.     numlo = pop();
  1931.     quot = ((((unsigned long)numhi) << (8*sizeof(short))) 
  1932.                 + (unsigned long)numlo) 
  1933.                     / (unsigned long)denom;
  1934.  
  1935.     remainder = ((((unsigned long)numhi) << (8*sizeof(short))) 
  1936.                 + (unsigned long)numlo) 
  1937.                     % (unsigned long)denom;
  1938.  
  1939.     push (remainder);
  1940.     push (quot);
  1941. }
  1942.  
  1943. swap()                /* swap: a b -- b a */
  1944. {
  1945.     short a, b;
  1946.     b = pop();
  1947.     a = pop();
  1948.     push (b);
  1949.     push (a);
  1950. }
  1951.  
  1952. rot()                /* rotate */
  1953. {
  1954.     short a, b, c;
  1955.     a = pop ();
  1956.     b = pop ();
  1957.     c = pop ();
  1958.     push (b);
  1959.     push (a);
  1960.     push (c);
  1961. }
  1962.  
  1963. tfetch()            /* 2@: addr -- mem[addr+1] mem[addr] */
  1964. {
  1965.     unsigned short addr;
  1966.     addr = pop();
  1967.     push (mem[addr + 1]);
  1968.     push (mem[addr]);
  1969. }
  1970.  
  1971. store()            /* !: val addr -- <set mem[addr] = val> */
  1972. {
  1973.     unsigned short tmp;
  1974.     tmp = pop();
  1975.     mem[tmp] = pop();
  1976. }
  1977.  
  1978. cstore()            /* C!: val addr --  */
  1979. {
  1980.     store();
  1981. }
  1982.  
  1983. tstore()            /* 2!: val1 val2 addr -- 
  1984.                    mem[addr] = val2,
  1985.                    mem[addr+1] = val1 */
  1986. {
  1987.     unsigned short tmp;
  1988.     tmp = pop();
  1989.     mem[tmp] = pop();
  1990.     mem[tmp+1] = pop();
  1991. }
  1992.  
  1993. leave()            /* set the index = the limit of a DO */
  1994. {
  1995.     int tmp;
  1996.     rpop();            /* discard old index */
  1997.     tmp = rpop();        /* and push the limit as */
  1998.     rpush(tmp);            /* both the limit */
  1999.     rpush(tmp);            /* and the index */
  2000. }
  2001.  
  2002. dplus()                /* D+: double-add */
  2003. {
  2004.     short ahi, alo, bhi, blo;
  2005.     long a, b;
  2006.     bhi = pop();
  2007.     blo = pop();
  2008.     ahi = pop();
  2009.     alo = pop();
  2010.     a = ((long)ahi << (8*sizeof(short))) + (long)alo;
  2011.     b = ((long)bhi << (8*sizeof(short))) + (long)blo;
  2012.     a = a + b;
  2013.     push ((unsigned short)(a & (short) -1));    /* sum lo */
  2014.     push ((short)(a >> (8*sizeof(short))));    /* sum hi */
  2015. }
  2016.  
  2017. subtract()            /* -: a b -- (a-b) */
  2018. {
  2019.     int tmp;
  2020.     tmp = pop();
  2021.     push (pop() - tmp);
  2022. }
  2023.  
  2024. dsubtract()            /* D-: double-subtract */
  2025. {
  2026.     short ahi, alo, bhi, blo;
  2027.     long a, b;
  2028.     bhi = pop();
  2029.     blo = pop();
  2030.     ahi = pop();
  2031.     alo = pop();
  2032.     a = ((long)ahi << (8*sizeof(short))) + (long)alo;
  2033.     b = ((long)bhi << (8*sizeof(short))) + (long)blo;
  2034.     a = a - b;
  2035.     push ((unsigned short)(a & (short) -1));    /* diff lo */
  2036.     push ((short)(a >> (8*sizeof(short))));    /* diff hi */
  2037. }
  2038.  
  2039. dminus()                /* DMINUS: negate a double number */
  2040. {
  2041.     unsigned short ahi, alo;
  2042.     long a;
  2043.     ahi = pop();
  2044.     alo = pop();
  2045.     a = -(((long)ahi << (8*sizeof(short))) + (long)alo);
  2046.     push ((unsigned short)(a & (short) -1));        /* -a lo */
  2047.     push ((unsigned short)(a >> (8*sizeof(short))));     /* -a hi */
  2048. }
  2049.  
  2050. over()                /* over: a b -- a b a */
  2051. {
  2052.     short a, b;
  2053.     b = pop();
  2054.     a = pop();
  2055.     push (a);
  2056.     push (b);
  2057.     push (a);
  2058. }
  2059.  
  2060. dup()                /* dup: a -- a a */
  2061. {
  2062.     short a;
  2063.     a = pop();
  2064.     push (a);
  2065.     push (a);
  2066. }
  2067.  
  2068. tdup()            /* 2dup: a b -- a b a b */
  2069. {
  2070.     short a, b;
  2071.     b = pop();
  2072.     a = pop();
  2073.     push (a);
  2074.     push (b);
  2075.     push (a);
  2076.     push (b);
  2077. }
  2078.  
  2079. pstore()            /* +!: val addr -- <add val to mem[addr]> */
  2080. {
  2081.     short addr, val;
  2082.     addr = pop();
  2083.     val = pop();
  2084.     mem[addr] += val;
  2085. }
  2086.  
  2087. toggle()            /* toggle: addr bits -- <xor mem[addr]
  2088.                    with bits, store in mem[addr]> */
  2089. {
  2090.     short bits, addr;
  2091.     bits = pop();
  2092.     addr = pop();
  2093.     mem[addr] ^= bits;
  2094. }
  2095.  
  2096. less()
  2097. {
  2098.     int tmp;
  2099.     tmp = pop();
  2100.     push (pop() < tmp);
  2101. }
  2102.  
  2103. pcold()
  2104. {
  2105.     csp = INITS0;        /* initialize values */
  2106.     rsp = INITR0;
  2107.     /* copy USER_DEFAULTS area into UP area */
  2108.     push (USER_DEFAULTS);    /* source */
  2109.     push (UP);            /* dest */
  2110.     push (DEFS_SIZE);        /* count */
  2111.     cmove();            /* move! */
  2112.                 /* returns, executes ABORT */
  2113. }
  2114.  
  2115. prslw()
  2116. {
  2117.     int buffer, flag, addr, i, temp, unwrittenflag;
  2118.     long fpos, ftell();
  2119.     char buf[1024];        /* holds data for xfer */
  2120.  
  2121.     flag = pop();
  2122.     buffer = pop();
  2123.     addr = pop();
  2124.     fpos = (long) (buffer * 1024);
  2125.  
  2126.                     /* extend if necessary */
  2127.     if (fpos >= bfilesize) {
  2128.         if (flag == 0) {         /* write */
  2129.         printf("Extending block file to %D bytes\n", fpos+1024);
  2130.         /* the "2" below is the fseek magic number for "beyond end" */
  2131.         fseek(blockfile, (fpos+1024) - bfilesize, 2);
  2132.         bfilesize = ftell(blockfile);
  2133.         }
  2134.         else {            /* reading unwritten data */
  2135.         unwrittenflag = TRUE;    /* will read all zeroes */
  2136.         }
  2137.     }
  2138.     else {
  2139.         /* note that "0" below is fseek magic number for "relative to
  2140.            beginning-of-file" */
  2141.         fseek(blockfile, fpos, 0);    /* seek to destination */
  2142.     }
  2143.  
  2144.     if (flag) {        /* read */
  2145.         if (unwrittenflag) {    /* not written yet */
  2146.         for (i=0; i<1024; i++) mem[addr++] = 0;    /* "read" nulls */
  2147.         }
  2148.         else {            /* does exist */
  2149.         if ((temp = fread (buf, sizeof(char), 1024, blockfile)) 
  2150.                                 != 1024) {
  2151.             fprintf (stderr,
  2152.                 "File read error %d reading buffer %d\n",
  2153.                     temp, buffer);
  2154.             errexit();
  2155.         }
  2156.         for (i=0; i<1024; i++) mem[addr++] = buf[i];
  2157.         }
  2158.     }
  2159.     else {    /* write */
  2160.         for (i=0; i<1024; i++) buf[i] = mem[addr++];
  2161.         if ((temp = fwrite (buf, sizeof(char), 1024, blockfile))
  2162.                                  != 1024) {
  2163.                 fprintf(stderr,
  2164.                 "File write error %d writing buffer %d\n",
  2165.                     temp, buffer);
  2166.                 errexit();
  2167.         }
  2168.     }
  2169. }
  2170.  
  2171. psave()
  2172. {
  2173.     FILE *fp;
  2174.  
  2175.     printf("\nSaving...");
  2176.     fflush(stdout);
  2177.     mem[SAVEDIP] = ip;    /* save state */
  2178.     mem[SAVEDSP] = csp;
  2179.     mem[SAVEDRP] = rsp;
  2180.  
  2181.     if ((fp = fopen(sfilename,"w")) == NULL)  /* open for writing only */
  2182.         errexit("Can't open core file %s for writing\n", sfilename);
  2183.     if (fwrite(mem, sizeof(*mem), mem[0], fp) != mem[0])
  2184.         errexit("Write error on %s\n",sfilename);
  2185.     if (fclose(fp) == EOF)
  2186.         errexit("Close error on %s\n",sfilename);
  2187.     puts("Saved. Exit FORTH.");
  2188.     exit(0);
  2189. }
  2190. //go.sysin dd *
  2191. echo 'x - prims.h'
  2192. sed 's/^X//' <<'//go.sysin dd *' >prims.h
  2193. X/* prims.h: This file defines inline primitives, which are called as functions
  2194.    from the big SWITCH in forth.c */
  2195.  
  2196.                  /* push mem[ip] to cstack */
  2197. #define lit() { push (mem[ip++]); }
  2198.             /* add an offset (this word) to ip */
  2199. #define branch() { ip += mem[ip]; }
  2200.             /* return a key from input */
  2201. #define key() { push(pkey()); }
  2202.         /* return TRUE if break key pressed */
  2203. #define qterminal() { pqterm(); }
  2204.                 /* and: a b -- a & b */
  2205. #define and() { push (pop() & pop()); }
  2206.                 /* or: a b -- a | b */
  2207. #define or() { push (pop() | pop()); }
  2208.                 /* xor: a b -- a ^ b */
  2209. #define xor() { push (pop() ^ pop()); }
  2210.             /* sp@: push the stack pointer */
  2211. #define spfetch() { push (csp); }
  2212.             /* sp!: load initial value into SP */
  2213. #define spstore() { csp = mem[S0]; }
  2214.             /* rp@: fetch the return stack pointer */
  2215. #define rpfetch() { push (rsp); }
  2216.             /* rp!: load initial value into RP */
  2217. #define rpstore() { rsp = mem[R0]; }
  2218.             /* ;S: ends a colon definition. */
  2219. #define semis() { ip = rpop(); }
  2220.             /* @: addr -- mem[addr] */
  2221. #define fetch() { push (mem[pop()]); }
  2222.             /* C@: addr -- mem[addr] */
  2223. #define cfetch() { push (mem[pop()] & 0xff); }
  2224.             /* push to return stack */
  2225. #define tor() { rpush(pop()); }
  2226.             /* pop from return stack */
  2227. #define fromr() { push (rpop()); }
  2228.             /* 0=: a -- (a == 0) */
  2229. #define zeq() { push ( pop() == 0 ); }
  2230.             /* 0<: a -- (a < 0) */
  2231. #define zless() { push ( pop() < 0 ); }
  2232.             /* +: a b -- (a+b) */
  2233. #define plus() { push (pop () + pop ()); }
  2234.             /* MINUS: negate a number */
  2235. #define minus() { push (-pop()); }
  2236.                 /* drop: a -- */
  2237. #define drop() { pop(); }
  2238.             /* DOCOL: push ip & start a thread */
  2239. #define docol() { rpush(ip); ip = w+1; }
  2240.             /* do a constant: push the value at mem[w+1] */
  2241. #define docon() { push (mem[w+1]); }
  2242.             /* do a variable: push (w+1) (the PFA) to the stack */
  2243. #define dovar() { push (w+1); }
  2244.         /* execute a user variable: add UP to the offset found in PF */
  2245. #define douse() { push (mem[w+1] + ORIGIN); }
  2246.  
  2247. #define allot() { Callot (pop()); }
  2248.                 /* comparison tests */
  2249. #define equal() { push(pop() == pop()); }
  2250.                 /* not equal */
  2251. #define noteq() { push (pop() != pop()); }
  2252.                 /* DODOES -- not supported */
  2253. #define dodoes() { errexit("DOES> is not supported."); }
  2254.                 /* DOVOC -- not supported */
  2255. #define dovoc() { errexit("VOCABULARIES are not supported."); }
  2256.                 /* (BYE) -- exit with error code */
  2257. #define pbye() { exit(0); }
  2258.                 /* TRON -- trace at pop() depth */
  2259. #define tron() { trace = TRUE; tracedepth = pop(); }
  2260.                 /* TROFF -- stop tracing */
  2261. #define troff() { trace = 0; }
  2262. //go.sysin dd *
  2263.