sources-request@genrad.UUCP (05/24/85)
This is posting one 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@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 - forth.doc'
sed 's/^X//' <<'//go.sysin dd *' >forth.doc
C-FORTH: a portable, C-coded figFORTH interpreter.
Written by Allan Pratt; completed April 1985.
This is a FORTH interpreter written entirely in portable C and FORTH. It
requires nothing more than a decent C compiler to use. It is not exactly
fast or efficient, but it is a true FORTH interpreter.
The features include:
Bootstrapping threaded definitions from a near-FORTH dictionary file.
Block file I/O.
Execution tracing and single-stepping.
Breakpoint detection, dumping the stack at the breakpoint.
Saving and automatic restoration of the FORTH environment.
Ability to convert the block file to a line-editor-compatible file, and back.
Included with the interpreter is a block file containing:
An UNTHREAD utility.
A screen editor with key-binding and cursor-addressing.
BRINGING UP THE INTERPRETER:
THIS FORTH MODEL REQUIRES "int"s TO BE TWICE THE SIZE OF "short"s,
and "short"s to be 16 bits. I realize this is a barrier to portability,
but you can change occurrances of "int" to "long" and "short" to "int" if
"long"s are twice the size of "int"s.
Note also that model sizes greater than 32K (with 16-bit cells) are likely
to fail because of the sign bit. This has not been adequately tested.
The first four sections of the file "common.h" contain implementation-dependent
constants. These are TRACE, BREAKPOINT, several default file names, INITMEM,
MAXMEM, and NSCR. As distributed, the FORTH system will work on most systems,
but especially virtual-memory systems. If you do not have virtual memory, you
will want to change MAXMEM -- see common.h for instructions.
Once you've configured common.h to your taste, compile the files with
touch lex.yy.c
make all
Note that lex.yy.c is lex output from forth.lex, slightly modified (using
sed). lex.yy.c is included in the distribution because not everybody has
lex and sed. You touch lex.yy.c before make-ing so make doesn't try to remake
it.
This make will create several files. Notable among them are "nf", the
bootstrapper, "forth.core", the core-image output of nf, and "forth", the
interpreter itself. Finally, there are two utility filters, b2l and l2b. These
convert files from block format to line format and back (b2l --> block to
line). A line-format file is one suitable for editing with vi or emacs: it
consists of a header line for each screen, followed by 16 newline-separated
lines of text for that screen, followed by the next screen. THERE MUST ALWAYS
BE SIXTEEN LINES BETWEEN HEADERS in the line file, or l2b won't work properly.
You must use l2b to create the block file "forth.block" from "forth.line". Use:
l2b < forth.line > forth.block
to do this. If you don't have I/O redirection, I'm afraid you'll have to
patch these programs (and lex.yy.c and nf.c, for that matter) to take
arguments or use default files.
Note that "forth.block" is the default block file used by FORTH. You can change
this default in "common.h", and you can change it on the FORTH command line
with -f.
Now that you have the interpreter ("forth"), the block file
("forth.block"), and the core file ("forth.core"), you are ready to
roll. Invoke FORTH with the following line to the C-shell:
stty -echo cbreak ; forth ; stty echo -cbreak
Some notes while running FORTH:
The backspace character is ^H, no matter what your terminal is set for. When
you backspace, ASCII 8 gets sent to the screen, so the cursor should back up
but not erase the letter you're backing up over. There is no kill character
to wipe out an entire line. If you backspace beyond the beginning of the line,
you will get a beep.
Don't use tabs; FORTH doesn't recognize them as whitespace.
Everything in the FORTH world is upper-case. Use caps-lock if you have one.
The VLIST command lists the FORTH vocabulary.
Some commands, like LIST and VLIST, use the FORTH word ?TERMINAL to see
if the user wants to quit. Use your interrupt character (usually ^C) to
stop these commands. If you hit ^C twice before ?TERMINAL is checked,
then you'll get an ABORT back to the FORTH top level. If the FORTH program
is waiting for keyboard input, you'll have to hit ^C twice and then hit
a normal key to see this effect. Your Quit character (often ^\) still works
to get you back to your shell.
When you start FORTH up, it will tell you the number of blocks in the
block file (either the default or the one you specified with -f). You can
see a block with the LIST command: "3 LIST" will list block number 3. Block
zero is special: because of a bug in the FORTH standard model, you can't
see block zero until you've accessed many other blocks (where "many" is the
number NSCR from "common.h").
In any case, you can load the UNTHREAD utility (see below) with "1 LOAD"
(because it starts on block 1), and the editor with "10 LOAD".
XFORTH uses "setbuf(stdout,0)" in "forth.c" to force standard output to
be unbuffered. If this call doesn't work for you, just remove it, and
standard output will be line buffered. If that is the case, change
EXPECT (in "forth.dict"): replace the EMIT call with DROP. Then you can
call forth directly, without the stty stuff. You use your own erase and kill
characters, but the editor won't work.
SAVING THE FORTH ENVIRONMENT:
When you have been working in FORTH for a while, you will have developed
words which you'd like to save, without having to reload them from the
block file all the time. The word SAVE will save the current core image on
a file, normally "forth.newcore", and exit. The -s flag changes the save
file name.
When you start FORTH, the core file (either "forth.core" or the one specified
with -c) is checked to see if it is a saved image or a bootstrapped image.
If it's a saved image, execution begins from the spot it left off from.
If it's bootstrapped (fresh out of nf), execution begins at COLD.
SUMMARY OF COMMAND-LINE OPTIONS:
-t[n] trace; n is a digit from 0 to 9, default 0.
Each time through the inner interpreter, a line will be printed
out showing the current stack pointer, the top n stack elements
(topmost at the left), the current interpretive pointer (ip), an indent
to reflect the current nesting depth (actually the return-stack depth),
and the name of the word about to be executed. N is the "trace depth";
see DOTRACE below.
-d[n] debug; n is a digit from 0 to 9, default 0.
Like -t, -d prints out the trace line each time through the inner
interpreter. Unlike -t, it will then wait for input from the terminal. If
you hit newline (Return, CR, etc.) it will proceed. If you type any key
followed by newline, it will dump the current memory image to the dump file,
usually "forth.dump", and then continue.
-n no setbuf.
If -n is present, the setbuf(stdout,NULL) call which makes stdout
unbuffered instead of line-buffered will not be executed. This is useful if
you intend to do debugging with -t, -d, or the TRON command (see below).
-p xxxx breakPoint.
Breakpoints are enabled, and one is set at address xxxx (in hex).
Each time through the inner interpreter, the ip address is checked against
this breakpoint address. If they match, "Breakpoint" is printed, along with
the current stack pointer and the entire contents of the stack, with the
topmost element at the left.
-c corename set the core file name
The memory image will be read from this file instead of the default,
which is usually "forth.core".
-b blockname set the block file name
This file will be used as the block file for disk reads and writes,
instead of the default block file, which is usually "forth.block".
-s savename set the core-save file name
This file will be created or overwritten upon execution of the (SAVE)
primitive (which is called by the SAVE command). It will contain a core image
(just like forth.core or the -c name) which reflects the current status at the
time of the save. If this file is used as input (renamed to "forth.core" or
used in -c later), the FORTH system will restart right where it left off.
Note that -c and -s MAY use the same name.
DEPARTURES FROM THE figFORTH-79 STANDARD:
---------- ---- --- -------- -- --------
There are two features of the FORTH-79 standard which are unimplemented in
this system: the <BUILDS ... DOES> construct and VOCABULARIES. Both of these
are unimplemented simply because I couldn't understand the documentation
sufficiently to implement them. In any case, they do not affect the operation
of FORTH, except inasmuch as the dictionary is simply a flat stack structure,
and defining-words using DOES simply don't work.
EXTENSIONS FROM THE figFORTH-79 STANDARD:
---------- ---- --- -------- -- --------
I grew a FORTH implementation from the Z80 figFORTH standard, and found the
following extensions to be vital to my sanity as a programmer and developer.
CASE c1 OF action1 ENDOF c2 OF action2 ENDOF default-action ENDCASE
This construct comes from Doctor Dobb's Journal, Number 59, September, 1984,
in an article by Ray Duncan.
I used to find that nesting IFs to emulate a CASE structure was the most
difficult part of programming in FORTH, but now I don't have to mess with
it any more.
\ (backslash)
This word begins a comment which extends to the end of the current line.
This is only meaningful while loading, and causes an error if you are not
loading. It amounts to an open-paren where the end of the line is the closing
paren. This, too, comes from Dr. Dobb's Journal, Number 59, in a different
article, by Henry Laxen.
TRON, TROFF, DOTRACE
These provide tracing facilities for C-FORTH. TRON takes one parameter, which
is the number of stack elements to show. TROFF disables tracing. DOTRACE
traces once, using the most recent depth value (from TRON or -tn on the command
line). TRON will have no effect (but will still consume its argument) if
the FORTH system was compiled without the TRACE flag set. DOTRACE, however,
will still trace one line as advertised.
REFORTH
This word is useful when loading screens, to get the user's input. It
reads one line from the terminal (with QUERY) and interprets it (with
INTERPRET), then returns to the caller. This is used in the editor (see
below) to read in the user's terminal type. This is yet another construct
from Ray Duncan's article in Dr. Dobb's Journal, Number 59.
ALIAS usage: ALIAS NEW OLD
This word is used to change the meaning of an existing word, after it
has been used in defining other words. Say you want to change EMIT so
it forces a CR when the current column (user var OUT) equals the number
of characters per line (constant C/L). The current definition of EMIT
is:
: EMIT
(EMIT)
1 OUT !+
;
You could define a new word, NEWEMIT, as follows:
: NEWEMIT
OUT @ C/L = IF
CR
THEN
(EMIT)
1 OUT +!
;
and use ALIAS NEWEMIT EMIT to make all previous references to EMIT execute
NEWEMIT instead. This is accomplished by making the definition of EMIT read:
: EMIT
NEWEMIT
;
(Note that my CR sets OUT to zero, so this really would work.)
NOTES ON THE BOOTSTRAP DICTIONARY:
----- -- --- --------- ----------
The contents of forth.dict describe the initial FORTH dictionary. There are
several types of things in this file; they will be described by example.
PRIM (EMIT) 12 (primitive)
This declares a primitive called "(EMIT)", with an execute-code of 12. This
execute-code is an index into the great switch statement in the inner
interpreter, next(). In a real FORTH system, this would be an address where
the actual code for the (EMIT) primitive resided.
To add primitives, you must do the following:
1. Add the primitive to forth.dict, using an unused execute-code.
2. Come up with a name for that primitive which is a legal C identifier.
Convention for parenthesis, like (EMIT), is PEMIT. For brackets, BEMIT.
For slash (like "C/L") is CSLL, where SL stands for slash.
3. Add the C identifier name to "forth.h", with the execute-code as its
value, like this:
#define PEMIT 12
4. In "prims.c", add the code for the primitive, as a function with
the same name as the #define above, except in lower case:
pemit()
{
putchar(pop());
}
5. In "forth.c", tack another case onto the switch statement in next():
case PEMIT: pemit(); break;
6. Recompile (preferably with make). You will need to recompile everything
but nf (which uses nf.c, lex.yy.c, and common.h, none of which you
changed). That is, you need to regenerate "forth" from forth.c, prims.c,
forth.h, and prims.h, and "forth.core" by throwing "forth.dict" at nf.
There is one special primitive: EXECUTE must be primitive number zero, since
it violates structure and jumps into the middle of next(). It is handled as
a special case in the code for NEXT, and it must be primitive number zero.
So much for primitives; there are other things in the forth.dict file:
CONST C/L 64 (constant)
Define constants with the word CONST followed by the name of the constant
and its value.
USER OUT 36 (user variable)
Define user variables with the word USER followed by the name of the variable
followed by the offset in the user-variable list of that variable.
The cold-start values for user variables are defined in common.h; they
get copied into the initial forth.dict by nf, into the "cold-start defaults"
area of memory. They are copied from there into the first few user-variable
locations by COLD.
VAR USE 0 (variable)
Define variables with the word VAR followed by the name of the variable
followed by its initial value.
: EMIT (colon-definition)
Begin colon-definitions with a colon (of course), followed by the name of
the word. Follow that with the words which make up the definition, ending
with ; for normal words or ;* for immediate words.
There are two special colon-definitions: {NULL} and COLD. {NULL} is a special
symbol which, when it is the name for a colon-definition, gets translated into
a single null byte; the special name '\0'. This is necessary since you
can't type a null byte into a file, and C would mess up anyway, thinking
the null was a terminator and not part of the string. COLD is a special word
in that it MUST BE DEFINED. The bootstrapper, nf, compiles the CFA of COLD
into a special place in low memory, where the interpreter knows it can
start executing threaded code.
LABEL
Labels are used as the targets of branches. They are handled in much the
same way as colon definitions and other words in the dictionary, in terms
of forward referencing and so on. For this reason, LABELS MUST BE UNIQUE
WORDS. You can't have a label which is the same as any other word in the
dictionary, or you'll get a "word redefined" error (or worse!).
Since the "nf" preprocessor does not execute FORTH code, it does not
have the higher-level FORTH constructs like begin .. until or
do .. loop. These must be implemented by the user, using the primitives
BRANCH (unconditional branch), 0BRANCH (branch on top-of-stack == 0),
(DO) (start a DO construct), and (LOOP) and (+LOOP) (the primitives
which end loop constructs). Each of BRANCH, 0BRANCH, (LOOP), and (+LOOP)
should be followed by one of two things: a signed offset, where a zero
offset branches to the address of the BRANCH (etc.) instruction; or
a label tag, which will be compiled as the appropriate offset from the
current location.
A FORTH word with a loop might look like this:
: ONE-TO-TEN
10 0 DO
I .
LOOP
;
This would be entered into the "forth.dict" file as follows:
: ONE-TO-TEN
LIT 10 0 (DO)
LABEL LOOP1
I .
(LOOP) LOOP1
;
Note the placement of the LABEL directive AFTER the (DO). Note also the use
of LIT before 10, but not before 0. See below under LIT for more details.
The branches are used to implement IF ... ELSE ... ENDIF constructs, as
well as conditional looping like BEGIN ... WHILE ... REPEAT and
BEGIN ... UNTIL. Ordinary programming practices are called for here,
with such standbys as branching over the "TRUE" branch of the IF when
the predicate is false, and branching over the "FALSE" part after the
TRUE part has executed (if the predicate was true). If you need more
guidance, study forth.dict, or don't bother.
" (quotation mark)
The quotation mark begins and ends a "STRING LITERAL", which is compiled
into the dictionary as a count byte followed by the bytes in the string,
from left to right. This is useful for the primitive (."), which expects
a string of this form to follow it in the dictionary. Within quotation
marks, a backslash (\) will escape any character, including a quotation
mark or another backslash, so:
"He said, \"Backslash (\\) is best.\""
produces
[33] He said, "Backslash (\) is best."
where [33] is the length count.
Note that backslash escape conventions like \n, \t, etc. DO NOT WORK
IN STRING LITERALS. This is a bug, not a feature.
'x' (character literal surrounded by apostrophes)
Character-literal translation is done between single quotes, with the
following effects:
Text produces
'A' the value of the character A.
'\b' system-dependent backspace character
'\f' form-feed
'\n' newline
'\r' carriage return
'\t' tab
'\\' the value of the character backslash
''' the value of the character apostrophe.
These values are only meaningfully used after LIT commands; see below.
LIT
LIT must be used before all literal values in the dictionary, just as it
is used (though the user doesn't see it) when words are defined. The
forth.dict file, after all, represents a de-compiled FORTH memory image.
It has all the BRANCHes and (LOOP)s showing, and it also has LITs showing.
In the above example for looping, LIT was used before 10, but not before
0. This is because "0" is defined a a CONSTant earlier in the forth.dict
file. To keep this straight, you should keep the following in mind:
When you are in the middle of a definition, each word you type will have
its CFA compiled into the dictionary. If the word you type is not defined
yet, nf looks at its "hint" about the string of characters: do they form a
number, like a one and a zero form ten? Do they form a hexadecimal number,
like 0x10? Is it an octal literal, like 077? Is it a character literal,
like 'A'? If none of these is the case, then a zero is compiled as a place
holder, and the word is considered a FORWARD REFERENCE to something yet to
be defined.
Yes, forward references are handled, and the distinction of
defined words and labels is preserved: labels, instead of compiling their
CFA into the dictionary, compile the offset of their CFA from the current
dictionary pointer (minus one). If, at the end of the input file, there
are still unresolved forward references, they will be listed. If the
words containing the forward references are never executed, there will
be no problem. If those words ARE executed, FORTH will bomb with a message
like "Attempt to execute illegal primitive."
One snag is that you have to remember what numbers are defined as CONSTants,
and what numbers aren't. If nf sees "LIT 1" it will compile the CFA of LIT,
then the CFA of 1, because 1 has already been defined as a constant.
LIT must precede decimal, hex, octal, and character literals, but not
string literals. If one of these literals is not preceded by LIT, a
warning is issued, since this is unusual behavior. No warning is issued
if LIT is succeeded by something other than a literal-class item, because
that is not so unusual.
INSTALLER'S GUIDE FOR THE SCREEN EDITOR:
--------- - ----- --- --- ------ ------
This is an editor which I wrote on my Osborne 1, which has a memory-mapped
display. I hacked out that part and hacked in the screen updating using .LINE,
but at anything lower than 9600 BAUD I expect this to be intolerable.
When you get FORTH at your site, you will have to edit the line-file to
include functions which clear the screen, locate the cursor, and enter and
exit standout mode, named CLS, LOCATE, STANDOUT, and STANDEND, respectively.
The trick for installing this is to put those functions in an unused screen
(screens 8 and 9 are perfect for this), and place a CONSTANT in screen 10
which is the name of the terminal (like "H19" or "ACT5") and has a value
which is the number of the screen you put its definition in. VT100 and
ADM5 are included as models, in screens 6 and 7. ADM5 actually covers
a broad range of terminals, from the old ADM3A to the TVI920C, though
standout might not work the same any more. The two words STANDOUT and
STANDEND can be null words, anyway.
USER'S GUIDE FOR THE EDITOR:
---- - ----- --- --- ------
This is a screen editor for FORTH screens. It will alter the file
"forth.block" in the current directory, or whatever the installer set
the default blockfile to be, or whatever you specify on the command
line with the "-b file" switch.
You call a screen up with the EDIT command:
3 EDIT
will begin editing screen 3. The file starts with screen 0, but, due to
a bug in figFORTH which I have carefully preserved (:-), you can't see
screen 0 until you've edited several others -- as many as fit in memory,
in fact. This number is 5 at the outset, but can be as low as 2 or as
many as your installer's whim dictated. In any case, stick with screens
numbered from 1 to the size of the block file as displayed when you
started FORTH.
When you start editing, the screen will clear, and the screen you asked
for will appear. FORTH "screens" are, by convention and convenience,
sixteen lines by sixty-four characters, for a total of 1K per screen.
At the bottom of the screen being edited will be the word SCREEN and
this screen's number.
The keys (as I've distributed the editor) match WordStar, to some extent.
The cursor movement keys do, at any rate: ^E, ^D, ^X, ^S form a movement
triangle at the left-hand side of the keyboard, moving one character or
line at a time. The outer reaches of this triangle move even farther:
^A and ^F move one word backward and forward, and ^R and ^C move one
SCREEN backward and forward. If ^C is already your interrupt character,
don't panic: use ESC-C (escape is a meta-prefix like in Emacs). If your
network won't let you send ^S (like Sytek), ^H will do for backspace.
To see all the key bindings, use the FORTH command DESCRIBE-BINDINGS.
To make a binding, do this:
1. Type "BIND-TO-KEY function <CR>" where function is the name
of the command you want bound to a key, and <CR> means press
return/newline.
2. The computer will print "KEY: " at which time you should
strike the key you want to have that function bound to.
If you want something bound to ESC plus something, just press
escape followed by the key, exactly as you intend to use the
key in practice.
To see the binding for one key, use the command DESCRIBE-KEY. Again,
you will be asked for the key you want described. Strike the key just
as you normally do, with ESC before it if necessary.
The initial bindings are on screens 27 and 28 of the block file.
The editor is always in replace mode. That is, when you strike a key, it
overwrites whatever was under the cursor. There is no insert mode; I haven't
gotten around to that.
As you go around changing things, you are only changing the image of the
screen which FORTH keeps in memory; you are not changing the block file.
You can mark the current screen for updating to the blockfile with ^U.
This only marks the screen; it won't be written to the blockfile until
the space is needed again, or you explicitly FLUSH the memory buffers.
Use ESC-F (press escape, then press capital F) to mark the current screen
for updating, and then FLUSH all marked screens (including this one, now)
to the block file. Once you've done that, the change is permanent.
If you really mean to make a given change to a screen, mark it as updated
(^U) right away. Countless hours have been wasted changing screens without
marking them for writing, and then having that memory reused -- the changes
are lost.
You can leave the editor with ESC-Q (for Quit). Be sure to do an ESC-F
before you do, if you want to save what you have. You can never be sure
if your changes will get written out if you don't. (Yes, I know this
is an oversimplification.)
You can leave FORTH by typing BYE.
XFINAL NOTES FROM THE AUTHOR:
----- ----- ---- --- ------
XFORTH runs slowly. If anybody can make this turkey fly (without, of course,
rewriting it in assembly language), more power to you. It was done as a
Junior project at Indiana University, but in fact I learned more about
project management and programmer/systems staff interaction than I did
about implementing FORTH (which I had done previously in 8080 assembly
code). In that sense it was profitable, and, since it works, I see no reason
not to distribute it to the network. If you have comments of praise,
I can be reached through the summer of 1985 at the address below;
after that, I MAY be at iuvax!apratt. Comments of another nature
are not enthusiastically solicited, and I do NOT expect to upgrade this
implementation AT ALL, EVER. Sorry, but there will be no "Version 2" for
this baby. If I have left crucial points out of this documentation,
and my (hopefully-well-commented) code doesn't provide the answer,
I will reply and possibly improve this documentation. But for the
most part, you're on your own.
As a parting shot, the inner interpreter's "switch" statement could
be replaced by an array of functions, using the variable p as an
index. I was not that ambitious, and I don't know if it would be faster
than the table-lookup which my C compiler generates.
-- Allan Pratt
APRATT.PA@XEROX.ARPA
QUICK SUMMARY OF FILES (THERE IS A MESS OF THEM!)
Makefile supposed to bring them all together
b2l.c and b2l filter to convert block-files into line-files for editing
l2b.c and l2b filter to convert line-files into block-files for FORTH
common.h This is a header file with configuration and common information
used by all C source files except lex.yy.c
forth.h Header file with primitive numbers in it, among other things
forth.c source code for the guts/support functions for the interpreter
prims.h Header file with macro definitions for primitives
prims.c source code for primitives too complex for macros
The above four files, plus common.h, contribute to the
executable "forth"
nf.c source for the bootstrapper, which interprets the dictionary
and generates an initial memory image for FORTH
forth.lex lex input for lexical analyzer used by nf.c
forth.lex.h header file used by lex.yy.c and nf.c
lex.yy.c lex output, modified (look at the Makefile)
The above four files, plus common.h, contribute to the
executable "nf", the preprocessor.
forth.block This is the (default) block-file used by FORTH for its
editing- and load-screens
forth.line This file usually resembles forth.block, but is in a
format suitable for editing with emacs or vi: a header
line, followed by sixteen lines of trailing-blank-
truncated, newline-terminated text for each screen.
If one of forth.line and forth.block is out of date with
respect to the other, you can bring it back up to date
with b2l or l2b, above.
forth.dict This is a human-readable, pseudo-FORTH dictionary which
nf uses to generate the initial environment. It contains
forward references and no higher structures like DO..LOOP
forth.core This is one output of nf: it contains the core image for
the FORTH environment, as dictated by common.h and forth.dict
forth.newcore This is the file for holding core images saved with the (SAVE)
primitive. If FORTH is started with "-c forth.newcore", the
image is restarted right where it left off.
forth.map This is another output of nf: it contains a human-readable
dump of the forth environment which nf generated. This can
be compared with the post-mortem dump which FORTH generates
in forth.dump in certain cases.
//go.sysin dd *sources-request@genrad.UUCP (05/24/85)
This is posting two 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@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 - Makefile'
sed 's/^X//' <<'//go.sysin dd *' >Makefile
test: forth.core forth
forth: forth.o prims.o
cc -o forth forth.o prims.o
forth.o: forth.c common.h forth.h prims.h
cc -c forth.c
prims.o: prims.c forth.h prims.h
cc -c prims.c
all: forth forth.core l2b b2l
nf: nf.o lex.yy.o
cc -o nf nf.o lex.yy.o
nf.o: nf.c forth.lex.h common.h
cc -c nf.c
lex.yy.o: lex.yy.c forth.lex.h
cc -c lex.yy.c
lex.yy.c: forth.lex
lex forth.lex
rm -f lex.tmp
sed "s/yylex(){/TOKEN *yylex(){/" lex.yy.c > lex.tmp
mv -f lex.tmp lex.yy.c
forth.core: nf forth.dict
nf < forth.dict
# l2b: convert a line file to a block file. Usage: l2b < linefile > blockfile
l2b: l2b.c
cc -o l2b l2b.c
# b2l: convert a block file to a line file. Usage: b2l < blockfile > linefile
b2l: b2l.c
cc -o b2l b2l.c
# forth.line and forth.block are not included here, because you can't tell
# which one is more recent. To make one from the other, use b2l and l2b.
//go.sysin dd *
echo 'x - b2l.c'
sed 's/^X//' <<'//go.sysin dd *' >b2l.c
X/* usage: block2line < blockfile > linefile
* takes a block file from stdin and makes a cr-delimited file to stdout
* with 64 characters per line, 16 lines per screen
*/
#include <stdio.h>
main()
{
int i, j, screen;
char buf[64]; /* max line size */
while(1) {
printf("------------------ SCREEN %d ------------------\n",
screen++);
for (i=0; i<16; i++) {
if (fread(buf,sizeof(char),64,stdin) < 64) exit(0);
j = 63;
while (buf[j] == ' ' && j >= 0) j--;
if (j >= 0) fwrite(buf,sizeof(char),j+1,stdout);
putchar('\n');
}
}
}
//go.sysin dd *
echo 'x - common.h'
sed 's/^X//' <<'//go.sysin dd *' >common.h
X/*
* This is common.h -- the defines which are common to both nf.c and forth.c.
* These include the name of the SAVEFILE (the file which nf.c creates,
* and the default image which f.c loads), and all those boundaries for
* memory areas, like UP, USER_DEFAULTS, etc.
*/
X/*
* NOTE THAT THIS FORTH IMPLENTATION REQUIRES int TO BE TWICE THE SIZE OF short
*/
#define TRUE 1
#define FALSE 0
X/*
TWEAKING: define TRACE to allow tracing, BREAKPOINT to allow breakpoints.
Each of these takes up time in the inner interpreter, so if you are
not debugging, take them out. Without TRACE, the DOTRACE primitive will
still work, but the TRON primitive will have no effect.
*/
#define TRACE
#define BREAKPOINT
X/* external files */
#define COREFILE "forth.core" /* used for input to f.c, output from nf.c */
#define DICTFILE "forth.dict" /* used for input to nf.c */
#define MAPFILE "forth.map" /* used for dump-output from nf.c */
#define DUMPFILE "forth.dump" /* used for dump-output from f.c */
#define BLOCKFILE "forth.block" /* used for block i/o */
#define SAVEFILE "forth.newcore" /* used by (SAVE) primitive */
X/* MEMORY ALLOCATION CONSTANTS */
X/* Set INITMEM to the size of the largest FORTH model you want nf to create.
This can be just barely enough (within GULPFRQ words) to hold the initial
FORTH image, or it can be the maximum size you will ever want. Somewhere in
between is best, so you don't fragment memory with realloc() calls right
away. */
#define INITMEM (13*1024) /* 13K holds the distribution forth.dict */
X/* set MAXMEM to the MOST MEMORY YOU EVER WANT ALLOCATED TO FORTH. FORTH will
never allocate more than MAXMEM*sizeof(short) for the FORTH memory image.
Note that other functions, like open, read, and write, allocate memory
transparent to the forth system. MAXMEM will not affect these. Also,
note that realloc is used to grow the FORTH image, and LARGE CHUNKS of
fragmented memory can result. If you want to keep a tight rein on things,
set MAXMEM to the same number as INITMEM, and the FORTH memory image will
be fixed at that many SHORTs, with no later allocations, and therefore
no fragmenting.
A value of 0 for MAXMEM means "allocate as much as you want" --
useful on virtual-memory machines. Also note that each malloc and realloc
is checked for success (of course), so MAXMEM is truly a maximal limit.
NOTE THAT MODELS OF GREATER THAN 32K MAY CRASH BECAUSE OF SIGNED
VALUES. THIS HAS NOT BEEN ADEQUATELY TESTED.
*/
#define MAXMEM 0
X/* set NSCR to the number of disk blocks from you want to keep in FORTH memory
at any time. If your disks are fast enough, you might want a low number
like 3. If you have lots of memory, you might want something like 10.
In any case, this number MUST BE AT LEAST 2. */
#define NSCR 5 /* MUST BE AT LEAST 2 */
X/* end of implementation-dependent DEFINEs. */
X/* define bits for the first byte of each word */
#define MSB 0x80 /* says this is first byte */
#define IMMEDIATE 0x40 /* Says this word is immediate */
#define SMUDGE 0x20 /* on = you can't find this word */
#define MAXWIDTH 0x20 /* Maximum length of a word */
#define KBBUFF 1024 /* one disk-quantum */
#define US 32 /* words needed for user variables */
#define CO (KBBUFF+4)
/* size of a disk buffer w/4 words overhead */
#define NBUF NSCR /* number of disk buffers, at 1 to a screen */
X/* Memory Management boundaries -- each name refers to the FIRST location of
the indicated field Some fields are nested, and I have tried to show the
nesting nature in the defines. */
#define ORIGIN 0 /* the Origin of this system is zero */
#define ORIG ORIGIN /* another word for ORIGIN */
#define SCRATCHSIZE 16 /* From ORIGIN to ORIGIN+SCRATCHSIZE is scratch
space which is saved across saves: see the
definition of this space below */
#define USER_DEFAULTS (ORIGIN+SCRATCHSIZE) /* 16 */
/* start of user variable initial-values space
-- it's DEFS-SIZE bytes long */
#define DEFS_SIZE 8 /* words in the USER DEFAULTS area */
#define UP (USER_DEFAULTS+DEFS_SIZE) /* User var space, US bytes long */
#define TIB_START (UP+US) /* Terminal input buffer, same size as a
disk buffer (KBBUFF words), starts after
user variables */
#define TIB_END (TIB_START + KBBUFF)
#define CS_SIZE 128 /* words in the Computation Stack */
#define RS_SIZE 256 /* words in the Return Stack */
#define INITS0 (TIB_START+KBBUFF+CS_SIZE) /* c. stack grows down CSS words,
bangs into end of TIB */
#define INITR0 (INITS0+RS_SIZE) /* Return stack grows down RSS words, bangs
into INITS0. */
#define BUF1 INITR0 /* buffers start right after r. stack */
#define DPBASE (BUF1+(NBUF*CO)) /* Dictionary starts just past last buffer */
X/* low-core definitions */
#define LIMIT 0 /* mem[LIMIT] tells the size of core */
#define COLDIP 1 /* mem[COLDIP] holds the CFA of ABORT */
/* you can set ip=mem[COLDIP] and call next() to start */
X/* these locations define the warm-start machine state: if you save the FORTH
memory image, then restart it, execution will start up with these values.
This save/restore system is not implemented, so leave mem[SAVEDIP] = 0. */
#define SAVEDIP 2 /* mem[SAVEDIP] = 0 for newly-generated
systems, or the IP for a saved system */
#define SAVEDSP 3 /* restored when SAVEDIP != 0 */
#define SAVEDRP 4 /* ditto */
#define ABORTIP 5 /* need this to recover from ^C */
//go.sysin dd *
echo 'x - forth.c'
sed 's/^X//' <<'//go.sysin dd *' >forth.c
X/*
* forth.c
*
* Portable FORTH interpreter in C
*
* Author: Allan Pratt, Indiana University (iuvax!apratt)
* Spring, 1984
* References: 8080 and 6502 fig-FORTH source listings (not the greatest refs
* in the world...)
*
* This program is intended to be compact, portable, and pretty complete.
* It is also intended to be in the public domain, and distribution should
* include this notice to that effect.
*
* This file contains the support code for all interpreter functions.
* the file prims.c contains code for the C-coded primitives, and the
* file forth.h connects the two with definitions.
*
* The program nf.c generates a new forth.core file from the dictionary
* forth.dict, using common.h to tie it together with this program.
*/
#include <stdio.h>
#include <signal.h>
#include <ctype.h> /* only for isxdigit */
#include "common.h"
#include "forth.h"
#include "prims.h" /* macro-defined primitives */
X/* declare globals which are defined in forth.h */
unsigned short csp, rsp, ip, w;
short *mem;
int trace, tracedepth, debug, breakenable, breakpoint, qtermflag, forceip;
int nobuf;
XFILE *blockfile;
long bfilesize;
char *bfilename; /* block file name (change with -f ) */
char *cfilename; /* core file name (change with -l ) */
char *sfilename; /* save file name (change with -s ) */
X/*
----------------------------------------------------
SYSTEM FUNCTIONS
----------------------------------------------------
*/
errexit(s,p1,p2) /* An error occurred -- clean up (?) and
exit. */
{
printf(s,p1,p2);
printf("ABORT FORTH!\nDumping to %s... ",DUMPFILE);
fflush(stdout);
memdump();
puts("done.");
exit(1);
}
Callot (n) /* allot n words in the dictionary */
short n;
{
unsigned newsize;
mem[DP] += n; /* move DP */
if (mem[DP] + GULPFRQ > mem[LIMIT]) { /* need space */
newsize = mem[DP] + GULPSIZE;
if (newsize > MAXMEM && MAXMEM)
errexit("ATTEMPT TO GROW PAST MAXMEM (%d) WORDS\n",MAXMEM);
mem = (short *)realloc((char *)mem, newsize*sizeof(*mem));
if (mem == NULL)
errexit("REALLOC FAILED\n");
mem[LIMIT] = newsize;
}
}
push(v) /* push value v to cstack */
short v;
{
if (csp <= TIB_END)
errexit("PUSH TO FULL CALC. STACK\n");
mem[--csp] = v;
}
short pop() /* pop a value from comp. stack, and return
it as the value of the function */
{
if (csp >= INITS0) {
puts("Empty Stack!");
return 0;
}
return (mem[csp++]);
}
rpush(v)
short v;
{
if (rsp <= INITS0)
errexit("PUSH TO FULL RETURN STACK");
mem[--rsp] = v;
}
short rpop()
{
if (rsp >= INITR0)
errexit("POP FROM EMPTY RETURN STACK!");
return (mem[rsp++]);
}
pkey() /* (KEY) -- wait for a key & return it */
{
int c;
if ((c = getchar()) == EOF) errexit("END-OF-FILE ENCOUNTERED");
return(c);
}
pqterm() /* (?TERMINAL):
return true if BREAK has been hit */
{
if (qtermflag) {
push(TRUE);
qtermflag = FALSE; /* this influences ^C handling */
}
else push(FALSE);
}
pemit() /* (EMIT): c -- emit a character */
{
putchar(pop() & 0x7f); /* stdout is unbuffered */
}
next() /* instruction processor: control goes here
almost right away, and cycles through here
until you leave. */
X/*
* This is the big kabloona. What it does is load the value at mem[ip]
* into w, increment ip, and invoke prim. number w. This implies that
* mem[ip] is the CFA of a word. What's in the CF of a word is the number
* of the primitive which should be executed. For a word written in FORTH,
* that primitive is "docol", which pushes ip to the return stack, then
* uses w+2 (the PFA of the word) as the new ip. See "interp.doc" for
* more.
*/
X/*
* There is an incredible hack going on here: the SPECIAL CASE mentioned in
* the code is for the word EXECUTE, which must set W itself and jump INSIDE
* the "next" loop, by-passing the first instruction. This has been made a
* special case: if the primitive to execute is zero, the special case is
* invoked, and the code for EXECUTE is put right in the NEXT loop. For this
* reason, "EXECUTE" MUST BE THE FIRST WORD IN THE DICTIONARY.
*/
{
short p;
while (1) {
if (forceip) { /* force ip to this value -- used by sig_int */
ip = forceip;
forceip = FALSE;
}
#ifdef TRACE
if (trace) dotrace();
#endif TRACE
#ifdef BREAKPOINT
if (breakenable && ip == breakpoint) dobreak();
#endif BREAKPOINT
w = mem[ip];
ip++;
/* w, mem, and ip are all global. W is now
a POINTER TO the primitive number to
execute, and ip points to the NEXT thread to
follow. */
next1: /* This is for the SPECIAL CASE */
p = mem[w]; /* p is the actual number of the primitive */
if (p == 0) { /* SPECIAL CASE FOR EXECUTE! */
w = pop(); /* see above for explanation */
goto next1;
}
/* else */
switch(p) {
case LIT : lit(); break;
case BRANCH : branch(); break;
case ZBRANCH : zbranch(); break;
case PLOOP : ploop(); break;
case PPLOOP : pploop(); break;
case PDO : pdo(); break;
case I : i(); break;
case R : r(); break;
case DIGIT : digit(); break;
case PFIND : pfind(); break;
case ENCLOSE : enclose(); break;
case KEY : key(); break;
case PEMIT : pemit(); break;
case QTERMINAL : qterminal(); break;
case CMOVE : cmove(); break;
case USTAR : ustar(); break;
case USLASH : uslash(); break;
case AND : and(); break;
case OR : or(); break;
case XOR : xor(); break;
case SPFETCH : spfetch(); break;
case SPSTORE : spstore(); break;
case RPFETCH : rpfetch(); break;
case RPSTORE : rpstore(); break;
case SEMIS : semis(); break;
case LEAVE : leave(); break;
case TOR : tor(); break;
case FROMR : fromr(); break;
case ZEQ : zeq(); break;
case ZLESS : zless(); break;
case PLUS : plus(); break;
case DPLUS : dplus(); break;
case MINUS : minus(); break;
case DMINUS : dminus(); break;
case OVER : over(); break;
case DROP : drop(); break;
case SWAP : swap(); break;
case DUP : dup(); break;
case TDUP : tdup(); break;
case PSTORE : pstore(); break;
case TOGGLE : toggle(); break;
case FETCH : fetch(); break;
case CFETCH : cfetch(); break;
case TFETCH : tfetch(); break;
case STORE : store(); break;
case CSTORE : cstore(); break;
case TSTORE : tstore(); break;
case DOCOL : docol(); break;
case DOCON : docon(); break;
case DOVAR : dovar(); break;
case DOUSE : douse(); break;
case SUBTRACT : subtract(); break;
case EQUAL : equal(); break;
case NOTEQ : noteq(); break;
case LESS : less(); break;
case ROT : rot(); break;
case DODOES : dodoes(); break;
case DOVOC : dovoc(); break;
case ALLOT : allot(); break;
case PBYE : pbye(); break;
case TRON : tron(); break;
case TROFF : troff(); break;
case DOTRACE : dotrace(); break;
case PRSLW : prslw(); break;
case PSAVE : psave(); break;
case PCOLD : pcold(); break;
default : errexit("Bad execute-code %d\n",p); break;
}
}
}
dotrace()
{
short worka, workb, workc;
putchar('\n');
if (tracedepth) { /* show any stack? */
printf("sp: %04x (", csp);
worka = csp;
for (workb = tracedepth; workb; workb--)
printf("%04x ",(unsigned short) mem[worka++]);
putchar(')');
}
printf(" ip=%04x ",ip);
if (mem[R0]-rsp < RS_SIZE && mem[R0] - rsp > 0) /* if legal rsp */
for (worka = mem[R0]-rsp; worka; worka--) { /* indent */
putchar('>');
putchar(' ');
}
worka = mem[ip] - 3; /* this is second-to-last letter, or
the count byte */
while (!(mem[worka] & 0x80)) worka--; /* skip back to count byte */
workc = mem[worka] & 0x2f; /* workc is count value */
worka++;
while (workc--) putchar(mem[worka++] & 0x7f);
fflush(stdout);
if (debug) { /* wait for \n -- any other input will dump */
char buffer[10];
if (*gets(buffer) != '\0') {
printf("dumping core... ");
fflush(stdout);
memdump();
puts("done.");
}
}
}
#ifdef BREAKPOINT
dobreak()
{
int temp;
puts("Breakpoint.");
printf("Stack pointer = %x:\n",csp);
for (temp = csp; temp < INITS0; temp++)
printf("\t%04x",mem[temp]);
putchar('\n');
}
#endif BREAKPOINT
main(argc,argv)
int argc;
char *argv[];
{
FILE *fp;
unsigned short size;
int i = 1;
cfilename = COREFILE; /* "forth.core" */
bfilename = BLOCKFILE; /* "forth.block" */
sfilename = SAVEFILE; /* "forth.newcore" */
trace = debug = breakenable = nobuf = 0;
while (i < argc) {
if (*argv[i] == '-') {
switch (*(argv[i]+1)) {
#ifdef TRACE
case 'd': /* -d[n] */
debug = 1; /* ...and fall through */
case 't': /* -t[n] */
trace = TRUE;
if (argv[i][2])
tracedepth = (argv[i][2] - '0');
else tracedepth = 0;
break;
#else !TRACE
case 'd':
case 't':
fprintf(stderr,
"Must compile with TRACE defined for -t or -d\n");
break;
#endif TRACE
case 'c': if (++i == argc) usage(argv[0]);
cfilename = argv[i]; /* -c file */
break;
case 's': if (++i == argc) usage(argv[0]);
sfilename = argv[i]; /* -s file */
break;
#ifdef BREAKPOINT
case 'p': if (++i == argc) usage(argv[0]);
breakenable = TRUE; /* -p xxxx */
breakpoint = xtoi(argv[i]);
break;
#else !BREAKPOINT
case 'p': fprintf(stderr,
"Must compile with BREAKPOINT defined for -p");
break;
#endif BREAKPOINT
case 'b': if (++i == argc) usage();
bfilename = argv[i]; /* -b blockfile */
break;
case 'n': nobuf = TRUE;
break;
default: usage(argv[0]);
exit(1);
}
}
else usage(argv[0]); /* not a dash */
i++;
}
if ((fp = fopen(cfilename,"r")) == NULL) {
fprintf(stderr,"Forth: Could not open %s\n", cfilename);
exit(1);
}
if (fread(&size, sizeof(size), 1, fp) != 1) {
fprintf(stderr,"Forth: %s is empty.\n",cfilename);
exit(1) ;
}
if ((mem = (short *)calloc(size, sizeof(*mem))) == NULL) {
fprintf(stderr, "Forth: unable to malloc(%d,%d)\n",
size, sizeof(*mem));
exit(1);
}
mem[LIMIT] = size;
if (fread(mem+1, sizeof(*mem), size-1, fp) != size-1) {
fprintf(stderr, "Forth: not %d bytes on %s.\n",
size, cfilename);
exit(1);
}
fclose(fp);
initsignals();
getblockfile();
if (!nobuf) setbuf(stdout,NULL);
if (ip = mem[SAVEDIP]) { /* if savedip != 0, that is */
csp = mem[SAVEDSP];
rsp = mem[SAVEDRP];
puts("restarting a saved FORTH image");
}
else {
ip = mem[COLDIP]; /* this is the ip passed from nf.c */
/* ip now points to a word holding the CFA of COLD */
rsp = INITR0; /* initialize return stack */
csp = INITS0;
}
next();
/* never returns */
}
usage(s)
char *s;
{
fprintf(stderr, "usage:\n");
fprintf(stderr, "%s [-t[n]] [-d[n]] [-p xxxx] [-n]\n",s);
fputs(stderr, "\t[-c corename] [-b blockname] [-s savename]\n");
fputs(stderr, "Where:\n");
fputs(stderr,
"-t[n]\t\tsets trace mode\n");
fputs(stderr,
"-d[n]\t\tsets trace mode and debug mode (waits for newline)");
fputs(stderr,
"\t\t[n] above sets stack depth to display. Single digit, 0-9. Default 0.\n");
fputs(stderr,
"-p xxxx\t\tsets a breakpoint at xxxx (in hex), shows stack when reached\n");
fputs(stderr,
"-n\t\tleaves stdout line-buffered\n");
fprintf(stderr,
"-c corename\tuses corename as the core image (default %s without -c)\n",
COREFILE);
fprintf(stderr,
"-b blockname\tuses blockname as the blockfile (default %s without -b)\n",
BLOCKFILE);
fprintf(stderr,
"-s savename\tuses savename as the save-image file (default %s without -s)\n",
SAVEFILE);
}
memdump() /* dump core. */
{
int i; /* top of RAM */
int temp, tempb, firstzero, nonzero;
char chars[9], outline[80], tstr[6];
FILE *dumpfile;
dumpfile = fopen(DUMPFILE,"w");
fprintf(dumpfile,
"CSP = 0x%x RSP = 0x%x IP = 0x%x W = 0x%x DP = 0x%x\n",
csp, rsp, ip, w, mem[DP]);
for (temp = 0; temp < mem[LIMIT]; 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(dumpfile,"%s %s\n",outline,chars);
firstzero = TRUE;
}
else if (firstzero) {
fprintf(dumpfile, "----- ZERO ----\n");
firstzero = FALSE;
}
}
fclose(dumpfile);
}
X/* here is where ctype.h is used */
xtoi(s)
char *s;
{ /* convert hex ascii to integer */
int temp = 0;
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;
}
X/*
* Interrupt (^C) handling: If the user hits ^C once, the next pqterm call
* will return TRUE. If he hits ^C again before pqterm is called, there will
* be a forced jump to ABORT next time we hit next(). If it is a primitive
* that is caught in an infinite loop, this won't help any.
*/
sig_int()
{
if (qtermflag) { /* second time? */
forceip = mem[ABORTIP]; /* checked each time through next */
qtermflag = FALSE;
trace = FALSE; /* stop tracing; reset */
}
else qtermflag = TRUE;
}
initsignals()
{
signal(SIGINT,sig_int);
}
getblockfile()
{
/* recall that opening with mode "a+" opens for reading and writing */
/* with the pointer positioned at the end; this is so ftell returns */
/* the size of the file. */
if ((blockfile = fopen(bfilename, "a+")) == NULL)
errexit("Can't open blockfile \"%s\"\n", bfilename);
bfilesize = ftell(blockfile);
printf("Block file has %d blocks.\n",(int) (bfilesize/1024) - 1);
}
//go.sysin dd *
echo 'x - forth.dict'
sed 's/^X//' <<'//go.sysin dd *' >forth.dict
PRIM EXECUTE 0 ( cfa -- <execute word> )
PRIM LIT 1 ( push the next value to the stack )
PRIM BRANCH 2 ( branch by offset in next word )
PRIM 0BRANCH 3 ( branch if zero by off. in next word )
PRIM (LOOP) 4 ( end of a <DO> )
PRIM (+LOOP) 5 ( inc -- <end of a <DO> w/increment != 1 )
PRIM (DO) 6 ( limit init -- <begin a DO loop> )
PRIM I 7 ( get loop index <R> )
PRIM DIGIT 8 ( c -- DIGIT 1 | 0 <convert digit> )
PRIM (FIND) 9 ( s -- s 0 | s NFA 1 <find word s> )
PRIM ENCLOSE 10 ( addr c -- addr next first last <not quite> )
PRIM KEY 11 ( -- c <get next char from input> )
PRIM (EMIT) 12 ( c -- <put char to output> )
PRIM ?TERMINAL 13 ( see if op. interrupted <like w/^C> )
PRIM CMOVE 14 ( src dest count -- <move words>)
PRIM U* 15 ( unsigned multiply )
PRIM U/ 16 ( unsigned divide )
PRIM AND 17 ( a b -- a&b )
PRIM OR 18 ( a b -- a|b )
PRIM XOR 19 ( a b -- a%b )
PRIM SP@ 20 ( -- sp )
PRIM SP! 21 ( -- <store empty value to sp> )
PRIM RP@ 22 ( -- rp )
PRIM RP! 23 ( -- <store empty value to rp> )
PRIM ;S 24 ( -- <pop r stack <end colon def'n>> )
PRIM LEAVE 25 ( -- <set index = limit for a loop> )
PRIM >R 26 ( a -- <push a to r stack> )
PRIM R> 27 ( -- a <pop a from r stack )
PRIM 0= 28 ( a -- !a <logical not> )
PRIM 0< 29 ( a -- a<0 )
PRIM + 30 ( a b -- a+b )
PRIM D+ 31 ( ahi alo bhi blo -- a+bhi a+blo )
PRIM MINUS 32 ( a -- -a )
PRIM DMINUS 33 ( ahi alo -- <-a>hi <-a>lo )
PRIM OVER 34 ( a b -- a b a )
PRIM DROP 35 ( a -- )
PRIM SWAP 36 ( a b -- b a )
PRIM DUP 37 ( a -- a a )
PRIM 2DUP 38 ( a b -- a b a b )
PRIM +! 39 ( val addr -- < *addr += val > )
PRIM TOGGLE 40 ( addr mask -- <*addr %= mask> )
PRIM @ 41 ( addr -- *addr )
PRIM C@ 42 ( addr -- *addr )
PRIM 2@ 43 ( addr -- *addr+1 *addr )
PRIM ! 44 ( val addr -- <*addr = val> )
PRIM C! 45 ( val addr -- <*addr = val> )
PRIM 2! 46 ( bhi blo addr -- <*addr=blo, *addr+1=bhi )
PRIM DOCOL 47 ( goes into CF of : definitions )
PRIM DOCON 48 ( goes into CF of constants )
PRIM DOVAR 49 ( goes into CF of variables )
PRIM DOUSE 50 ( goes into CF of user variables )
PRIM - 51 ( a b -- a-b )
PRIM = 52 ( a b -- a==b)
PRIM != 53 ( a b -- a!=b)
PRIM < 54 ( a b -- a<b )
PRIM ROT 55 ( a b c -- c a b )
PRIM DODOES 56 ( place holder; this value goes into CF )
PRIM DOVOC 57
PRIM R 58 ( same as I, but must be a primitive )
PRIM ALLOT 59 ( primitive because of mem. management )
PRIM (BYE) 60 ( executes exit <pop[]>; )
PRIM TRON 61 ( depth -- trace to this depth )
PRIM TROFF 62 ( stop tracing )
PRIM DOTRACE 63 ( trace once )
PRIM (R/W) 64 ( BUFFER FLAG ADDR -- read if flag=1, write/0 )
PRIM (SAVE) 65 ( Save current environment )
PRIM (COLD) 66
( end of primitives )
CONST 0 0
CONST 1 1
CONST 2 2
CONST 3 3
CONST -1 -1
CONST BL 32 ( A SPACE, OR BLANK )
CONST C/L 64
CONST B/BUF 1024
CONST B/SCR 1
CONST #BUFF 5 ( IMPLEMENTATION DEPENDENT )
CONST WORDSIZE 1 ( EXTENSION: WORDSIZE IS THE NUMBER OF BYTES IN A WORD.
USUALLY, THIS IS TWO, BUT WITH PSEUDO-MEMORY
ADDRESSED AS AN ARRAY OF WORDS, IT'S ONE. )
CONST FIRST 0 ( ADDRESS OF THE FIRST BUFFER AND END OF BUFFER SPACE )
CONST LIMIT 0 ( the reader fills these in with INITR0 and DPBASE )
USER S0 24
USER R0 25
USER TIB 26
USER WIDTH 27
USER WARNING 28
USER FENCE 29
USER DP 30
USER VOC-LINK 31
USER BLK 32
USER IN 33
USER ERRBLK 34
USER ERRIN 35
USER OUT 36
USER SCR 37
USER OFFSET 38
USER CONTEXT 39
USER CURRENT 40
USER STATE 41
USER BASE 42
USER DPL 43
USER FLD 44
USER CSP 45
USER R# 46
USER HLD 47
VAR USE 0 ( These two are filled in by COLD )
VAR PREV 0 ( to the same as the constant FIRST )
CONST SEC/BLK 1
: EMIT
(EMIT)
1 OUT +! ;
: CR
LIT 13 EMIT
LIT 10 EMIT
0 OUT ! ;
: NOP ; ( DO-NOTHING )
: +ORIGIN ; ( ADD ORIGIN OF SYSTEM; IN THIS CASE, 0 )
: 1+
1 + ;
: 2+
2 + ;
: 1-
1 - ;
: ++ ( ADDR -- <INCREMENTS VAL AT ADDR> )
1 SWAP +! ; ( MY OWN EXTENSION )
: -- ( ADDR -- <DECREMENTS VAL AT ADDR> )
-1 SWAP +! ; ( MY OWN EXTENSION )
: HERE ( -- DP )
DP @ ;
: , ( V -- <PLACES V AT DP AND INCREMENTS DP>)
HERE !
WORDSIZE ALLOT ; ( CHANGE FROM MODEL FOR WORDSIZE )
: C, ( C -- <COMPILE A CHARACTER. SAME AS , WHEN WORDSIZE=1> )
HERE C!
1 ALLOT ;
: U< ( THIS IS TRICKY. )
2DUP XOR 0< ( SIGNS DIFFERENT? )
0BRANCH U1 ( NO: GO TO U1 )
DROP 0< 0= ( YES; ANSWER IS [SECOND > 0] )
BRANCH U2 ( SKIP TO U2 <END OF WORD> )
LABEL U1
- 0< ( SIGNS ARE THE SAME. JUST SUBTRACT
AND TEST NORMALLY )
LABEL U2
;
: > ( CHEAP TRICK )
SWAP < ;
: <> ( NOT-EQUAL )
!= ;
: SPACE ( EMIT A SPACE )
BL EMIT
;
: -DUP ( V -- V | V V <DUPLICATE IF V != 0> )
DUP
0BRANCH DDUP1 ( SKIP TO END IF IT WAS ZERO )
DUP
LABEL DDUP1
;
: TRAVERSE ( A DIR -- A <TRAVERSE A WORD FROM NFA TO LFA
<DIR = 1> OR LFA TO NFA <DIR = -1> )
SWAP
LABEL T1
OVER ( BEGIN )
+
LIT 0x7F OVER C@ < ( HIGH BIT CLEAR? )
0BRANCH T1 ( UNTIL )
SWAP DROP ;
: LATEST ( NFA OF LAST WORD DEFINED )
CURRENT @ @ ;
: LFA ( GO FROM PFA TO LFA )
2 - ; ( 2 IS WORDSIZE*2 )
: CFA ( GO FROM PFA TO CFA )
WORDSIZE - ;
: NFA ( GO FROM PFA TO NFA )
3 - ( NOW AT LAST CHAR )
-1 TRAVERSE ; ( 3 IS WORDSIZE*3 )
: PFA ( GO FROM NFA TO PFA )
1 TRAVERSE ( NOW AT LAST CHAR )
3 + ; ( 3 IS WORDSIZE*3 )
: !CSP ( SAVE CSP AT USER VAR CSP )
SP@ CSP ! ;
: (ABORT)
ABORT
;
: ERROR ( N -- <ISSUE ERROR #N> )
WARNING @ 0< ( WARNING < 0 MEANS <ABORT> )
0BRANCH E1
(ABORT) ( IF )
LABEL E1
HERE COUNT TYPE (.") "?" ( THEN )
MESSAGE
SP! ( EMPTY THE STACK )
BLK @ -DUP ( IF LOADING, STORE IN & BLK )
0BRANCH E2
ERRBLK ! IN @ ERRIN ! ( IF )
LABEL E2
QUIT ( THEN )
;
: ?ERROR ( F N -- <IF F, DO ERROR #N> )
SWAP
0BRANCH QERR1
ERROR ( IF <YOU CAN'T RETURN FROM ERROR> )
LABEL QERR1
DROP ( THEN )
;
: ?COMP ( GIVE ERR#17 IF NOT COMPILING )
STATE @ 0= LIT 17 ?ERROR
;
: ?EXEC ( GIVE ERR#18 IF NOT EXECUTING )
STATE @ LIT 18 ?ERROR
;
: ?PAIRS ( GIVE ERR#19 IF PAIRS DON'T MATCH )
- LIT 19 ?ERROR
;
: ?CSP ( GIVE ERR#20 IF CSP & SP DON'T MATCH )
SP@ CSP @ - LIT 20 ?ERROR
;
: ?LOADING ( GIVE ERR#21 IF NOT LOADING )
BLK @ 0= LIT 22 ?ERROR
;
: COMPILE ( COMPILE THE CFA OF THE NEXT WORD TO DICT )
?COMP
R> DUP ( GET OUR RETURN ADDRESS )
WORDSIZE + >R ( SKIP NEXT; ORIG. ADDR STILL ON TOS )
@ ,
;
: [ ( BEGIN EXECUTING )
0 STATE !
;*
: ] ( END EXECUTING )
LIT 0xC0 STATE !
;*
: SMUDGE ( TOGGLE COMPLETION BIT OF LATEST WORD )
LATEST ( WHEN THIS BIT=1, WORD CAN'T BE FOUND )
LIT 0x20 TOGGLE
;
: :
( DEFINE A WORD )
?EXEC
!CSP
CURRENT @ CONTEXT !
CREATE ] ( MAKE THE WORD HEADER AND BEGIN COMPILING )
(;CODE) DOCOL
;*
: ; ( END A DEFINITION )
?CSP ( CHECK THAT WE'RE DONE )
COMPILE ;S ( PLACE ;S AT THE END )
SMUDGE [ ( MAKE THE WORD FINDABLE AND BEGIN INTERPRETING )
;*
: CONSTANT
CREATE SMUDGE ,
(;CODE) DOCON
;
: VARIABLE
CONSTANT
(;CODE) DOVAR
;
: USER
CONSTANT
(;CODE) DOUSE
;
: HEX ( GO TO HEXADECIMAL BASE )
LIT 0x10 BASE ! ;
: DECIMAL ( GO TO DECIMAL BASE )
LIT 0x0A BASE !
;
: ;CODE ( unused without an assembler )
?CSP COMPILE (;CODE) [ NOP ( "ASSEMBLER" might go where nop is )
;*
: (;CODE) ( differs from the normal def'n )
R> @ @ LATEST PFA CFA !
;
: <BUILDS ( UNSURE )
0 CONSTANT ; ( NOTE CONSTANT != CONST )
: DOES> ( UNSURE )
R> LATEST PFA !
(;CODE) DODOES
;
: COUNT ( ADDR -- ADDR+1 COUNT )
DUP 1+ SWAP C@ ; ( CONVERTS THE <STRING> ADDR TO A FORM SUITABLE
FOR "TYPE" )
: TYPE
-DUP
0BRANCH TYPE1
OVER + SWAP ( GET START .. END ADDRS )
(DO)
LABEL TYPE2
I C@ EMIT
(LOOP) TYPE2
BRANCH TYPE3
LABEL TYPE1
DROP
LABEL TYPE3
;
: -TRAILING ( addr count -- addr count <count adjusted to
exclude trailing blanks> )
DUP 0 (DO) ( DO )
LABEL TRAIL1
OVER OVER + 1 - C@ BL -
0BRANCH TRAIL2
LEAVE BRANCH TRAIL3 ( IF )
LABEL TRAIL2
1 - ( ELSE )
LABEL TRAIL3
(LOOP) TRAIL1 ( THEN LOOP )
;
: (.") ( PRINT A COMPILED STRING )
R COUNT
DUP 1+ R> + >R TYPE
;
: ." ( COMPILE A STRING IF COMPILING,
OR PRINT A STRING IF INTERPRETING )
LIT '"'
STATE @
0BRANCH QUOTE1
COMPILE (.") WORD HERE C@ 1+ ALLOT ( IF )
BRANCH QUOTE2
LABEL QUOTE1
WORD HERE COUNT TYPE ( ELSE )
LABEL QUOTE2
;* ( THEN )
: EXPECT ( MODIFIED EXPECT lets UNIX input editing & echoing )
( change EMIT to DROP below if not -echo )
OVER + OVER ( start of input buffer is on top of stack )
DUP 0 SWAP C! ( smack a zero at the start to catch empty lines )
(DO) ( above is an added departure <read "hack"> )
LABEL EXPEC1
KEY
( Comment this region out if using stty cooked )
DUP LIT 8 = 0BRANCH EXPEC2
DROP DUP I = DUP R> 2 - + >R 0BRANCH EXPEC6
LIT 7 BRANCH EXPEC7
LABEL EXPEC6
LIT 8 ( output for backspace )
LABEL EXPEC7
BRANCH EXPEC3
( End of region to comment out for stty cooked )
LABEL EXPEC2
DUP LIT '\n' = 0BRANCH EXPEC4 ( IF )
LEAVE DROP BL 0 BRANCH EXPEC5
LABEL EXPEC4 ( ELSE )
DUP
LABEL EXPEC5 ( THEN )
I C! 0 I 1+ !
LABEL EXPEC3
EMIT ( use DROP here for stty echo, EMIT for -echo )
(LOOP) EXPEC1
DROP
;
: QUERY
TIB @ ( ADDRESS OF BUFFER )
B/BUF ( SIZE OF BUFFER )
EXPECT ( GET A LINE )
0 IN ! ( PREPARE FOR INTERPRET )
;
: {NUL} ( THIS GETS TRANSLATED INTO A SINGLE NULL BYTE )
BLK @
0BRANCH NULL1
BLK ++ 0 IN ! ( IF )
BLK @ B/SCR 1 - AND 0=
0BRANCH NULL2
?EXEC
R> ( IF )
DROP
LABEL NULL2
BRANCH NULL3 ( ENDIF ELSE )
LABEL NULL1
R> DROP
LABEL NULL3 ( ENDIF )
;*
: FILL ( START COUNT VALUE -- <FILL COUNT WORDS, FROM START,
WITH VALUE )
SWAP -DUP
0BRANCH FILL1
SWAP ROT SWAP OVER C! ( IF <NON-NULL COUNT> )
DUP 1+ ROT 1 -
CMOVE
BRANCH FILL2
LABEL FILL1
DROP DROP
LABEL FILL2
;
: ERASE ( START COUNT -- <ZERO OUT MEMORY> )
0 FILL
;
: BLANKS ( START COUNT -- <FILL WITH BLANKS> )
BL FILL
;
: HOLD ( C -- <PLACE C AT --HLD> )
HLD -- HLD @ C!
;
: PAD ( -- ADDR <OF PAD SPACE> )
HERE LIT 0x44 +
;
: WORD ( C -- <GET NEXT WORD TO END OF DICTIONARY,
DELIMITED WITH C OR NULL )
( LOADING PART OF THIS IS COMMENTED OUT )
BLK @ -DUP
0BRANCH W1
BLOCK ( IF loading )
BRANCH W2
LABEL W1
TIB @ ( ELSE )
LABEL W2 ( ENDIF )
IN @ + SWAP ENCLOSE ( GET THE WORD )
HERE LIT 0x22 BLANKS ( BLANK SPACE AFTER WORD )
IN +! OVER - >R R HERE C! + HERE 1+ R> CMOVE
;
: (NUMBER)
LABEL NUM1
1+
DUP >R C@ BASE @ DIGIT
0BRANCH NUM2 ( WHILE )
SWAP BASE @ U* DROP
ROT BASE @ U* D+
DPL @ 1+
0BRANCH NUM3
DPL ++ ( IF )
LABEL NUM3
R> ( ENDIF )
BRANCH NUM1 ( REPEAT )
LABEL NUM2
R>
;
: NUMBER
0 0 ROT DUP 1+ C@
LIT '-' = DUP >R + -1
LABEL N1 ( BEGIN )
DPL ! (NUMBER) DUP C@ BL !=
0BRANCH N2 ( WHILE )
DUP C@ LIT '0' != 0 ?ERROR 0 ( . )
BRANCH N1 ( REPEAT )
LABEL N2
DROP R>
0BRANCH N3 ( IF )
DMINUS
LABEL N3 ( ENDIF )
;
: -FIND
BL WORD ( HERE CONTEXT @ @ <FIND> DUP 0= 0BRANCH FIND1 DROP )
HERE LATEST (FIND)
( LABEL FIND1 )
;
: ID. ( NFA -- <PRINT ID OF A WORD > )
PAD LIT 0x5F BLANKS
DUP PFA LFA OVER - PAD SWAP CMOVE
PAD COUNT LIT 0x1F AND TYPE SPACE
;
: CREATE ( MAKE A HEADER FOR THE NEXT WORD )
-FIND
0BRANCH C1
DROP NFA ID. LIT 4 MESSAGE SPACE ( NOT UNIQUE )
LABEL C1
HERE DUP C@ WIDTH @ MIN 1+ ALLOT ( MAKE ROOM )
DUP LIT 0xA0 TOGGLE ( MAKE IT UNFINDABLE )
HERE 1 - LIT 0x80 TOGGLE ( SET HI BIT )
LATEST , ( DO LF )
CURRENT @ ! ( UPDATE FOR LATEST )
LIT 999 , ( COMPILE ILLEGAL VALUE TO CODE FIELD )
;
: [COMPILE] ( COMPILE THE NEXT WORD, EVEN IF IT'S IMMEDIATE )
-FIND 0= 0 ?ERROR DROP CFA ,
;*
: LITERAL
STATE @
0BRANCH L1
COMPILE LIT ,
LABEL L1
;*
: DLITERAL
STATE @
0BRANCH D1
SWAP LITERAL LITERAL
LABEL D1
;*
: ?STACK ( ERROR IF STACK OVERFLOW OR UNDERFLOW )
S0 @ SP@ U< 1 ?ERROR ( SP > S0 MEANS UNDERFLOW )
SP@ TIB @ U< LIT 7 ?ERROR ( SP < R0 MEANS OVERFLOW: THIS IS IMPLEMENTATION-
DEPENDENT; I KNOW THAT THE CS IS JUST
ABOVE THE TIB. )
;
: INTERPRET
LABEL I1
-FIND ( BEGIN )
0BRANCH I2
STATE @ < ( IF )
0BRANCH I3
CFA , ( IF )
BRANCH I4
LABEL I3
CFA EXECUTE ( ELSE )
LABEL I4
?STACK ( ENDIF )
BRANCH I5
LABEL I2
HERE NUMBER DPL @ 1+
0BRANCH I6
DLITERAL ( IF )
BRANCH I7
LABEL I6
DROP LITERAL ( ELSE )
LABEL I7
?STACK ( ENDIF ENDIF )
LABEL I5
BRANCH I1 ( AGAIN )
;
: IMMEDIATE ( MAKE MOST-RECENT WORD IMMEDIATE )
LATEST LIT 0x40 TOGGLE
;
( *** These are commented out because we don't handle vocabularies ***
: VOCABULARY
<BUILDS LIT 0xA081 ,
CURRENT @ CFA , HERE VOC-LINK @ , VOC-LINK ! DOES>
WORDSIZE + CONTEXT !
;
: DEFINITIONS
CONTEXT @ CURRENT !
;
*** End of commenting-out *** )
: ( ( COMMENT )
LIT ')' ( CLOSING PAREN )
WORD
;*
: QUIT
0 BLK ! [
LABEL Q1
RP! CR QUERY INTERPRET ( BEGIN )
STATE @ 0=
0BRANCH Q2
(.") "OK" ( IF )
LABEL Q2
BRANCH Q1 ( ENDIF AGAIN )
;
: ABORT
SP! DECIMAL ?STACK CR
.CPU ( PRINT THE GREETING )
( FORTH )
QUIT
;
: COLD
(COLD)
VOC-LINK @ CONTEXT ! ( INITIALIZE CONTEXT )
CONTEXT @ CURRENT ! ( MAKE CONTEXT CURRENT )
FIRST USE !
FIRST PREV !
EMPTY-BUFFERS
1 WARNING ! ( USE SCREEN 4 FOR ERROR MESSAGES )
ABORT
;
: WARM
EMPTY-BUFFERS
ABORT
;
: S->D
DUP 0<
0BRANCH S2D1
-1 ( HIGH WORD IS ALL 1S )
BRANCH S2D2
LABEL S2D1
0
LABEL S2D2
;
: +-
0<
0BRANCH PM1
MINUS
LABEL PM1
;
: D+-
0<
0BRANCH DPM1
DMINUS
LABEL DPM1
;
: ABS
DUP +-
;
: DABS
DUP D+-
;
: MIN
2DUP >
0BRANCH MIN1
SWAP
LABEL MIN1
DROP
;
: MAX
2DUP <
0BRANCH MAX1
SWAP
LABEL MAX1
DROP
;
( MATH STUFF )
: M*
2DUP XOR >R ABS SWAP ABS U* R> D+-
;
: M/
OVER >R >R DABS R ABS U/
R> R XOR +- SWAP
R> +- SWAP
;
: * ( MULTIPLY, OF COURSE )
M* DROP
;
: /MOD
>R S->D R> M/
;
: / ( DIVIDE <AND CONQUOR> )
/MOD SWAP DROP
;
: MOD
/MOD DROP
;
: */MOD
>R M* R> M/
;
: */
*/MOD
SWAP DROP
;
: M/MOD
>R 0 R U/ R> SWAP >R U/ R>
;
( END OF MATH STUFF )
: (LINE) ( LINE SCR -- ADDR C/L )
>R C/L B/BUF */MOD R> B/SCR * + BLOCK +
C/L
;
: .LINE ( LINE SCR -- )
(LINE) -TRAILING TYPE
;
: MESSAGE
WARNING @ 0BRANCH MSG1
-DUP 0BRANCH MSG2 ( message # 0 is no message at all )
LIT 4 OFFSET @ B/SCR / - .LINE SPACE ( messages are on screen 4 )
BRANCH MSG2
LABEL MSG1
(.") "MSG # " .
LABEL MSG2
;
( DISK-ORIENTED WORDS )
: +BUF
LIT 1028 ( 1K PLUS 4 BYTES OVERHEAD, CO from defines )
+ DUP LIMIT = 0BRANCH P1
DROP FIRST
LABEL P1
DUP PREV @ -
;
: UPDATE ( MARK BUFFER AS MODIFIED )
PREV @ @ LIT 0X8000 OR PREV @ !
;
: EMPTY-BUFFERS
FIRST LIMIT OVER - ERASE
;
: BUFFER
USE @ DUP >R
LABEL BUF1
+BUF 0BRANCH BUF1 ( LOOP UNTIL +BUF RETURNS NONZERO )
USE ! R @ 0< 0BRANCH BUF2 ( SEE IF IT'S DIRTY <sign bit is dirty bit> )
R 2+ R @ LIT 0X7FFF AND 0 R/W ( WRITE THIS DIRTY BUFFER )
LABEL BUF2
R !
R PREV !
R> 2+
;
: BLOCK
OFFSET @ + >R PREV @ DUP @ R - DUP +
0BRANCH BLOCK1
LABEL BLOCK2
+BUF 0=
0BRANCH BLOCK3
DROP R BUFFER DUP R 1 R/W 2 -
LABEL BLOCK3
DUP @ R - DUP + 0= 0BRANCH BLOCK2
DUP PREV !
LABEL BLOCK1
R> DROP 2+
;
: R/W ( ADDR F BUFNO -- read if F=1, write if 0 )
(R/W)
;
: FLUSH
#BUFF 1+ 0 (DO)
LABEL FLUSH1
0 BUFFER DROP
(LOOP) FLUSH1
;
: LOAD
BLK @ >R IN @ >R 0 IN !
B/SCR * BLK !
INTERPRET
R> IN ! R> BLK !
;
: -->
(.") "--> "
?LOADING 0 IN ! B/SCR BLK @ OVER MOD - BLK +!
;*
: '
-FIND 0= 0 ?ERROR DROP LITERAL
;*
: FORGET
CURRENT @ CONTEXT @ - LIT 24 ?ERROR
' DUP FENCE @ < LIT 21 ?ERROR
DUP NFA DP ! LFA @ CONTEXT @ !
;
( COMPILING WORDS )
: BACK
HERE - ,
;
: BEGIN
?COMP HERE 1
;*
: ENDIF
?COMP 2 ?PAIRS HERE OVER - SWAP !
;*
: THEN
ENDIF
;*
: DO
COMPILE (DO) HERE LIT 3
;*
: LOOP
LIT 3 ?PAIRS COMPILE (LOOP) BACK
;*
: +LOOP
LIT 3 ?PAIRS ?COMP COMPILE (+LOOP) BACK
;*
: UNTIL
1 ?PAIRS COMPILE 0BRANCH BACK
;*
: END
UNTIL
;*
: AGAIN
?COMP
1 ?PAIRS COMPILE BRANCH BACK
;*
: REPEAT
?COMP
>R >R AGAIN R> R> 2 -
ENDIF
;*
: IF
COMPILE 0BRANCH HERE 0 , 2
;*
: ELSE
2 ?PAIRS COMPILE BRANCH HERE 0 , SWAP 2 ENDIF 2
;*
: WHILE
IF 2+
;*
: SPACES
0 MAX -DUP 0BRANCH SPACES1
0 (DO)
LABEL SPACES2
SPACE
(LOOP) SPACES2
LABEL SPACES1
;
: <#
PAD HLD !
;
: #>
DROP DROP HLD @ PAD OVER -
;
: SIGN
ROT 0< 0BRANCH SIGN1
LIT '-' HOLD
LABEL SIGN1
;
: #
BASE @ M/MOD ROT LIT 9 OVER < 0BRANCH #1
LIT 7 + ( 7 is offset to make 'A' come after '9')
LABEL #1
LIT '0' + HOLD
;
: #S
LABEL #S1
# 2DUP OR 0= 0BRANCH #S1
;
: D.R
>R SWAP OVER DABS <# #S SIGN #> R> OVER - SPACES TYPE
;
: .R
>R S->D R> D.R
;
: D.
0 D.R SPACE
;
: .
S->D D.
;
: ?
@ .
;
: U.
0 D.
;
: VLIST
C/L 1+ OUT ! CONTEXT @ @
LABEL VLIST1 ( BEGIN )
OUT @ C/L > 0BRANCH VLIST2 ( IF )
CR
LABEL VLIST2 ( THEN )
DUP ID. SPACE PFA LFA @
DUP 0= ?TERMINAL OR 0BRANCH VLIST1 ( UNTIL )
DROP
;
: .CPU
(.") "C-CODED FORTH INTERPRETER" ( special string handling )
;
: BYE
CR (.") "EXIT FORTH" CR
0 (BYE)
;
: LIST
DECIMAL CR
DUP SCR ! (.") "SCR # " .
LIT 16 0 (DO)
LABEL LIST1
CR I 3 .R SPACE
I SCR @ .LINE
?TERMINAL 0BRANCH LIST2
LEAVE
LABEL LIST2
(LOOP) LIST1
CR
;
: CASE
?COMP CSP @ !CSP LIT 4
;*
: OF
?COMP LIT 4 ?PAIRS
COMPILE OVER COMPILE = COMPILE 0BRANCH
HERE 0 ,
COMPILE DROP
LIT 5
;*
: ENDOF
?COMP
LIT 5 ?PAIRS
COMPILE BRANCH
HERE 0 ,
SWAP 2 ENDIF LIT 4
;*
: ENDCASE
?COMP
LIT 4 ?PAIRS
COMPILE DROP
LABEL ENDC1 ( BEGIN )
SP@ CSP @ != 0BRANCH ENDC2 ( WHILE )
2 ENDIF
BRANCH ENDC1 ( REPEAT )
LABEL ENDC2
CSP !
;*
: \ ( REMAINER OF THE LINE IS A COMMENT )
?LOADING
IN @ C/L / 1+ C/L * IN !
;*
: ALIAS ( usage: ALIAS NEW OLD; makes already-compiled references )
( to OLD refer to NEW. Restrictions: OLD must have been a )
( colon-definition, and it must not have been of the form )
( { : OLD ; } where the first word of the PFA is ;S . )
' CFA
' DUP
2 - @ LIT DOCOL != LIT 27 ?ERROR ( ERROR IF NOT A COLON DEFINITION )
DUP @ LIT ;S = LIT 28 ?ERROR ( MAKE SURE ;S IS NOT THE FIRST WORD )
DUP >R ! LIT ;S R> 2+ !
;
: REFORTH ( GET & EXECUTE ONE FORTH LINE <PERHAPS A NUMBER> )
IN @ >R BLK @ >R
0 IN ! 0 BLK !
QUERY INTERPRET
R> BLK ! R> IN !
;
( The vocabulary word FORTH will be compiled after the dictionary is read,
with a pointer to the last word in the dictionary, which will be itself. )
//go.sysin dd *
echo 'x - forth.h'
sed 's/^X//' <<'//go.sysin dd *' >forth.h
X/*
* forth.h -- define function numbers for primitives, and other constants,
* externals, and globals used in forth.c and prims.c
*/
#define EXECUTE 0
#define LIT 1
#define BRANCH 2
#define ZBRANCH 3
#define PLOOP 4
#define PPLOOP 5
#define PDO 6
#define I 7
#define R 58
#define DIGIT 8
#define PFIND 9
#define ENCLOSE 10
#define KEY 11
#define PEMIT 12
#define QTERMINAL 13
#define CMOVE 14
#define USTAR 15
#define USLASH 16
#define AND 17
#define OR 18
#define XOR 19
#define SPFETCH 20
#define SPSTORE 21
#define RPFETCH 22
#define RPSTORE 23
#define SEMIS 24
#define LEAVE 25
#define TOR 26
#define FROMR 27
#define ZEQ 28
#define ZLESS 29
#define PLUS 30
#define DPLUS 31
#define MINUS 32
#define DMINUS 33
#define OVER 34
#define DROP 35
#define SWAP 36
#define DUP 37
#define TDUP 38
#define PSTORE 39
#define TOGGLE 40
#define FETCH 41
#define CFETCH 42
#define TFETCH 43
#define STORE 44
#define CSTORE 45
#define TSTORE 46
#define DOCOL 47
#define DOCON 48
#define DOVAR 49
#define DOUSE 50
#define SUBTRACT 51
#define EQUAL 52
#define NOTEQ 53
#define LESS 54
#define ROT 55
#define DODOES 56
#define DOVOC 57
X/* 58 is above */
#define ALLOT 59
#define PBYE 60
#define TRON 61
#define TROFF 62
#define DOTRACE 63
#define PRSLW 64
#define PSAVE 65
#define PCOLD 66
X/* memory */
#define GULPFRQ 256 /* if mem[LIMIT] - dp < GULPFRQ, then get */
#define GULPSIZE 1024 /* a block of GULPSIZE words */
X/*
* User variables and other locations
*/
#define S0 UP+0 /* csp when stack is empty */
#define R0 UP+1 /* rsp when r stack is empty */
#define TIB UP+2 /* Terminal Input Buffer location */
#define WIDTH UP+3 /* screen width */
#define WARNING UP+4 /* print messages? */
#define FENCE UP+5 /* can not forget below this mark */
#define DP UP+6 /* points to first unallocated word */
#define VOCLINK UP+7 /* vocabulary link */
char *calloc(), *realloc(), *gets();
long lseek();
X/* GLOBALS */
X/* STACK POINTERS are registers of our FORTH machine. They, like everything
else, point into memory (mem[]). They are read by sp@ and rp@, set by sp!
and rp!. They are initialized by COLD. */
extern unsigned short csp;
extern unsigned short rsp;
X/* This variable is all-important. It will be set to the top of the
data area by sbrk, and more memory will be allocated. All memory is
addressed as a subscript to this address -- mem[0] is the first memory
element, mem[1] is second, and so on.
*/
extern short *mem; /* points to the number of bytes in mem[0], as read
from COREFILE at startup */
X/* two more machine registers: the interpretive pointer */
extern unsigned short ip; /* for an explanation of these, look in */
extern unsigned short w; /* interp.doc */
extern int trace, debug; /* global for tracing in next() */
extern int tracedepth, breakenable, breakpoint, qtermflag, forceip, nobuf;
extern FILE *blockfile;
extern long bfilesize;
extern char *bfilename;
extern char *cfilename;
extern char *sfilename;
//go.sysin dd *
echo 'x - forth.lex'
sed 's/^X//' <<'//go.sysin dd *' >forth.lex
%{
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.
*/
%}
decimal [0-9]
hex [0-9A-Fa-f]
octal [0-7]
white [ \t\n\r\f]
tail /{white}
%{
#include "forth.lex.h"
TOKEN token;
%}
%%
{white}* /* whitespace -- keep looping */ ;
-?[1-9]{decimal}*{tail} { token.type = DECIMAL; token.text = yytext;
return &token; }
-?0{octal}*{tail} { token.type = OCTAL; token.text = yytext;
return &token; }
-?0[xX]{hex}+{tail} { token.type = HEX; token.text = yytext;
return &token; }
\'\\b\'{tail} { token.type = C_BS; token.text = yytext; return &token; }
\'\\f\'{tail} { token.type = C_FF; token.text = yytext; return &token; }
\'\\n\'{tail} { token.type = C_NL; token.text = yytext; return &token; }
\'\\r\'{tail} { token.type = C_CR; token.text = yytext; return &token; }
\'\\t\'{tail} { token.type = C_TAB; token.text = yytext; return &token; }
\'\\\\\'{tail} { token.type = C_BSLASH; token.text = yytext; return &token; }
\'.\'{tail} { token.type = C_LIT; token.text = yytext; return &token; }
\"(\\\"|[^"])*\"{tail} { token.type = STRING_LIT; token.text = yytext;
return &token; }
"("{tail} { token.type = COMMENT; token.text = yytext;
return &token; }
"PRIM"{tail} { token.type = PRIM; token.text = yytext;
return &token; }
"CONST"{tail} { token.type = CONST; token.text = yytext;
return &token; }
"VAR"{tail} { token.type = VAR; token.text = yytext;
return &token; }
"USER"{tail} { token.type = USER; token.text = yytext;
return &token; }
"LABEL"{tail} { token.type = LABEL; token.text = yytext;
return &token; }
":"{tail} { token.type = COLON; token.text = yytext;
return &token; }
";"{tail} { token.type = SEMICOLON; token.text = yytext;
return &token; }
";*"{tail} { token.type = SEMISTAR; token.text = yytext;
return &token; }
"{NUL}"{tail} { token.type = NUL; token.text = yytext;
return &token; }
"LIT"{tail} { token.type = LIT; token.text = yytext;
return &token; }
[^ \n\t\r\f]+{tail} { token.type = OTHER; token.text = yytext;
return &token; }
%%
//go.sysin dd *
echo 'x - forth.lex.h'
sed 's/^X//' <<'//go.sysin dd *' >forth.lex.h
X/* this is my best effort at a reconstruction of this file - it was not
** included with the distribution, and I cannot reach the author via
** electronic mail!
** John Nelson (decvax!genrad!john) [moderator, mod.sources]
*/
struct tokenrec {
int type;
char *text;
};
#define TOKEN struct tokenrec
TOKEN *yylex();
#define DECIMAL 1
#define OCTAL 2
#define HEX 3
#define C_BS 4
#define C_FF 5
#define C_NL 6
#define C_CR 7
#define C_TAB 8
#define C_BSLASH 9
#define C_LIT 10
#define STRING_LIT 11
#define COMMENT 12
#define PRIM 13
#define CONST 14
#define VAR 15
#define USER 16
#define LABEL 17
#define COLON 18
#define SEMICOLON 19
#define SEMISTAR 20
#define NUL 21
#define LIT 22
#define OTHER 23
//go.sysin dd *
echo 'x - forth.line'
sed 's/^X//' <<'//go.sysin dd *' >forth.line
------------------ SCREEN 0 ------------------
================================================================
|| C-CODED FIG-FORTH for UNIX* systems by ALLAN PRATT ||
|| ||
|| INCLUDES \ COMMENTS, ||
|| CASE..OF..ENDOF..ENDCASE ||
|| UNTHREAD, EDITOR ||
|| REFORTH, ||
|| "ALIAS NEW OLD" ||
|| AND OTHER NICE THINGS. ||
|| ( * UNIX is a trademark of Bell Labs ) ||
================================================================
------------------ SCREEN 1 ------------------
( UNTHREAD VERSION 2 / SCREEN 1 OF 3 )
: DOQUOTE \ AFTER (.")
34 EMIT WORDSIZE + DUP C@ OVER 1+ SWAP TYPE
34 EMIT SPACE DUP C@ + 1+ ;
: DOLIT \ AFTER LIT, BRANCHES, AND (LOOP)S
WORDSIZE + DUP @ . WORDSIZE + ;
-->
------------------ SCREEN 2 ------------------
( UNTHREAD VERSION 2 / SCREEN 2 OF 3 )
: DOWORD \ MAIN UNTHREADER
DUP @ WORDSIZE + DUP NFA ID. CASE
' LIT OF DOLIT ENDOF
' 0BRANCH OF DOLIT ENDOF
' BRANCH OF DOLIT ENDOF
' (LOOP) OF DOLIT ENDOF
' (+LOOP) OF DOLIT ENDOF
' (.") OF DOQUOTE ENDOF
' ;S OF DROP 0 ENDOF \ LEAVE 0
DUP OF WORDSIZE + ENDOF \ DEFAULT
ENDCASE ;
-->
------------------ SCREEN 3 ------------------
( UNTHREAD VERSION 2 / SCREEN 3 OF 3 )
: UNTHREAD \ USAGE: UNTHREAD WORD
[COMPILE] ' DUP CFA @
' DOWORD CFA @ <> 27 ?ERROR \ NOT THREADED
CR ." : " DUP NFA ID. SPACE
BEGIN
DOWORD
OUT @ C/L > IF CR THEN
-DUP WHILE
REPEAT ;
CR ." UNTHREAD READY"
;S
------------------ SCREEN 4 ------------------
( ERROR MESSAGES )
EMPTY STACK
ISN'T UNIQUE
XFULL STACK
C-CODED figFORTH by ALLAN PRATT / APRIL 1985
------------------ SCREEN 5 ------------------
MSG # 16
MUST BE COMPILING
MUST BE EXECUTING
UNMATCHED STRUCTURES
DEFINITION NOT FINISHED
WORD IS PROTECTED BY FENCE
MUST BE LOADING
CONTEXT ISN'T CURRENT
ALIAS: NOT A COLON DEFINITION
ALIAS: CAN'T ALIAS A NULL WORD
------------------ SCREEN 6 ------------------
X." LOADING EDITOR FOR VT100" CR
: CLS \ clear screen and home cursor
27 EMIT ." [2J" 27 EMIT ." [H"
;
: LOCATE \ 0 16 LOCATE positions cursor at line 16, column 0
27 EMIT 91 EMIT 1+ 1 .R 59 EMIT 1+ 1 .R 72 EMIT ;
: STANDOUT \ This can be a null word
27 EMIT ." [7m" ;
: STANDEND \ This can be a null word, too.
27 EMIT ." [m" ;
;S \ CONTINUE LOADING EDITOR
------------------ SCREEN 7 ------------------
X." LOADING EDITOR FOR ADM5" CR
: CLS 26 EMIT ;
: LOCATE
27 EMIT 61 EMIT
32 + EMIT 32 + EMIT ;
: STANDOUT
27 EMIT 71 EMIT ;
: STANDEND
27 EMIT 71 EMIT ;
;S \ continue loading editor
------------------ SCREEN 8 ------------------
( Reserved for more terminals; set the name of the terminal
as a constant in screen 10 )
;S
------------------ SCREEN 9 ------------------
( Reserved for more terminals. Set the name of the terminal
as a constant in screen 10 )
;S
------------------ SCREEN 10 ------------------
( EDITOR -- SCREEN 1 OF 19 -- VARIABLES )
DECIMAL
0 VARIABLE ROW 0 VARIABLE COL
0 VARIABLE EDIT-SCR 0 VARIABLE SCREEN-IS-MODIFIED
0 VARIABLE MUST-UPDATE 0 VARIABLE LAST-KEY-STRUCK
0 VARIABLE CURSOR-IS-DIRTY
0 VARIABLE KEYMAP WORDSIZE 255 * ALLOT
KEYMAP WORDSIZE 256 * ERASE
0 VARIABLE SCR-BUFFER B/BUF B/SCR * WORDSIZE - ALLOT
( TERMINAL CONSTANTS -- VALUE IS SCREEN NUMBER TO LOAD )
6 CONSTANT VT100 7 CONSTANT ADM5
-->
------------------ SCREEN 11 ------------------
( EDITOR -- SCREEN 2 OF 19 -- SCREEN STUFF )
CR ." ENTER THE TYPE OF TERMINAL YOU ARE USING. TYPE ONE OF:"
CR ." VT100 ADM5" CR \ list the constants from scr 10
REFORTH \ this word gets & interprets one line.
LOAD \ load the right screen; VT100 = 6, ADM5 = 7
: EXIT-EDIT
0 16 LOCATE QUIT ;
: ABORT-EDIT
0 15 LOCATE MESSAGE ;
: BIND-ADDR ( C -- ADDR where binding is stored )
WORDSIZE * KEYMAP + ;
-->
------------------ SCREEN 12 ------------------
( EDITOR -- SCREEN 3 OF 19 -- I/O )
: ^EMIT ( OUTPUT W/ESC AND ^ )
DUP 127 > IF ." ESC-" 128 - THEN
DUP 32 < IF ." ^" 64 + THEN
EMIT ;
: BACK-WRAP ( DECR EDIT SCR. AND PUT CURSOR AT BOTTOM )
EDIT-SCR -- C/L 1- COL ! 15 ROW ! 1 MUST-UPDATE ! ;
: FORWARD-WRAP ( INCR EDIT SCR. AND PUT CURSOR AT TOP )
EDIT-SCR ++ 0 COL ! 0 ROW ! 1 MUST-UPDATE ! ;
: ED-KEY ( INPUT W/ESC FOR HI BIT )
KEY DUP 27 = IF DROP KEY 128 + THEN
DUP LAST-KEY-STRUCK ! ;
-->
------------------ SCREEN 13 ------------------
( EDITOR -- SCREEN 4 OF 19 -- BINDING WORDS )
: (BIND) ( CFA K -- STORES INTO KEYMAP )
BIND-ADDR !
;
: BIND-TO-KEY ( "BIND-TO-KEY NAME" ASKS FOR KEY )
[COMPILE] ' CFA
." KEY: " ED-KEY DUP ^EMIT SPACE
(BIND) ;
: DESCRIBE-KEY
." KEY: " ED-KEY DUP ^EMIT SPACE
BIND-ADDR @ -DUP IF NFA ID.
ELSE ." SELF-INSERT"
THEN SPACE ;
-->
------------------ SCREEN 14 ------------------
( EDITOR -- SCREEN 5 OF 19 -- PRIMITIVE OPS )
: PREV-LINE ROW @ IF ROW -- 1 CURSOR-IS-DIRTY !
ELSE BACK-WRAP THEN ;
: NEXT-LINE ROW @ 15 < IF ROW ++ 1 CURSOR-IS-DIRTY !
ELSE FORWARD-WRAP THEN ;
: BEGINNING-OF-LINE 0 COL ! 1 CURSOR-IS-DIRTY ! ;
: END-OF-LINE C/L 1- COL ! 1 CURSOR-IS-DIRTY ! ;
: EDIT-CR NEXT-LINE BEGINNING-OF-LINE ;
: PREV-CHAR COL @ IF COL -- 1 CURSOR-IS-DIRTY !
ELSE END-OF-LINE PREV-LINE
THEN ;
: NEXT-CHAR COL @ C/L 1- < IF COL ++ 1 CURSOR-IS-DIRTY !
ELSE EDIT-CR
THEN ;
-->
------------------ SCREEN 15 ------------------
( EDITOR -- SCREEN 6 OF 19 -- MORE LOW-LEVEL )
: THIS-CHAR
ROW @ EDIT-SCR @ (LINE) DROP COL @ + ;
: PUT-CHAR THIS-CHAR C! 1 MUST-UPDATE ! ;
: INSERT-CHAR PUT-CHAR NEXT-CHAR ;
: SELF-INSERT
LAST-KEY-STRUCK @ DUP THIS-CHAR C! EMIT
NEXT-CHAR
;
DECIMAL -->
------------------ SCREEN 16 ------------------
( EDITOR -- SCREEN 7 OF 19 -- DISPLAY STUFF )
HEX
: SHOWSCR ( N -- SHOWS SCREEN N )
CLS
0 10 LOCATE STANDOUT ." SCREEN " DUP . STANDEND
10 0 DO
0 I LOCATE
I OVER .LINE
LOOP DROP ;
: REDRAW EDIT-SCR @ SHOWSCR ;
: ?REDRAW
MUST-UPDATE @ IF REDRAW 0 MUST-UPDATE !
1 CURSOR-IS-DIRTY ! THEN ;
DECIMAL -->
------------------ SCREEN 17 ------------------
( EDITOR -- SCREEN 8 OF 19 -- EXECUTE-KEY )
: EXECUTE-KEY ( K -- EXECUTE THE KEY )
WORDSIZE * KEYMAP + @ -DUP IF
EXECUTE
ELSE
SELF-INSERT
THEN
;
: ?PLACE-CURSOR
CURSOR-IS-DIRTY @ IF
COL @ ROW @ LOCATE
0 CURSOR-IS-DIRTY !
THEN
;
-->
------------------ SCREEN 18 ------------------
( EDITOR -- SCREEN 9 OF 19 -- TOP-LEVEL )
: TOP-LEVEL
BEGIN
?REDRAW ?PLACE-CURSOR ED-KEY EXECUTE-KEY
AGAIN
;
: EDIT
EDIT-SCR ! CLS
0 ROW ! 0 COL ! 1 MUST-UPDATE !
TOP-LEVEL
;
-->
------------------ SCREEN 19 ------------------
( EDITOR -- SCREEN 10 OF 19 -- HIGH-LEVEL KEY WORDS )
: UPDATE-SCR ( BOUND TO ^U )
EDIT-SCR @ B/SCR * DUP B/SCR + SWAP DO
I BLOCK DROP UPDATE
LOOP ;
: NEXT-SCR ( ^C and ESC-C )
EDIT-SCR ++ 1 MUST-UPDATE !
;
: PREV-SCR ( ^R and ESC-R )
EDIT-SCR @ 0= IF EDIT-SCR ++ THEN
EDIT-SCR -- 1 MUST-UPDATE ! ;
-->
------------------ SCREEN 20 ------------------
( EDITOR -- SCREEN 11 OF 19 -- HIGH-LEVEL )
HEX
: TAB-KEY ( INCREMENT TO NEXT TAB STOP )
COL @ 8 + F8 AND DUP C/L < IF COL ! THEN ;
DECIMAL
: REEDIT ( RESTART EDITING )
EDIT-SCR @ EDIT ;
: ERRCONV
ERRBLK @ DUP B/SCR / SWAP B/SCR MOD DUP +
ERRIN @ C/L @ / + ;
: ERREDIT ERRCONV ROW ! EDIT-SCR ! BEGINNING-OF-LINE
1 MUST-UPDATE ! CLS TOP-LEVEL ;
-->
------------------ SCREEN 21 ------------------
( EDITOR -- SCREEN 12 OF 19 -- )
: UPDATE-AND-FLUSH
UPDATE-SCR FLUSH ;
: DEL-TO-END-OF-LINE
COL @ ROW @ EDIT-SCR @ ( SAVE THESE )
C/L COL @ DO BL INSERT-CHAR LOOP
EDIT-SCR ! ROW ! COL ! ( RESTORE SAVED VALUES )
;
-->
------------------ SCREEN 22 ------------------
( EDITOR -- SCREEN 13 OF 19 -- MORE HIGH-LEVEL )
: CLEAR-SCREEN
EDIT-SCR @ B/SCR * DUP B/SCR + SWAP DO
I BLOCK B/BUF BLANKS
LOOP
1 MUST-UPDATE !
;
: DESCRIBE-BINDINGS ( SHOWS ALL BINDINGS )
256 0 DO ( INTERESTING ONES, ANYWAY )
I BIND-ADDR @
-DUP IF CR I ^EMIT SPACE NFA ID. THEN
?TERMINAL IF LEAVE THEN
LOOP CR ;
-->
------------------ SCREEN 23 ------------------
( EDITOR -- SCREEN 14 OF 19 -- WORD MOVEMENT )
: NEXT-WORD
THIS-CHAR C@ BL = IF PREV-CHAR THEN ( BUG FIX )
BEGIN NEXT-CHAR THIS-CHAR C@ BL = UNTIL
BEGIN NEXT-CHAR THIS-CHAR C@ BL <> UNTIL ;
: PREV-WORD
BEGIN PREV-CHAR THIS-CHAR C@ BL <> UNTIL
BEGIN PREV-CHAR THIS-CHAR C@ BL = UNTIL
NEXT-CHAR ;
-->
------------------ SCREEN 24 ------------------
( EDITOR -- SCREEN 15 OF 19 -- BUFFER CONTROL )
: TO-BUFFER ( COPY FROM HERE TO BUFFER )
EDIT-SCR @ 16 0 DO
I OVER (LINE) I C/L * SCR-BUFFER + SWAP CMOVE
LOOP DROP
;
: FROM-BUFFER ( COPY FROM BUFFER TO HERE )
EDIT-SCR @ 16 0 DO
I OVER (LINE) DROP I C/L * SCR-BUFFER + SWAP C/L CMOVE
LOOP DROP 1 MUST-UPDATE !
;
-->
------------------ SCREEN 25 ------------------
( EDITOR -- SCREEN 16 OF 19 -- MORE BUFFERS )
: SCR-COPY ( SRC DEST -- COPIES A SCREEN )
EDIT-SCR @ ROT ROT ( OLD IS THIRD )
SWAP EDIT-SCR ! TO-BUFFER ( OLD IS SECOND/DEST IS FIRST )
EDIT-SCR ! FROM-BUFFER UPDATE-SCR
EDIT-SCR !
;
: QUOTE-NEXT
ED-KEY INSERT-CHAR
;
: EXECUTE-FORTH-LINE
0 17 LOCATE 27 EMIT 84 EMIT REFORTH
1 MUST-UPDATE ! TOP-LEVEL ;
-->
------------------ SCREEN 26 ------------------
( EDITOR -- SCREEN 17 OF 19 -- )
-->
------------------ SCREEN 27 ------------------
( EDITOR -- SCREEN 18 OF 19 -- INITIALIZE BINDINGS )
' PREV-LINE CFA 11 (BIND) ( ^K )
' NEXT-LINE CFA 10 (BIND) ( ^J )
' PREV-CHAR CFA 8 (BIND) ( ^H )
' NEXT-CHAR CFA 12 (BIND) ( ^L )
' NEXT-SCR CFA 3 (BIND) ( ^C )
' PREV-SCR CFA 18 (BIND) ( ^R )
' EXIT-EDIT CFA 209 (BIND) ( ESC-Q )
' EDIT-CR CFA 13 (BIND) ( ^M )
' TAB-KEY CFA 9 (BIND) ( ^I )
' UPDATE-SCR CFA 21 (BIND) ( ^U )
' NEXT-WORD CFA 6 (BIND) ( ^F )
' PREV-WORD CFA 1 (BIND) ( ^A )
' UPDATE-AND-FLUSH CFA 198 (BIND) ( ESC-F )
-->
------------------ SCREEN 28 ------------------
( EDITOR -- SCREEN 19 OF 19 -- MORE BINDINGS )
' DEL-TO-END-OF-LINE CFA 25 (BIND) ( ^Y )
' PREV-CHAR CFA 19 (BIND) ( ^S )
' PREV-LINE CFA 5 (BIND) ( ^E )
' NEXT-LINE CFA 24 (BIND) ( ^X )
' NEXT-CHAR CFA 4 (BIND) ( ^D )
' TO-BUFFER CFA 190 (BIND) ( ESC-> )
' FROM-BUFFER CFA 188 (BIND) ( ESC-< )
' NEXT-SCREEN CFA 195 (BIND) ( ESC-C )
' PREV-SCREEN CFA 210 (BIND) ( ESC-R )
' QUOTE-NEXT CFA 16 (BIND) ( ^P )
' EXECUTE-FORTH-LINE CFA 155 (BIND) ( ESC-ESC )
CR ." EDITOR READY "
;S
------------------ SCREEN 29 ------------------
//go.sysin dd *sources-request@genrad.UUCP (05/24/85)
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@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 *sources-request@genrad.UUCP (05/29/85)
I have been informed that someone's news compression / batch system ate
the end of the third installation of the C forth distribution, and that
many sites are affected. Please, folks: upgrade to the newest version
of "compress"! Anyway, here is the tail end of Part3 again (prims.c,
prims.h).
------ cut here -------
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 *