C Forth (Part 3 of 3)
sources-request at genrad.UUCP
sources-request at genrad.UUCP
Sat May 25 00:13:06 AEST 1985
This is posting three of three of a portable FORTH interpreter, written
entirely in C. It has been successfully ported to a VAX 11/60 running
BSD 2.9, to EUNICE version 3 (I think), and the original machine, a VAX
11/780 running BSD 4.2. When I mentioned in net.lang.forth (and elsewhere)
that I was writing this portable FORTH, several people asked that I post
the results of my labors. Well, here they are.
-- Allan Pratt
(after May 7:) APRATT.PA at XEROX.ARPA
[moderator's note: I have had no luck at all getting through
to this address. There was a missing file in the original
distribution: "forth.lex.h" which I have reconstructed
(hopefully correctly). - John P. Nelson]
------------- cut here ----------------
: Run this shell script with "sh" not "csh"
PATH=:/bin:/usr/bin:/usr/ucb
export PATH
echo 'x - l2b.c'
sed 's/^X//' <<'//go.sysin dd *' >l2b.c
X/* usage: line2block < linefile > blockfile
* takes a file (like one generated by block2line) of the form:
* <header line>
* < 16 screen lines >
* ...
* and produces a block file with exactly 64 characters on each line, having
* removed the header lines. This file is suitable for use with FORTH as a
* block file.
*/
#include <stdio.h>
main()
{
int i;
char buf[65];
char *spaces = /* 64 spaces, below */
" ";
/* 64 spaces, above */
while (1) {
gets(buf); /* header line */
for (i=0; i<16; i++) {
if (gets(buf) == NULL) exit(0);
printf("%s%s",buf,spaces+strlen(buf));
}
}
}
//go.sysin dd *
echo 'x - lex.yy.c'
sed 's/^X//' <<'//go.sysin dd *' >lex.yy.c
# include "stdio.h"
# define U(x) x
# define NLSTATE yyprevious=YYNEWLINE
# define BEGIN yybgin = yysvec + 1 +
# define INITIAL 0
# define YYLERR yysvec
# define YYSTATE (yyestate-yysvec-1)
# define YYOPTIM 1
# define YYLMAX 200
# define output(c) putc(c,yyout)
# define input() (((yytchar=yysptr>yysbuf?U(*--yysptr):getc(yyin))==10?(yylineno++,yytchar):yytchar)==EOF?0:yytchar)
# define unput(c) {yytchar= (c);if(yytchar=='\n')yylineno--;*yysptr++=yytchar;}
# define yymore() (yymorfg=1)
# define ECHO fprintf(yyout, "%s",yytext)
# define REJECT { nstr = yyreject(); goto yyfussy;}
int yyleng; extern char yytext[];
int yymorfg;
extern char *yysptr, yysbuf[];
int yytchar;
XFILE *yyin ={stdin}, *yyout ={stdout};
extern int yylineno;
struct yysvf {
struct yywork *yystoff;
struct yysvf *yyother;
int *yystops;};
struct yysvf *yyestate;
extern struct yysvf yysvec[], *yybgin;
X/* LEX input for FORTH input file scanner */
X/*
Specifications are as follows:
This file must be run through "sed" to change
yylex () {
to
TOKEN *yylex () {
where the sed script is
sed "s/yylex () {/TOKEN *yylex () {/" lex.yy.c
Note that spaces have been included above so these lines won't be
mangled by sed; in actuality, the two blanks surrounding () are
removed.
The function "yylex()" always returns a pointer to a structure:
struct tokenrec {
int type;
char *text;
}
#define TOKEN struct tokenrec
where the type is a hint as to the word's type:
DECIMAL for decimal literal d+
OCTAL for octal literal 0d*
HEX for hex literal 0xd+ or 0Xd+
C_BS for a literal Backspace '\b'
C_FF for a literal Form Feed '\f'
C_NL for a literal Newline '\n'
C_CR for a literal Carriage Return '\r'
C_TAB for a literal Tab '\t'
C_BSLASH for a literal backslash '\\'
C_IT for an other character literal 'x' where x is possibly '
STRING_LIT for a string literal (possibly containing \")
COMMENT for a left-parenthesis (possibly beginning a comment)
PRIM for "PRIM"
CONST for "CONST"
VAR for "VAR"
USER for "USER"
LABEL for "LABEL"
COLON for ":"
SEMICOLON for ";"
SEMISTAR for ";*" (used to make words IMMEDIATE)
NUL for the token {NUL}, which gets compiled as a null byte;
this special interpretation takes place in the COLON
code.
LIT for the word "LIT" (treated like OTHER, except that
no warning is generated when a literal follows this)
OTHER for an other word not recognized above
Note that this is just a hint: the meaning of any string of characters
depends on the context.
*/
#include "forth.lex.h"
TOKEN token;
# define YYNEWLINE 10
TOKEN *yylex(){
int nstr; extern int yyprevious;
while((nstr = yylook()) >= 0)
yyfussy: switch(nstr){
case 0:
if(yywrap()) return(0); break;
case 1:
X/* whitespace -- keep looping */ ;
break;
case 2:
{ token.type = DECIMAL; token.text = yytext;
return &token; }
break;
case 3:
{ token.type = OCTAL; token.text = yytext;
return &token; }
break;
case 4:
{ token.type = HEX; token.text = yytext;
return &token; }
break;
case 5:
{ token.type = C_BS; token.text = yytext; return &token; }
break;
case 6:
{ token.type = C_FF; token.text = yytext; return &token; }
break;
case 7:
{ token.type = C_NL; token.text = yytext; return &token; }
break;
case 8:
{ token.type = C_CR; token.text = yytext; return &token; }
break;
case 9:
{ token.type = C_TAB; token.text = yytext; return &token; }
break;
case 10:
{ token.type = C_BSLASH; token.text = yytext; return &token; }
break;
case 11:
{ token.type = C_LIT; token.text = yytext; return &token; }
break;
case 12:
{ token.type = STRING_LIT; token.text = yytext;
return &token; }
break;
case 13:
{ token.type = COMMENT; token.text = yytext;
return &token; }
break;
case 14:
{ token.type = PRIM; token.text = yytext;
return &token; }
break;
case 15:
{ token.type = CONST; token.text = yytext;
return &token; }
break;
case 16:
{ token.type = VAR; token.text = yytext;
return &token; }
break;
case 17:
{ token.type = USER; token.text = yytext;
return &token; }
break;
case 18:
{ token.type = LABEL; token.text = yytext;
return &token; }
break;
case 19:
{ token.type = COLON; token.text = yytext;
return &token; }
break;
case 20:
{ token.type = SEMICOLON; token.text = yytext;
return &token; }
break;
case 21:
{ token.type = SEMISTAR; token.text = yytext;
return &token; }
break;
case 22:
{ token.type = NUL; token.text = yytext;
return &token; }
break;
case 23:
{ token.type = LIT; token.text = yytext;
return &token; }
break;
case 24:
{ token.type = OTHER; token.text = yytext;
return &token; }
break;
case -1:
break;
default:
fprintf(yyout,"bad switch yylook %d",nstr);
} return(0); }
X/* end of yylex */
int yyvstop[] ={
0,
1,
0,
1,
0,
-24,
0,
1,
0,
-24,
0,
-24,
0,
-13,
-24,
0,
-24,
0,
-3,
-24,
0,
-2,
-24,
0,
-19,
-24,
0,
-20,
-24,
0,
-24,
0,
-24,
0,
-24,
0,
-24,
0,
-24,
0,
-24,
0,
24,
0,
24,
0,
-12,
-24,
0,
-24,
0,
-24,
0,
24,
0,
-24,
0,
13,
24,
0,
3,
24,
0,
-3,
-24,
0,
-24,
0,
2,
24,
0,
19,
24,
0,
20,
24,
0,
-21,
-24,
0,
-24,
0,
-24,
0,
-24,
0,
-24,
0,
-24,
0,
-24,
0,
-24,
0,
-12,
0,
12,
24,
0,
-12,
-24,
0,
-11,
-24,
0,
-11,
0,
-24,
0,
-24,
0,
-24,
0,
-24,
0,
-24,
0,
-24,
0,
-4,
-24,
0,
21,
24,
0,
-24,
0,
-24,
0,
-23,
-24,
0,
-24,
0,
-24,
0,
-16,
-24,
0,
-24,
0,
12,
0,
-12,
0,
12,
24,
0,
11,
24,
0,
11,
0,
-10,
-24,
0,
-5,
-24,
0,
-6,
-24,
0,
-7,
-24,
0,
-8,
-24,
0,
-9,
-24,
0,
4,
24,
0,
-24,
0,
-24,
0,
23,
24,
0,
-14,
-24,
0,
-17,
-24,
0,
16,
24,
0,
-24,
0,
12,
0,
10,
24,
0,
5,
24,
0,
6,
24,
0,
7,
24,
0,
8,
24,
0,
9,
24,
0,
-15,
-24,
0,
-18,
-24,
0,
14,
24,
0,
17,
24,
0,
-22,
-24,
0,
15,
24,
0,
18,
24,
0,
22,
24,
0,
0};
# define YYTYPE char
struct yywork { YYTYPE verify, advance; } yycrank[] ={
0,0, 0,0, 1,3, 0,0,
0,0, 0,0, 0,0, 0,0,
0,0, 0,0, 1,4, 1,4,
0,0, 4,4, 4,4, 0,0,
4,4, 4,4, 7,26, 7,26,
11,31, 11,31, 21,44, 21,44,
0,0, 12,32, 12,32, 33,55,
33,55, 0,0, 42,63, 42,63,
0,0, 42,63, 42,63, 1,5,
4,4, 46,66, 46,66, 0,0,
1,6, 1,7, 22,45, 3,3,
23,46, 24,47, 1,8, 48,68,
49,69, 1,9, 1,10, 3,19,
3,19, 42,63, 50,70, 2,6,
2,7, 1,10, 12,33, 1,11,
1,12, 2,8, 5,5, 51,71,
6,23, 52,72, 1,3, 43,64,
1,13, 35,57, 5,20, 5,20,
6,24, 6,19, 2,11, 2,12,
3,3, 1,14, 37,59, 38,60,
18,40, 1,15, 13,34, 2,13,
15,37, 16,38, 1,16, 1,17,
34,56, 1,3, 3,3, 3,3,
2,14, 9,27, 9,27, 5,21,
2,15, 6,23, 3,3, 36,58,
22,22, 2,16, 2,17, 10,30,
10,30, 8,9, 8,10, 3,3,
39,61, 5,5, 5,5, 6,23,
6,23, 8,10, 14,3, 40,62,
41,43, 5,5, 53,73, 6,23,
28,27, 28,27, 14,19, 14,19,
1,18, 43,43, 5,5, 56,75,
6,23, 57,76, 3,3, 59,78,
9,28, 9,28, 45,65, 45,65,
58,77, 58,77, 60,79, 2,18,
29,54, 29,54, 10,10, 10,10,
62,81, 25,46, 65,43, 14,3,
29,54, 5,5, 10,10, 6,23,
75,89, 5,22, 76,90, 6,25,
81,93, 29,54, 82,43, 28,28,
28,28, 14,3, 14,3, 0,0,
47,67, 47,67, 0,0, 47,67,
47,67, 14,3, 61,80, 61,80,
9,29, 64,82, 64,82, 0,0,
17,3, 0,0, 14,35, 14,3,
14,3, 14,3, 14,3, 14,3,
17,19, 17,19, 14,36, 47,67,
68,83, 68,83, 69,84, 69,84,
70,85, 70,85, 71,86, 71,86,
72,87, 72,87, 25,48, 73,88,
73,88, 14,3, 78,91, 78,91,
25,49, 79,92, 79,92, 0,0,
25,50, 17,3, 14,3, 14,3,
14,3, 14,3, 14,3, 14,3,
25,51, 45,22, 89,94, 89,94,
25,52, 0,0, 25,53, 17,3,
17,3, 90,95, 90,95, 93,96,
93,96, 0,0, 0,0, 17,3,
0,0, 0,0, 0,0, 0,0,
0,0, 0,0, 20,41, 0,0,
17,39, 17,3, 17,3, 17,3,
17,3, 17,3, 20,41, 20,41,
54,74, 54,74, 0,0, 0,0,
0,0, 0,0, 0,0, 0,0,
64,43, 0,0, 0,0, 0,0,
0,0, 0,0, 0,0, 17,3,
0,0, 0,0, 0,0, 0,0,
0,0, 0,0, 0,0, 20,42,
17,3, 17,3, 17,3, 17,3,
17,3, 17,3, 0,0, 0,0,
0,0, 0,0, 0,0, 0,0,
0,0, 20,41, 20,41, 54,54,
54,54, 0,0, 0,0, 0,0,
0,0, 20,41, 0,0, 54,54,
0,0, 0,0, 0,0, 0,0,
0,0, 0,0, 20,41, 0,0,
54,54, 0,0, 0,0, 0,0,
0,0, 0,0, 0,0, 0,0,
0,0, 0,0, 0,0, 0,0,
0,0, 0,0, 0,0, 0,0,
0,0, 0,0, 0,0, 0,0,
0,0, 20,41, 0,0, 0,0,
0,0, 20,43, 0,0, 0,0,
0,0};
struct yysvf yysvec[] ={
0, 0, 0,
yycrank+-1, 0, yyvstop+1,
yycrank+-16, yysvec+1, yyvstop+3,
yycrank+-42, 0, yyvstop+5,
yycrank+4, 0, yyvstop+7,
yycrank+-61, 0, yyvstop+9,
yycrank+-63, 0, yyvstop+11,
yycrank+-9, yysvec+3, yyvstop+13,
yycrank+-57, yysvec+3, yyvstop+16,
yycrank+-84, yysvec+3, yyvstop+18,
yycrank+-94, yysvec+3, yyvstop+21,
yycrank+-11, yysvec+3, yyvstop+24,
yycrank+-16, yysvec+3, yyvstop+27,
yycrank+-3, yysvec+3, yyvstop+30,
yycrank+-113, 0, yyvstop+32,
yycrank+-2, yysvec+3, yyvstop+34,
yycrank+-2, yysvec+3, yyvstop+36,
yycrank+-175, 0, yyvstop+38,
yycrank+-2, yysvec+3, yyvstop+40,
yycrank+0, 0, yyvstop+42,
yycrank+-237, 0, yyvstop+44,
yycrank+-13, yysvec+3, yyvstop+46,
yycrank+-8, yysvec+5, yyvstop+49,
yycrank+-5, yysvec+3, yyvstop+51,
yycrank+6, 0, yyvstop+53,
yycrank+-106, yysvec+3, yyvstop+55,
yycrank+0, 0, yyvstop+57,
yycrank+0, 0, yyvstop+60,
yycrank+-111, yysvec+3, yyvstop+63,
yycrank+-92, yysvec+3, yyvstop+66,
yycrank+0, 0, yyvstop+68,
yycrank+0, 0, yyvstop+71,
yycrank+0, 0, yyvstop+74,
yycrank+-18, yysvec+3, yyvstop+77,
yycrank+-10, yysvec+3, yyvstop+80,
yycrank+-3, yysvec+3, yyvstop+82,
yycrank+-15, yysvec+3, yyvstop+84,
yycrank+-5, yysvec+3, yyvstop+86,
yycrank+-10, yysvec+3, yyvstop+88,
yycrank+-26, yysvec+3, yyvstop+90,
yycrank+-30, yysvec+3, yyvstop+92,
yycrank+-24, yysvec+20, 0,
yycrank+21, 0, yyvstop+94,
yycrank+-33, yysvec+20, 0,
yycrank+0, 0, yyvstop+96,
yycrank+-125, yysvec+5, yyvstop+99,
yycrank+-28, yysvec+3, yyvstop+102,
yycrank+155, 0, yyvstop+105,
yycrank+-8, yysvec+3, yyvstop+107,
yycrank+-9, yysvec+3, yyvstop+109,
yycrank+-15, yysvec+3, yyvstop+111,
yycrank+-24, yysvec+3, yyvstop+113,
yycrank+-26, yysvec+3, yyvstop+115,
yycrank+-79, yysvec+3, yyvstop+117,
yycrank+-239, yysvec+3, yyvstop+119,
yycrank+0, 0, yyvstop+122,
yycrank+-44, yysvec+3, yyvstop+125,
yycrank+-60, yysvec+3, yyvstop+127,
yycrank+-127, yysvec+3, yyvstop+129,
yycrank+-54, yysvec+3, yyvstop+132,
yycrank+-56, yysvec+3, yyvstop+134,
yycrank+-161, yysvec+3, yyvstop+136,
yycrank+-68, yysvec+3, yyvstop+139,
yycrank+0, 0, yyvstop+141,
yycrank+-164, yysvec+20, yyvstop+143,
yycrank+-54, yysvec+20, yyvstop+145,
yycrank+0, 0, yyvstop+148,
yycrank+0, 0, yyvstop+151,
yycrank+-179, yysvec+3, yyvstop+153,
yycrank+-181, yysvec+3, yyvstop+156,
yycrank+-183, yysvec+3, yyvstop+159,
yycrank+-185, yysvec+3, yyvstop+162,
yycrank+-187, yysvec+3, yyvstop+165,
yycrank+-190, yysvec+3, yyvstop+168,
yycrank+0, 0, yyvstop+171,
yycrank+-68, yysvec+3, yyvstop+174,
yycrank+-78, yysvec+3, yyvstop+176,
yycrank+0, 0, yyvstop+178,
yycrank+-193, yysvec+3, yyvstop+181,
yycrank+-196, yysvec+3, yyvstop+184,
yycrank+0, 0, yyvstop+187,
yycrank+-31, yysvec+3, yyvstop+190,
yycrank+-66, yysvec+20, yyvstop+192,
yycrank+0, 0, yyvstop+194,
yycrank+0, 0, yyvstop+197,
yycrank+0, 0, yyvstop+200,
yycrank+0, 0, yyvstop+203,
yycrank+0, 0, yyvstop+206,
yycrank+0, 0, yyvstop+209,
yycrank+-209, yysvec+3, yyvstop+212,
yycrank+-216, yysvec+3, yyvstop+215,
yycrank+0, 0, yyvstop+218,
yycrank+0, 0, yyvstop+221,
yycrank+-218, yysvec+3, yyvstop+224,
yycrank+0, 0, yyvstop+227,
yycrank+0, 0, yyvstop+230,
yycrank+0, 0, yyvstop+233,
0, 0, 0};
struct yywork *yytop = yycrank+329;
struct yysvf *yybgin = yysvec+1;
char yymatch[] ={
00 ,01 ,01 ,01 ,01 ,01 ,01 ,01 ,
01 ,011 ,012 ,01 ,011 ,011 ,01 ,01 ,
01 ,01 ,01 ,01 ,01 ,01 ,01 ,01 ,
01 ,01 ,01 ,01 ,01 ,01 ,01 ,01 ,
011 ,01 ,'"' ,01 ,01 ,01 ,01 ,01 ,
01 ,01 ,01 ,01 ,01 ,01 ,01 ,01 ,
'0' ,'1' ,'1' ,'1' ,'1' ,'1' ,'1' ,'1' ,
'8' ,'8' ,01 ,01 ,01 ,01 ,01 ,01 ,
01 ,'A' ,'A' ,'A' ,'A' ,'A' ,'A' ,01 ,
01 ,01 ,01 ,01 ,01 ,01 ,01 ,01 ,
01 ,01 ,01 ,01 ,01 ,01 ,01 ,01 ,
'X' ,01 ,01 ,01 ,01 ,01 ,01 ,01 ,
01 ,'A' ,'A' ,'A' ,'A' ,'A' ,'A' ,01 ,
01 ,01 ,01 ,01 ,01 ,01 ,01 ,01 ,
01 ,01 ,01 ,01 ,01 ,01 ,01 ,01 ,
'X' ,01 ,01 ,01 ,01 ,01 ,01 ,01 ,
0};
char yyextra[] ={
0,0,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,
1,0,0,0,0,0,0,0,
0};
X/* ncform 4.1 83/08/11 */
int yylineno =1;
# define YYU(x) x
# define NLSTATE yyprevious=YYNEWLINE
char yytext[YYLMAX];
struct yysvf *yylstate [YYLMAX], **yylsp, **yyolsp;
char yysbuf[YYLMAX];
char *yysptr = yysbuf;
int *yyfnd;
extern struct yysvf *yyestate;
int yyprevious = YYNEWLINE;
yylook(){
register struct yysvf *yystate, **lsp;
register struct yywork *yyt;
struct yysvf *yyz;
int yych;
struct yywork *yyr;
# ifdef LEXDEBUG
int debug;
# endif
char *yylastch;
/* start off machines */
# ifdef LEXDEBUG
debug = 0;
# endif
if (!yymorfg)
yylastch = yytext;
else {
yymorfg=0;
yylastch = yytext+yyleng;
}
for(;;){
lsp = yylstate;
yyestate = yystate = yybgin;
if (yyprevious==YYNEWLINE) yystate++;
for (;;){
# ifdef LEXDEBUG
if(debug)fprintf(yyout,"state %d\n",yystate-yysvec-1);
# endif
yyt = yystate->yystoff;
if(yyt == yycrank){ /* may not be any transitions */
yyz = yystate->yyother;
if(yyz == 0)break;
if(yyz->yystoff == yycrank)break;
}
*yylastch++ = yych = input();
tryagain:
# ifdef LEXDEBUG
if(debug){
fprintf(yyout,"char ");
allprint(yych);
putchar('\n');
}
# endif
yyr = yyt;
if ( (int)yyt > (int)yycrank){
yyt = yyr + yych;
if (yyt <= yytop && yyt->verify+yysvec == yystate){
if(yyt->advance+yysvec == YYLERR) /* error transitions */
{unput(*--yylastch);break;}
*lsp++ = yystate = yyt->advance+yysvec;
goto contin;
}
}
# ifdef YYOPTIM
else if((int)yyt < (int)yycrank) { /* r < yycrank */
yyt = yyr = yycrank+(yycrank-yyt);
# ifdef LEXDEBUG
if(debug)fprintf(yyout,"compressed state\n");
# endif
yyt = yyt + yych;
if(yyt <= yytop && yyt->verify+yysvec == yystate){
if(yyt->advance+yysvec == YYLERR) /* error transitions */
{unput(*--yylastch);break;}
*lsp++ = yystate = yyt->advance+yysvec;
goto contin;
}
yyt = yyr + YYU(yymatch[yych]);
# ifdef LEXDEBUG
if(debug){
fprintf(yyout,"try fall back character ");
allprint(YYU(yymatch[yych]));
putchar('\n');
}
# endif
if(yyt <= yytop && yyt->verify+yysvec == yystate){
if(yyt->advance+yysvec == YYLERR) /* error transition */
{unput(*--yylastch);break;}
*lsp++ = yystate = yyt->advance+yysvec;
goto contin;
}
}
if ((yystate = yystate->yyother) && (yyt= yystate->yystoff) != yycrank){
# ifdef LEXDEBUG
if(debug)fprintf(yyout,"fall back to state %d\n",yystate-yysvec-1);
# endif
goto tryagain;
}
# endif
else
{unput(*--yylastch);break;}
contin:
# ifdef LEXDEBUG
if(debug){
fprintf(yyout,"state %d char ",yystate-yysvec-1);
allprint(yych);
putchar('\n');
}
# endif
;
}
# ifdef LEXDEBUG
if(debug){
fprintf(yyout,"stopped at %d with ",*(lsp-1)-yysvec-1);
allprint(yych);
putchar('\n');
}
# endif
while (lsp-- > yylstate){
*yylastch-- = 0;
if (*lsp != 0 && (yyfnd= (*lsp)->yystops) && *yyfnd > 0){
yyolsp = lsp;
if(yyextra[*yyfnd]){ /* must backup */
while(yyback((*lsp)->yystops,-*yyfnd) != 1 && lsp > yylstate){
lsp--;
unput(*yylastch--);
}
}
yyprevious = YYU(*yylastch);
yylsp = lsp;
yyleng = yylastch-yytext+1;
yytext[yyleng] = 0;
# ifdef LEXDEBUG
if(debug){
fprintf(yyout,"\nmatch ");
sprint(yytext);
fprintf(yyout," action %d\n",*yyfnd);
}
# endif
return(*yyfnd++);
}
unput(*yylastch);
}
if (yytext[0] == 0 /* && feof(yyin) */)
{
yysptr=yysbuf;
return(0);
}
yyprevious = yytext[0] = input();
if (yyprevious>0)
output(yyprevious);
yylastch=yytext;
# ifdef LEXDEBUG
if(debug)putchar('\n');
# endif
}
}
yyback(p, m)
int *p;
{
if (p==0) return(0);
while (*p)
{
if (*p++ == m)
return(1);
}
return(0);
}
/* the following are only used in the lex library */
yyinput(){
return(input());
}
yyoutput(c)
int c; {
output(c);
}
yyunput(c)
int c; {
unput(c);
}
//go.sysin dd *
echo 'x - nf.c'
sed 's/^X//' <<'//go.sysin dd *' >nf.c
X/* nf.c -- this program can be run to generate a new environment for the
* FORTH interpreter forth.c. It takes the dictionary from the standard input.
* Normally, this dictionary is in the file "forth.dict", so
* nf < forth.dict
* will do the trick.
*/
#include <stdio.h>
#include <ctype.h>
#include "common.h"
#include "forth.lex.h" /* #defines for lexical analysis */
#define isoctal(c) (c >= '0' && c <= '7') /* augument ctype.h */
#define assert(c,s) (!(c) ? failassert(s) : 1)
#define chklit() (!prev_lit ? dictwarn("Qustionable literal") : 1)
#define LINK struct linkrec
#define CHAIN struct chainrec
struct chainrec {
char chaintext[32];
int defloc; /* CFA or label loc */
int chaintype; /* 0=undef'd, 1=absolute, 2=relative */
CHAIN *nextchain;
LINK *firstlink;
};
struct linkrec {
int loc;
LINK *nextlink;
};
CHAIN firstchain;
#define newchain() (CHAIN *)(calloc(1,sizeof(CHAIN)))
#define newlink() (LINK *)(calloc(1,sizeof(LINK)))
CHAIN *find();
CHAIN *lastchain();
LINK *lastlink();
char *strcat();
char *calloc();
int dp = DPBASE;
int latest;
short mem[INITMEM];
XFILE *outf, *fopen();
main(argc, argv)
int argc;
char *argv[];
{
#ifdef DEBUG
puts("Opening output file");
#endif DEBUG
strcpy(firstchain.chaintext," ** HEADER **");
firstchain.nextchain = NULL;
firstchain.firstlink = NULL;
#ifdef DEBUG
puts("call builddict");
#endif DEBUG
builddict();
#ifdef DEBUG
puts("Make FORTH and COLDIP");
#endif DEBUG
mkrest();
#ifdef DEBUG
puts("Call Buildcore");
#endif DEBUG
buildcore();
#ifdef DEBUG
puts("call checkdict");
#endif DEBUG
checkdict();
#ifdef DEBUG
puts("call writedict");
#endif DEBUG
writedict();
printf("%s: done.\n", argv[0]);
}
buildcore() /* set up low core */
{
mem[USER_DEFAULTS+0] = INITS0; /* initial S0 */
mem[USER_DEFAULTS+1] = INITR0; /* initial R0 */
mem[USER_DEFAULTS+2] = TIB_START; /* initial TIB */
mem[USER_DEFAULTS+3] = MAXWIDTH; /* initial WIDTH */
mem[USER_DEFAULTS+4] = 0; /* initial WARNING */
mem[USER_DEFAULTS+5] = dp; /* initial FENCE */
mem[USER_DEFAULTS+6] = dp; /* initial DP */
mem[USER_DEFAULTS+7] = instance("FORTH") + 3; /* initial CONTEXT */
mem[SAVEDIP] = 0; /* not a saved FORTH */
}
builddict() /* read the dictionary */
{
int prev_lit = 0, lit_flag = 0;
int temp;
char s[256];
TOKEN *token;
while ((token = yylex()) != NULL) { /* EOF returned as a null pointer */
#ifdef DEBUG
printf("\ntoken: %s: %d ",token->text, token->type);
#endif DEBUG
switch (token->type) {
case PRIM:
#ifdef DEBUG
printf("primitive ");
#endif DEBUG
if ((token = yylex()) == NULL) /* get the next word */
dicterr("No word following PRIM");
strcpy (s,token->text);
#ifdef DEBUG
printf(".%s. ",s);
#endif DEBUG
if ((token == yylex()) == NULL) /* get the value */
dicterr("No value following PRIM <word>");
mkword(s,mkval(token));
break;
case CONST:
#ifdef DEBUG
printf("constant ");
#endif DEBUG
if ((token = yylex()) == NULL) /* get the word */
dicterr("No word following CONST");
strcpy (s,token->text); /* s holds word */
#ifdef DEBUG
printf(".%s. ",s);
#endif DEBUG
if (!find("DOCON"))
dicterr ("Constant definition before DOCON: %s",s);
/* put the CF of DOCON into this word's CF */
mkword(s,(int)mem[instance("DOCON")]);
if ((token = yylex()) == NULL) /* get the value */
dicterr("No value following CONST <word>");
temp = mkval(token);
/* two special-case constants */
if (strcmp(s,"FIRST") == 0) temp = INITR0;
else if (strcmp(s,"LIMIT") == 0) temp = DPBASE;
comma(temp);
break;
case VAR:
#ifdef DEBUG
printf("variable ");
#endif DEBUG
if ((token = yylex()) == NULL) /* get the variable name */
dicterr("No word following VAR");
strcpy (s,token->text);
#ifdef DEBUG
printf(".%s. ",s);
#endif DEBUG
if (!find("DOVAR"))
dicterr("Variable declaration before DOVAR: %s",s);
mkword (s, (int)mem[instance("DOVAR")]);
if ((token = yylex()) == NULL) /* get the value */
dicterr("No value following VAR <word>");
comma(mkval(token));
break;
case USER:
#ifdef DEBUG
printf("uservar ");
#endif DEBUG
if ((token = yylex()) == NULL) /* get uservar name */
dicterr("No name following USER");
strcpy (s,token->text);
#ifdef DEBUG
printf(".%s. ",s);
#endif DEBUG
if (!find("DOUSE"))
dicterr("User variable declared before DOUSE: %s",s);
mkword (s, (int)mem[instance("DOUSE")]);
if ((token = yylex()) == NULL) /* get the value */
dicterr("No value following USER <word>");
comma(mkval(token));
break;
case COLON:
#ifdef DEBUG
printf("colon def'n ");
#endif DEBUG
if ((token = yylex()) == NULL) /* get name of word */
dicterr("No word following : in definition");
strcpy (s,token->text);
#ifdef DEBUG
printf(".%s.\n",s);
#endif DEBUG
if (!find("DOCOL"))
dicterr("Colon definition appears before DOCOL: %s",s);
if (token->type == NUL) { /* special zero-named word */
int here = dp; /* new latest */
#ifdef DEBUG
printf("NULL WORD AT 0x%04x\n");
#endif DEBUG
comma(0xC1);
comma(0x80);
comma(latest);
latest = here;
comma((int)mem[instance("DOCOL")]);
}
else {
mkword (s, (int)mem[instance("DOCOL")]);
}
break;
case SEMICOLON:
#ifdef DEBUG
puts("end colon def'n");
#endif DEBUG
comma (instance(";S"));
break;
case SEMISTAR:
#ifdef DEBUG
printf("end colon w/IMMEDIATE ");
#endif DEBUG
comma (instance (";S")); /* compile cfA of ;S, not CF */
mem[latest] |= IMMEDIATE; /* make the word immediate */
break;
case STRING_LIT:
#ifdef DEBUG
printf("string literal ");
#endif DEBUG
strcpy(s,token->text);
mkstr(s); /* mkstr compacts the string in place */
#ifdef DEBUG
printf("string=(%d) \"%s\" ",strlen(s),s);
#endif DEBUG
comma(strlen(s));
{
char *stemp;
stemp = s;
while (*stemp) comma(*stemp++);
}
break;
case COMMENT:
#ifdef DEBUG
printf("comment ");
#endif DEBUG
skipcomment();
break;
case LABEL:
#ifdef DEBUG
printf("label: ");
#endif DEBUG
if ((token = yylex()) == NULL)
dicterr("No name following LABEL");
#ifdef DEBUG
printf(".%s. ", token->text);
#endif DEBUG
define(token->text,2); /* place in sym. table w/o compiling
anything into dictionary; 2 means
defining a label */
break;
case LIT:
lit_flag = 1; /* and fall through to the rest */
default:
if (find(token->text) != NULL) { /* is word defined? */
#ifdef DEBUG
printf(" normal: %s\n",token->text);
#endif DEBUG
comma (instance (token->text));
break;
}
/* else */
/* the literal types all call chklit(). This macro checks to
if the previous word was "LIT"; if not, it warns */
switch(token->type) {
case DECIMAL: chklit(); comma(mkdecimal(token->text)); break;
case HEX: chklit(); comma(mkhex(token->text)); break;
case OCTAL: chklit(); comma(mkoctal(token->text)); break;
case C_BS: chklit(); comma('\b'); break;
case C_FF: chklit(); comma('\f'); break;
case C_NL: chklit(); comma('\n'); break;
case C_CR: chklit(); comma('\r'); break;
case C_TAB: chklit(); comma('\t'); break;
case C_BSLASH: chklit(); comma(0x5c); break; /* ASCII backslash */
case C_LIT: chklit(); comma(*((token->text)+1)); break;
default:
#ifdef DEBUG
printf("forward reference");
#endif DEBUG
comma (instance (token->text)); /* create an instance,
to be resolved at definition */
}
}
#ifdef DEBUG
if (lit_flag) puts("expect a literal");
#endif DEBUG
prev_lit = lit_flag; /* to be used by chklit() next time */
lit_flag = 0;
}
}
comma(i) /* put at mem[dp]; increment dp */
{
mem[dp++] = (unsigned short)i;
if (dp > INITMEM) dicterr("DICTIONARY OVERFLOW");
}
X/*
* make a word in the dictionary. the new word will have name *s, its CF
* will contain v. Also, resolve any previously-unresolved references by
* calling define()
*/
mkword(s, v)
char *s;
short v;
{
int here, count = 0;
char *olds;
olds = s; /* preserve this for resolving references */
#ifdef DEBUG
printf("%s ",s);
#endif DEBUG
here = dp; /* hold this value to place length byte */
while (*s) { /* for each character */
mem[++dp] = (unsigned short)*s;
count++; s++;
}
if (count >= MAXWIDTH) dicterr("Input word name too long");
/* set MSB on */
mem[here] = (short)(count | 0x80);
mem[dp++] |= 0x80; /* set hi bit of last char in name */
mem[dp++] = (short)latest; /* the link field */
latest = here; /* update the link */
mem[dp] = v; /* code field; leave dp = CFA */
define(olds,1); /* place in symbol table. 1 == "not a label" */
dp++; /* now leave dp holding PFA */
/* that's all. Now dp points (once again) to the first UNallocated
spot in mem, and everybody's happy. */
}
mkrest() /* Write out the word FORTH as a no-op with
DOCOL as CF, ;S as PF, followed by
0xA081, and latest in its PF.
Also, Put the CFA of ABORT at
mem[COLDIP] */
{
int temp;
mem[COLDIP] = dp; /* the cold-start IP is here, and the word
which will be executed is COLD */
if ((mem[dp++] = instance("COLD")) == 0)
dicterr("COLD must be defined to take control at startup");
mem[ABORTIP] = dp; /* the abort-start IP is here, and the word
which will be executed is ABORT */
if ((mem[dp++] = instance("ABORT")) == 0)
dicterr("ABORT must be defined to take control at interrupt");
mkword("FORTH",mem[instance("DOCOL")]);
comma(instance(";S"));
comma(0xA081); /* magic number for vocabularies */
comma(latest); /* NFA of last word in dictionary: FORTH */
mem[LIMIT] = dp + 1024;
if (mem[LIMIT] >= INITMEM) mem[LIMIT] = INITMEM-1;
}
writedict() /* write memory to COREFILE and map
to MAPFILE */
{
FILE *outfile;
int i, temp, tempb, firstzero, nonzero;
char chars[9], outline[80], tstr[6];
outfile = fopen(MAPFILE,"w");
for (temp = 0; temp < dp; temp += 8) {
nonzero = FALSE;
sprintf (outline, "%04x:", temp);
for (i = temp; i < temp + 8; i++) {
sprintf (tstr, " %04x", (unsigned short) mem[i]);
strcat (outline, tstr);
tempb = mem[i] & 0x7f;
if (tempb < 0x7f && tempb >= ' ')
chars[i % 8] = tempb;
else
chars[i % 8] = '.';
nonzero |= mem[i];
}
if (nonzero) {
fprintf (outfile, "%s %s\n", outline, chars);
firstzero = TRUE;
}
else
if (firstzero) {
fprintf (outfile, "----- ZERO ----\n");
firstzero = FALSE;
}
}
fclose (outfile);
printf ("Writing %s; DPBASE=%d; dp=%d\n", COREFILE, DPBASE, dp);
if ((outf = fopen (COREFILE, "w")) == NULL) {
printf ("nf: can't open %s for output.\n", COREFILE);
exit (1);
}
if (fwrite (mem, sizeof (*mem), mem[LIMIT], outf) != mem[LIMIT]) {
fprintf (stderr, "Error writing to %s\n", COREFILE);
exit (1);
}
if (fclose (outf) == EOF) {
fprintf (stderr, "Error closing %s\n", COREFILE);
exit (1);
}
}
mkval(t) /* convert t->text to integer based on type */
TOKEN *t;
{
char *s = t->text;
int sign = 1;
if (*s == '-') {
sign = -1;
s++;
}
switch (t->type) {
case DECIMAL:
return (sign * mkdecimal(s));
case HEX:
return (sign * mkhex(s));
case OCTAL:
return (sign * mkoctal(s));
default:
dicterr("Bad value following PRIM, CONST, VAR, or USER");
}
}
mkhex(s)
char *s;
{ /* convert hex ascii to integer */
int temp;
temp = 0;
s += 2; /* skip over '0x' */
while (isxdigit (*s)) { /* first non-hex char ends */
temp <<= 4; /* mul by 16 */
if (isupper (*s))
temp += (*s - 'A') + 10;
else
if (islower (*s))
temp += (*s - 'a') + 10;
else
temp += (*s - '0');
s++;
}
return temp;
}
mkoctal(s)
char *s;
{ /* convert Octal ascii to integer */
int temp;
temp = 0;
while (isoctal (*s)) { /* first non-octal char ends */
temp = temp * 8 + (*s - '0');
s++;
}
return temp;
}
mkdecimal(s) /* convert ascii to decimal */
char *s;
{
return (atoi(s)); /* alias */
}
dicterr(s,p1)
char *s;
int p1; /* might be char * -- printf uses it */
{
fprintf(stderr,s,p1);
fprintf(stderr,"\nLast word defined was ");
printword(latest);
X/* fprintf(stderr, "; last word read was \"%s\"", token->text); */
fprintf(stderr,"\n");
exit(1);
}
dictwarn(s) /* almost like dicterr, but don't exit */
char *s;
{
fprintf(stderr,"\nWarning: %s\nLast word read was ",s);
printword(latest);
putc('\n',stderr);
}
printword(n)
int n;
{
int count, tmp;
count = mem[n] & 0x1f;
for (n++;count;count--,n++) {
tmp = mem[n] & ~0x80; /* mask eighth bit off */
if (tmp >= ' ' && tmp <= '~') putc(tmp, stderr);
}
}
skipcomment()
{
while(getchar() != ')');
}
mkstr(s) /* modifies a string in place with escapes
compacted. Strips leading & trailing \" */
char *s;
{
char *source;
char *dest;
source = dest = s;
source++; /* skip leading quote */
while (*source != '"') { /* string ends with unescaped \" */
if (*source == '\\') { /* literal next */
source++;
}
*dest++ = *source++;
}
*dest = '\0';
}
failassert(s)
char *s;
{
puts(s);
exit(1);
}
checkdict() /* check for unresolved references */
{
CHAIN *ch = &firstchain;
#ifdef DEBUG
puts("\nCheck for unresolved references");
#endif DEBUG
while (ch != NULL) {
#ifdef DEBUG
printf("ch->chaintext = .%s. - ",ch->chaintext);
#endif DEBUG
if ((ch->firstlink) != NULL) {
fprintf(stderr,"Unresolved forward reference: %s\n",ch->chaintext);
#ifdef DEBUG
puts("still outstanding");
#endif DEBUG
}
#ifdef DEBUG
else puts("clean.");
#endif DEBUG
ch = ch->nextchain;
}
}
X/********* structure-handling functions find(s), define(s,t), instance(s) **/
CHAIN *find(s) /* returns a pointer to the chain named s */
char *s;
{
CHAIN *ch;
ch = &firstchain;
while (ch != NULL) {
if (strcmp (s, ch->chaintext) == 0) return ch;
else ch = ch->nextchain;
}
return NULL; /* not found */
}
X/* define must create a symbol table entry if none exists, with type t.
if one does exist, it must have type 0 -- it is an error to redefine
something at this stage. Change to type t, and fill in the outstanding
instances, with the current dp if type=1, or relative if type=2. */
define(s,t) /* define s at current dp */
char *s;
int t;
{
CHAIN *ch;
LINK *ln, *templn;
#ifdef DEBUG
printf("define(%s,%d)\n",s,t);
#endif DEBUG
if (t < 1 || t > 2) /* range check */
dicterr("Program error: type in define() not 1 or 2.");
if ((ch = find(s)) != NULL) { /* defined or instanced? */
if (ch -> chaintype != 0) /* already defined! */
dicterr("Word already defined: %s",s);
else {
#ifdef DEBUG
printf("there are forward refs: ");
#endif DEBUG
ch->chaintype = t;
ch->defloc = dp;
}
}
else { /* must create a (blank) chain */
#ifdef DEBUG
puts("no forward refs");
#endif DEBUG
/* create a new chain, link it in, leave ch pointing to it */
ch = ((lastchain() -> nextchain) = newchain());
strcpy(ch->chaintext, s);
ch->chaintype = t;
ch->defloc = dp; /* fill in for future references */
}
/* now ch points to the chain (possibly) containing forward refs */
if ((ln = ch->firstlink) == NULL) return; /* no links! */
while (ln != NULL) {
#ifdef DEBUG
printf(" Forward ref at 0x%x\n",ln->loc);
#endif DEBUG
switch (ch->chaintype) {
case 1: mem[ln->loc] = (short)dp; /* absolute */
break;
case 2: mem[ln->loc] = (short)(dp - ln->loc); /* relative */
break;
default: dicterr ("Bad type field in define()");
}
/* now skip to the next link & free this one */
templn = ln;
ln = ln->nextlink;
free(templn);
}
ch->firstlink = NULL; /* clean up that last pointer */
}
X/*
instance must return a value to be compiled into the dictionary at
dp, consistent with the symbol s: if s is undefined, it returns 0,
and adds this dp to the chain for s (creating that chain if necessary).
If s IS defined, it returns <s> (absolute) or (s-dp) (relative),
where <s> was the dp when s was defined.
*/
instance(s)
char *s;
{
CHAIN *ch;
LINK *ln;
#ifdef DEBUG
printf("instance(%s):\n",s);
#endif DEBUG
if ((ch = find(s)) == NULL) { /* not defined yet at all */
#ifdef DEBUG
puts("entirely new -- create a new chain");
#endif DEBUG
/* create a new chain, link it in, leave ch pointing to it */
ch = ((lastchain() -> nextchain) = newchain());
strcpy(ch->chaintext, s);
ln = newlink(); /* make its link */
ch->firstlink = ln;
ln->loc = dp; /* store this location there */
return 0; /* all done */
}
else {
switch(ch->chaintype) {
case 0: /* not defined yet */
#ifdef DEBUG
puts("still undefined -- add a link");
#endif DEBUG
/* create a new link, point the last link to it, and
fill in the loc field with the current dp */
(lastlink(ch)->nextlink = newlink()) -> loc = dp;
return 0;
case 1: /* absolute */
#ifdef DEBUG
puts("defined absolute.");
#endif DEBUG
return ch->defloc;
case 2: /* relative */
#ifdef DEBUG
puts("defined relative.");
#endif DEBUG
return ch->defloc - dp;
default:
dicterr("Program error: bad type for chain");
}
}
}
CHAIN *lastchain() /* starting from firstchain, find the last chain */
{
CHAIN *ch = &firstchain;
while (ch->nextchain != NULL) ch = ch->nextchain;
return ch;
}
LINK *lastlink(ch) /* return the last link in the chain */
CHAIN *ch; /* CHAIN MUST HAVE AT LEAST ONE LINK */
{
LINK *ln = ch->firstlink;
while (ln->nextlink != NULL) ln = ln->nextlink;
return ln;
}
yywrap() /* called by yylex(). returning 1 means "all finished" */
{
return 1;
}
//go.sysin dd *
echo 'x - prims.c'
sed 's/^X//' <<'//go.sysin dd *' >prims.c
X/*
* prims.c -- code for the primitive functions declared in forth.dict
*/
#include <stdio.h>
#include <ctype.h> /* used in "digit" */
#include "common.h"
#include "forth.h"
#include "prims.h" /* macro primitives */
X/*
----------------------------------------------------
PRIMITIVE DEFINITIONS
----------------------------------------------------
*/
zbranch() /* add an offset (branch) if tos == 0 */
{
if(pop() == 0)
ip += mem[ip];
else
ip++; /* else skip over the offset */
}
ploop() /* (loop) -- loop control */
{
short index, limit;
index = rpop()+1;
if(index < (limit = rpop())) { /* if the new index < the limit */
rpush(limit); /* restore the limit */
rpush(index); /* and the index (incremented) */
branch(); /* and go back to the top of the loop */
}
else ip++; /* skip over the offset, and exit, having
popped the limit & index */
}
pploop() /* (+loop) -- almost the same */
{
short index, limit;
index = rpop()+pop(); /* get index & add increment */
if(index < (limit = rpop())) { /* if new index < limit */
rpush (limit); /* restore the limit */
rpush (index); /* restore the new index */
branch(); /* and branch back to the top */
}
else {
ip++; /* skip over branch offset */
}
}
pdo() /* (do): limit init -- [pushed to rstack] */
{
swap();
rpush (pop());
rpush (pop());
}
i() /* copy top of return stack to cstack */
{
int tmp;
tmp = rpop();
rpush(tmp);
push(tmp);
}
r() /* this must be a primitive as well as I because otherwise it
always returns its own address */
{
i();
}
digit() /* digit: c -- FALSE or [v TRUE] */
{
short c, base; /* C is ASCII char, convert to val. BASE is
used for range checking */
base = pop();
c = pop();
if (!isascii(c)) {
push (FALSE);
return;
}
/* lc -> UC if necessary */
if (islower(c)) c = toupper(c);
if (c < '0' || (c > '9' && c < 'A') || c > 'Z') {
push(FALSE); /* not a digit */
}
else { /* it is numeric or UC Alpha */
if (c >= 'A') c -= 7; /* put A-Z right after 0-9 */
c -= '0'; /* now c is 0..35 */
if (c >= base) {
push (FALSE); /* FALSE - not a digit */
}
else { /* OKAY: push value, then TRUE */
push (c);
push (TRUE);
}
}
}
pfind() /* WORD TOP -- xx FLAG, where TOP is NFA to start at;
WORD is the word to find; xx is PFA of found word;
yy is actual length of the word found;
FLAG is 1 if found. If not found, 0 alone is stacked. */
{
unsigned short worka, workb, workc, current, word, match;
current = pop ();
word = pop ();
while (current) { /* stop at end of dictionary */
if (!((mem[current] ^ mem[word]) & 0x3f)) {
/* match lengths & smudge */
worka = current + 1;/* point to the first letter */
workb = word + 1;
workc = mem[word]; /* workc gets count */
match = TRUE; /* initally true, for looping */
while (workc-- && match)
match = ((mem[worka++] & 0x7f) == (mem[workb++] & 0x7f));
if (match) { /* exited with match TRUE -- FOUND IT */
push (worka + 2); /* worka=LFA; push PFA */
push (mem[current]); /* push length byte */
push (TRUE); /* and TRUE flag */
return;
}
}
/* failed to match */
/* follow link field to next word */
current = mem[current + (mem[current] & 0x1f) + 1];
}
push (FALSE); /* current = 0; end of dict; not found */
}
enclose()
{
int delim, current, offset;
delim = pop();
current = pop();
push (current);
offset = -1;
current--;
encl1:
current++;
offset++;
if (mem[current] == delim) goto encl1;
push(offset);
if (mem[current] == NULL) {
offset++;
push (offset);
offset--;
push (offset);
return;
}
encl2:
current++;
offset++;
if (mem[current] == delim) goto encl4;
if (mem[current] != NULL) goto encl2;
/* mem[current] is null.. */
push (offset);
push (offset);
return;
encl4: /* found the trailing delimiter */
push (offset);
offset++;
push (offset);
return;
}
cmove() /* cmove: source dest number -- */
{
short source, dest, number, i;
number = pop();
dest = pop();
source = pop();
for ( ; number ; number-- ) mem[dest++] = mem[source++];
}
fill() /* fill: c dest number -- */
{
short dest, number, c;
number = pop();
dest = pop();
c = pop();
mem[dest] = c; /* always at least one */
if (number == 1) return; /* return if only one */
push (dest); /* else push dest as source of cmove */
push (dest + 1); /* dest+1 as dest of cmove */
push (number - 1); /* number-1 as number of cmove */
cmove();
}
ustar() /* u*: a b -- a*b.hi a*b.lo */
{
unsigned short a, b;
unsigned long c;
a = (unsigned short)pop();
b = (unsigned short)pop();
c = a * b;
/* (short) -1 is probably FFFF, which is just what we want */
push ((unsigned short)(c & (short) -1)); /* low word of product */
/* high word of product */
push ((short)((c >> (8*sizeof(short))) & (short) -1));
}
uslash() /* u/: NUM.LO NUM.HI DENOM -- REM QUOT */
{
unsigned short numhi, numlo, denom;
unsigned short quot, remainder; /* the longs below are to be sure the
intermediate computation is done
long; the results are short */
denom = pop();
numhi = pop();
numlo = pop();
quot = ((((unsigned long)numhi) << (8*sizeof(short)))
+ (unsigned long)numlo)
/ (unsigned long)denom;
remainder = ((((unsigned long)numhi) << (8*sizeof(short)))
+ (unsigned long)numlo)
% (unsigned long)denom;
push (remainder);
push (quot);
}
swap() /* swap: a b -- b a */
{
short a, b;
b = pop();
a = pop();
push (b);
push (a);
}
rot() /* rotate */
{
short a, b, c;
a = pop ();
b = pop ();
c = pop ();
push (b);
push (a);
push (c);
}
tfetch() /* 2@: addr -- mem[addr+1] mem[addr] */
{
unsigned short addr;
addr = pop();
push (mem[addr + 1]);
push (mem[addr]);
}
store() /* !: val addr -- <set mem[addr] = val> */
{
unsigned short tmp;
tmp = pop();
mem[tmp] = pop();
}
cstore() /* C!: val addr -- */
{
store();
}
tstore() /* 2!: val1 val2 addr --
mem[addr] = val2,
mem[addr+1] = val1 */
{
unsigned short tmp;
tmp = pop();
mem[tmp] = pop();
mem[tmp+1] = pop();
}
leave() /* set the index = the limit of a DO */
{
int tmp;
rpop(); /* discard old index */
tmp = rpop(); /* and push the limit as */
rpush(tmp); /* both the limit */
rpush(tmp); /* and the index */
}
dplus() /* D+: double-add */
{
short ahi, alo, bhi, blo;
long a, b;
bhi = pop();
blo = pop();
ahi = pop();
alo = pop();
a = ((long)ahi << (8*sizeof(short))) + (long)alo;
b = ((long)bhi << (8*sizeof(short))) + (long)blo;
a = a + b;
push ((unsigned short)(a & (short) -1)); /* sum lo */
push ((short)(a >> (8*sizeof(short)))); /* sum hi */
}
subtract() /* -: a b -- (a-b) */
{
int tmp;
tmp = pop();
push (pop() - tmp);
}
dsubtract() /* D-: double-subtract */
{
short ahi, alo, bhi, blo;
long a, b;
bhi = pop();
blo = pop();
ahi = pop();
alo = pop();
a = ((long)ahi << (8*sizeof(short))) + (long)alo;
b = ((long)bhi << (8*sizeof(short))) + (long)blo;
a = a - b;
push ((unsigned short)(a & (short) -1)); /* diff lo */
push ((short)(a >> (8*sizeof(short)))); /* diff hi */
}
dminus() /* DMINUS: negate a double number */
{
unsigned short ahi, alo;
long a;
ahi = pop();
alo = pop();
a = -(((long)ahi << (8*sizeof(short))) + (long)alo);
push ((unsigned short)(a & (short) -1)); /* -a lo */
push ((unsigned short)(a >> (8*sizeof(short)))); /* -a hi */
}
over() /* over: a b -- a b a */
{
short a, b;
b = pop();
a = pop();
push (a);
push (b);
push (a);
}
dup() /* dup: a -- a a */
{
short a;
a = pop();
push (a);
push (a);
}
tdup() /* 2dup: a b -- a b a b */
{
short a, b;
b = pop();
a = pop();
push (a);
push (b);
push (a);
push (b);
}
pstore() /* +!: val addr -- <add val to mem[addr]> */
{
short addr, val;
addr = pop();
val = pop();
mem[addr] += val;
}
toggle() /* toggle: addr bits -- <xor mem[addr]
with bits, store in mem[addr]> */
{
short bits, addr;
bits = pop();
addr = pop();
mem[addr] ^= bits;
}
less()
{
int tmp;
tmp = pop();
push (pop() < tmp);
}
pcold()
{
csp = INITS0; /* initialize values */
rsp = INITR0;
/* copy USER_DEFAULTS area into UP area */
push (USER_DEFAULTS); /* source */
push (UP); /* dest */
push (DEFS_SIZE); /* count */
cmove(); /* move! */
/* returns, executes ABORT */
}
prslw()
{
int buffer, flag, addr, i, temp, unwrittenflag;
long fpos, ftell();
char buf[1024]; /* holds data for xfer */
flag = pop();
buffer = pop();
addr = pop();
fpos = (long) (buffer * 1024);
/* extend if necessary */
if (fpos >= bfilesize) {
if (flag == 0) { /* write */
printf("Extending block file to %D bytes\n", fpos+1024);
/* the "2" below is the fseek magic number for "beyond end" */
fseek(blockfile, (fpos+1024) - bfilesize, 2);
bfilesize = ftell(blockfile);
}
else { /* reading unwritten data */
unwrittenflag = TRUE; /* will read all zeroes */
}
}
else {
/* note that "0" below is fseek magic number for "relative to
beginning-of-file" */
fseek(blockfile, fpos, 0); /* seek to destination */
}
if (flag) { /* read */
if (unwrittenflag) { /* not written yet */
for (i=0; i<1024; i++) mem[addr++] = 0; /* "read" nulls */
}
else { /* does exist */
if ((temp = fread (buf, sizeof(char), 1024, blockfile))
!= 1024) {
fprintf (stderr,
"File read error %d reading buffer %d\n",
temp, buffer);
errexit();
}
for (i=0; i<1024; i++) mem[addr++] = buf[i];
}
}
else { /* write */
for (i=0; i<1024; i++) buf[i] = mem[addr++];
if ((temp = fwrite (buf, sizeof(char), 1024, blockfile))
!= 1024) {
fprintf(stderr,
"File write error %d writing buffer %d\n",
temp, buffer);
errexit();
}
}
}
psave()
{
FILE *fp;
printf("\nSaving...");
fflush(stdout);
mem[SAVEDIP] = ip; /* save state */
mem[SAVEDSP] = csp;
mem[SAVEDRP] = rsp;
if ((fp = fopen(sfilename,"w")) == NULL) /* open for writing only */
errexit("Can't open core file %s for writing\n", sfilename);
if (fwrite(mem, sizeof(*mem), mem[0], fp) != mem[0])
errexit("Write error on %s\n",sfilename);
if (fclose(fp) == EOF)
errexit("Close error on %s\n",sfilename);
puts("Saved. Exit FORTH.");
exit(0);
}
//go.sysin dd *
echo 'x - prims.h'
sed 's/^X//' <<'//go.sysin dd *' >prims.h
X/* prims.h: This file defines inline primitives, which are called as functions
from the big SWITCH in forth.c */
/* push mem[ip] to cstack */
#define lit() { push (mem[ip++]); }
/* add an offset (this word) to ip */
#define branch() { ip += mem[ip]; }
/* return a key from input */
#define key() { push(pkey()); }
/* return TRUE if break key pressed */
#define qterminal() { pqterm(); }
/* and: a b -- a & b */
#define and() { push (pop() & pop()); }
/* or: a b -- a | b */
#define or() { push (pop() | pop()); }
/* xor: a b -- a ^ b */
#define xor() { push (pop() ^ pop()); }
/* sp@: push the stack pointer */
#define spfetch() { push (csp); }
/* sp!: load initial value into SP */
#define spstore() { csp = mem[S0]; }
/* rp@: fetch the return stack pointer */
#define rpfetch() { push (rsp); }
/* rp!: load initial value into RP */
#define rpstore() { rsp = mem[R0]; }
/* ;S: ends a colon definition. */
#define semis() { ip = rpop(); }
/* @: addr -- mem[addr] */
#define fetch() { push (mem[pop()]); }
/* C@: addr -- mem[addr] */
#define cfetch() { push (mem[pop()] & 0xff); }
/* push to return stack */
#define tor() { rpush(pop()); }
/* pop from return stack */
#define fromr() { push (rpop()); }
/* 0=: a -- (a == 0) */
#define zeq() { push ( pop() == 0 ); }
/* 0<: a -- (a < 0) */
#define zless() { push ( pop() < 0 ); }
/* +: a b -- (a+b) */
#define plus() { push (pop () + pop ()); }
/* MINUS: negate a number */
#define minus() { push (-pop()); }
/* drop: a -- */
#define drop() { pop(); }
/* DOCOL: push ip & start a thread */
#define docol() { rpush(ip); ip = w+1; }
/* do a constant: push the value at mem[w+1] */
#define docon() { push (mem[w+1]); }
/* do a variable: push (w+1) (the PFA) to the stack */
#define dovar() { push (w+1); }
/* execute a user variable: add UP to the offset found in PF */
#define douse() { push (mem[w+1] + ORIGIN); }
#define allot() { Callot (pop()); }
/* comparison tests */
#define equal() { push(pop() == pop()); }
/* not equal */
#define noteq() { push (pop() != pop()); }
/* DODOES -- not supported */
#define dodoes() { errexit("DOES> is not supported."); }
/* DOVOC -- not supported */
#define dovoc() { errexit("VOCABULARIES are not supported."); }
/* (BYE) -- exit with error code */
#define pbye() { exit(0); }
/* TRON -- trace at pop() depth */
#define tron() { trace = TRUE; tracedepth = pop(); }
/* TROFF -- stop tracing */
#define troff() { trace = 0; }
//go.sysin dd *
More information about the Mod.sources
mailing list