yourforth.fas

; yourforth: the simplest Forth compiler possible, i86 Linux version.
; Originated as a FASM version of ciforth created by ``m4'' from generic listing.
;
; This is a community effort in the spirit of the Forth Interest Group.
; It is public domain and only knows contributors, no copyright holders.
; Contributors:  <when contributing, put your name here>
;   yourforth $Revision: 6.28 $

; To build:
; wget http://flatassembler.net/fasm-1.70.03.tgz; tar xfz fasm-1.70.03.tgz; fasm/fasm yourforth.fas
; That is right. Not only did you brew coffee, you've been to Columbia, picked the beans,
; and roasted them as well! Next time you only need "fasm/fasm ourforth.fas".
; If you're new at Forth you may want to read the Chapter "gentle introduction"
; of yourforth.pdf.

; ---------------- preliminary remark -------------------------
; Normally a Forth in assembly style would use the official assembler
; on the operating system at hand, in our case gas or ``GNU as'' as it is called
; nowadays.
; The one-liner illustrates why we deviate here. A gas equivalent would download 1 Gbyte!
; I use fasm because it has overwhelming advantages.
; By implication the following advantages point to disadvantages of gas.
; 1. fasm accommodates one simple segment
; 2. fasm accommodates Intel syntax fairly
; 3. fasm has a traditional macro facility
; 4. fasm needs no linking step
; 5. fasm is small, basically an executable.
; Also it accommodates symbol reassignment and labels that are local to macro's,
; which is kind of essential to the way we want to use macro's.

; ------------------ 0. introduction ------------------------------------
; A famous chess player once stated that, if we were to find aliens living on
; another planet, we should expect that they will play Go. Likewise
; discovering Forth is something every civilisation in the universe will
; do eventually. Chuck Moore claims to have discovered, rather than invented, Forth.
; You'll find the structure of yourforth simple, and compelling.

; The model for Forth is the stored program computer, actually the best invention since
; sliced bread. The first computers had a work area where numbers were stored, and
; punched card that represented the instructions. Then someone came with the idea, to
; have one memory space, and store numbers there, but also put the program in the
; same space and then have the computer read the instructions from memory.
; Now a small program can write a larger program, and then execute it!
; It is similar to how the human brain continuously reconditions its synapses
; in a perpetual learning process. At last a machine with the potential of artificial
; intelligence was born. So a memory item is identified by a number,
;  the "address" of the memory item.
; The first program-building program was probably an assembler, but at the time the larger
;  program could not be deposited into memory and had to punched onto tape.
; Guess what? It is still done this way, only the tape has been replaced
; by disk files or EPROM. Only the artificial-intelligence-languages,
; LISP and Forth, allow to have a program that extends itself
; indefinitely. Interestingly, you will find that most programs cripple
; the computer, by separating into a text and a data segment, the
; equivalent of the punched card and the work area of above. Not so in
; Forth, were data and code belonging together remain close.
; It is hard to instruct a traditional compiler like GNU's to have such a
; unified memory space. It is illustrative that the option for the linker is
; called -magic and it is is probably only there, because Richard
; Stallman is a fan of that other ai-capable language, LISP. This applies
; to GNU as. Of course what we want is simple, and with fasm doing
; simple things is easy.

; The first c-compiler in existance was written in assembler (what else?)
; but then immediately they rewrote the compiler in c.
; Likewise a PL-1 compiler is written in PL-1, an algol68 compiler
; is written in algol68. Can't a Forth be written in Forth?
; Actually it is! It is even easier. If you want to add features to a c-compiler
; you must edit the source and rebuild it. Being an interpreter yourforth
; just can include a Forth source file with the facilities
; you want. Only the kernel here has to be written in assembler,
; like the first c-compiler ever.
; Even in this assembler source you will see that most of the code is actually
; Forthcode, that is compiled by the assembler (with a renaming convention).
; In the last part there is even Forth source that is compiled by yourforth
; at startup. That is equivalent to including a source file, but less messy.
; Forth is the only language simple enough to make this feasible.
; For the following you must be familiar with the concept of a data stack
; (ex. 0.1) and with behaviour of yourforth under a test (ex. 0.2).

; ---------------------- 1. memory and addressing ---------------------------------
; Memory consists of bytes
; and, yes, nothing funny, that are the bytes you buy in the store.
; Those bytes are numbered, and thus identified, and they
; can be used for data or code, as I choose.
; yourforth uses memory between BM and EM. (exercise)
; So you can use the byte addressed as BM, as BM+1, up till and including EM-1,
; but not EM.  (ex. 1.1)
; Bytes can represent characters, small pictures that are associated
; with sounds (in most languages) or concepts in e.g. Chinese.
; Chunks of bytes are needed to represent numbers as large as BM.
; We take 4 bytes together to form a cell, resulting in a 32-bit Forth,
; and restricting memory size to 4 Gbyte. Now we can manipulate
; fairly large numbers, of plus or minus 2000 millions, and addresses
; (which are just numbers)
; up to ca. 2 Gbyte. We will shun negative addresses in yourforth.

; The word "word" has a special meaning in Forth, so using official Forth jargon
; "cell" for those chunks diminishes confusion.

cw      =     4                 ; Cell width

; 32 bits also happens to be the word size of the processor we are using, or more
; precisely -- because it is probably a 64-bit processor -- of the wordsize we
; are instructing the processor to use.

        use32

; This is not enough, Linux must know that this is a 32 bit (ELF)
; executable (not ELF64), to start the program in the right mode.
; This is the way to instruct fasm to put such a header at the front
; of our program.

        FORMAT  ELF EXECUTABLE ; fasm makes an executable directly, no linker.

; We are not particularly interested at what address Forth starts, as long as
; we have enough bytes to work with, and
; that's what we define here. It is made to work, by declaring the right amount
; of space.
; (exercise)
;
forthsize      =     0x100000   ; One megabyte, for starters.
;
tasksize    = 0x10000           ; Total size of the uninitialised memory near EM
stacksize   = tasksize/4        ;  Its subdivisions.
cibsize     = tasksize/2

; ---------------------- 2. Communicating with the world --------------------
; Forth is an interpreter, an environment that you can type commands into
; to get them executed.
; Characters are glyph's, the bitmaps on the screen, that are associated
; with the content of one byte.
; Forth doesn't care much what the console
; shows you, nor what content results from pressing a particular key.
; Internally only rows of bytes are compared, and build up,
; and they are passed to the console for display.
; The typing and the showing of results goes through
; a "console" which is typically a terminal window on a Linux X-screen, but
; could equally well be an old fashioned VT100 terminal connected with a
; 100 m RS232 line. Linux has the convenient notions of a "standard input" and
; a "standard output" with facilities to use them. We let Linux take care of
; how this i/o is setup, and within Forth we just use it.
; This file is in UTF-8, but the character encoding doesn't count for much in Forth.
; (ex. 2.1). The inventor of Forth, Chuck Moore uses a Huffman
; encoding of his whim for colorforth.

; This brings us to the subject of the interface with the Operating
; System. The interfacing with Linux is brutally direct. We use the system calls,
; that have been given numbers. Each performs a basic functionality, e.g.
; the open system call opens a file.
; Their documentation shows on commands like "man 2 exit".

__NR_exit    =     0x1
__NR_open    =     0x5
__NR_close   =     0x6
__NR_creat   =     0x8
__NR_unlink  =     0xa
__NR_chdir   =     0xc
__NR_read    =     0x3
__NR_select  =     0x52
__NR_newselect      =     0x8e
__NR_write   =     0x4
__NR_ioctl   =     0x36
__NR_ioperm  =     0x65
__NR_iopl    =     0x6e
__NR_lseek   =     0x13
__NR_execve  =     0xb
__NR_fork    =     0x2
__NR_waitpid =     0x7
__NR_pipe    =     0x2a

; See XOS of how the dispatching takes place. (ex. 2.2)
; The numbers have been copied from a secret place in Linux's include hierarchy (exercise)
; and the exact names are retained, which means an exception to the naming convention
; that words containing capitals or underscores are Forth names.
;

; Experienced assembler programmers expect two segments, one that we will fill
; with our forth code, and one unitialized that may be very large.
; (We could get by with one segment if we initialize all space. Then we'll
; have 1 Gbyte executables.)
; The first segment would be marked BITS (or some such), and the second one NOBIT,
; and while linking we
; would have made sure that they fit snugly together. Now this is a bit silly,
; because the assembler perfectly knows that the NOBITS part is not initialised.
; Also it is not easy. Fitting two segments snugly goes against the spirit of the
; linker. There is no end of incantations needed, and worse yet, the high priests
; change those at will.
; Surprise! fasm doesn't have this nonsensical keyword. Not only doesn't it store
; the content of segments without content, it doesn't store the uninitialised part
; of segments. We can put everything in
; one segment, and the uninitialised part occupies no room on our hard disk.

               segment executable readable writable

; So one segment, no separation between the punch cards containing executable
; code and a workspace containing our data. We can have the computer invent
; a program, put it into its memory then execute it. The last part of this source,
; is Forth code. The first part is sufficient for compiling that during startup.
; It is fast enough that you will not notice it.  (exercise).

bm:                     ; This is the first address of Forth.

; As said, we are not particularly interested in what address bm represents and don't
; force the assemblers hand.

; You probably know a little bit how an interpreter works. Contrary to a compiler
; that may inspect a whole file, it takes the input one word at a time.
; In Forth word's are separated by blank space. The word is looked up in a list,
; and it is executed, which means that it gets in control. There is no "interpreter
; loop" that sniffs the word out, and refuses it if it is no good. No. You type
; "DROP" and if it's there, you get it. The Intel program counter is set
; to the machine code of "DROP" and the ship sails.
; Not all that we want the interpreter to understands can be put in the list, e.g.
; we can't put all 32 bit numbers there. There are other notations for
; expressions that are known at compile time and constant : "aap" 1234 0x1234.
; We'll call those denotations.
; The solution for denotations, is that it sufficient to have a partial
; or ambiguous match. yourforth requires that the first characters are
; recognized, so it can handle a 0x1234 notation for hexadecimal but not
; Intel's 1234H.
; Being a prefix is merely a property of the Forth definition and it doesn't
; make looking up a word all that harder.
; So, if the first part of a word matches a prefix definition in the
; list, e.g. " for strings, then the definition with name `` " ''
; is executed. For you new to Forth, a string consisting of one double
; quote is a perfectly good Forth name. Get used to it!
; It itself takes care of parsing the remainder of the denotation.
; At the very end of the list we have a catch-all, which always matches,
; because it is the empty string. This interprets the string as a
; number. I admit, this is a bit of a trick.

; Now the intelligent part. You can use the Forth system to extend itself by
; instructing the interpreter to add a new command to the list.
; We will discuss that later in great detail. For now let's sketch how
; the dictionary looks. It is basically a list of Forth words, each with
; a header. The list is expandable, and the most recent word is highest
; in memory. In Forth you can redefine a word, then it hides a word of
; that same name that might exist. You get a warning, but it is not an
; error. In this way you can replace a word with a version with
; debugging information, you can use the old version to build the word.
; In interactive sessions this feature is often used to correct
; mistakes. Oops, forgot a carriage return. Let me just redefine it
; as itself plus a carriage return.
;
; Forth definitions despite their division in categories like colon
; definitions, variables, constants, cd-objects are uniform. Zooming in
; we see the header, a structure with 5 fields each of one cell,
; followed by memory that is owned by this definition, then the
; following header. What is in the memory is up to the definition. You
; may consider this Forth's version of an object. If there is one thing
; to remember about objects that is that objects have a character and an
; identity. An objects character, its type or class, is determined by
; its behaviour or code. The identity of an object is determined by the
; data it carries. Likewise Forth's object have a code field and a data
; field. If you are into objects, you may associate the code field with
; methods and the data fields with fields in traditional objects. You
; will however discover that Forth is uncannily concrete and precise.
;
; The list mechanism requires a link field. This starts at the most
; recent word. Its link contains the address of the header of the
; previous definition, and so on, and the last definition contains a
; zero. Then of course there is one field for the name. The flag field
; with bits up for miscellaneous properties, brings the field count to 5.
;
; So let's summarize.
; A definition consist of a header with 5 fields CDFLN and its data
; area. The definitions together make up the memory up to a point that
; moves up when adding new definitions. Then we have free
; memory up till the end of a reserved with a few scratch area's notably
; the stack.
;
; The name is not very essential. You can change the name of any
; definition in a working program and it keeps working all
; the same. A definition can only be found if you know the name, of
; course. (EXERCISE!)
;
; The link field also is not. It is only used by the interpreter to look
; up a definition. A typical application program will never inspect link
; fields. Set them all to zero and the program keeps working fine. A
; definition can only be found if it is linked in properly, so the
; compilation of that program cannot succeed. In fact the : definition
; that starts compilation cannot be found. Exercise.
;
; The flag field contains a bit up for properties a word might have. For
; example it may be hidden, which means that it must be ignored during a
; lookup. Exercise.
;
; More essential is the data field. All but the basic instruction of the
; Forth engine have data, associated: a constant value, a buffer
; address, a structure with fields. Also note that most Forth code is
; interpreted. The interpreted code is data, not machine code. Exercise.
;
; Absolutely essential is the code field. This contains an address and
; the genuine Intel Program counter is directly and unconditionally
; loaded with that address if the definition is called upon. If that
; address is wrong you end up in genuine limbo. Remember Forth is
; concrete and precise, no handwaving. I repeat it for clarity. If you
; type in a Forth word, it is looked up, and its machine code address is
; fetched. Then your Intel machine starts, for better or worse,
; executing the code at that address. There is no safety net. If that
; code doesn't cooperate with Forth-as-a-whole your machine crashes.
; (exercise)
; You'll see no symbolic definition for field offsets in the assembler code.
; The only offsets that occurs is 1*cw, which means the data field offset.
; In high level Forth the offsets are handled by words >CFA >DFA etc.
;
; To an interpreter strings play of course an important role. Forth
; strings are represented as an address and a length. Putting two things
; on the stack is of course no problem. This may be unfamiliar for the
; c-programmer, but familiar for the Pascal programmer. Note that modern
; character encodings may contain embedded zero's, and several bytes may
; combine to represent glyph. yourforth doesn't care. If stored in
; memory the length occupies a whole cell, and the characters follow,
; one per byte, as far as this file is concerned. Counting those
; characters is a chore, as we will need a string for each name of a
; built in command.
; That chore is easily handled by the assembler using a macro.

macro string  content
{
    local startstring, endstring
    dd    endstring -startstring
startstring:
    db    content
endstring:
        align    cw
}

; "content" is of course the string itself, and fasm treats the start
; and the end of the string as locals, i.e. they are generated new for each
; string and are not visible outside the macro's.
; DD lays down a 32 bit value. It is short for DD, "define double (16-bits) word ".
; In yourforth a lot of DD's are used, to represent headers as well as interpreted
; code. You see that we keep those cells aligned to 32 bit boundaries. This is
; not strictly necessary, but it makes inspecting memory so much easier.
; <I'm tempted to use a 'fix macro' to redefine DD as DC >

; The header macro lays down the 5 fields in memory. You don't need to understand
; the following fully yet. The details are introduced gradually as each type of
; definition will be explained where it first occurs.
; All fields are passed to the macro
; as is, except for the name that is passed as a string. The string is
; to be laid out in memory just like in the string macro and a pointer
; to that is put in the name field.

macro header dea, cfield,dfield,ffield,lfield,forthname
{
    local nfield, startstring, endstring
nfield:         dd    endstring -startstring
startstring:    db    forthname
endstring:
        align    cw
dea:  dd      cfield, dfield, ffield, lfield, nfield
lastlink EQU dea
}
; Learn the five letters cdfln by heart!
; They stand for code, data, flag, link and name.
;
; Let's look at an example first.
;    header  _BM_,   docon, bm, 0, lastlink, "BM"
; This is a constant containing the bottom of the memory.
; _BM_ is the name such as used in the assembler, "BM" is the name
; within Forth. This string must be visible from Forth, unlike _BM_
; and bm, that stay within the assembler.
; docon is the code executed for a constant.
; bm is the data, i.e. a constant known by the assembler, which is
; in this case the label representing the bottom of the memory,
; that we defined above.
; 0 means that there are no flags. lastlink just means normal linking.
;
; Apart from a better overview and taking care of name strings,
; "header" makes one other thing easier. It is cumbersome to fill
; in lfield with the name of the previous definition. By setting
; lastlink -- changing it with every invocation of header -- the name of
; the previous definition is always available as "lastlink".
; So you will see that almost always all header specifies lastlink
; for lfield.
; As a result a definition can be moved around without changes to its header.
; We can always override this by replacing
; "lastlink" by the actual value we want to have.
; "dea" is the name used within the assembler. Remember forthname is a
; string like "+" that probably is not an acceptable name for the word
; in the assembler. So we need "dea" to use the word in the assembler.
; The "dea" passed to the header macro, results in that name being usable
; in the assembler as a number and an address. It contains only lower
; case characters and underscores.

; Each name in yourforth itself contains any assortion of weird characters and capital
; letters, no lower case. Let's take R@ as an example.
; It is identified by it dea: 'R@ a denotation, a fixed number.
; Within the assembler this number is represented by the name r_fetch.
; A simpler example is DROP. The assembler name is "DROP", which is the same
; number as 'DROP in yourforth.
; Here is the renaming convention:
; The capitals are kept, and if the resulting name clashes in the assembler,
; underscores are added before and after.
; Any special characters are replaced according to the following table.
; We'll have to write them out, like
; !     @     %        ,    *    (     <      >      /      +    -
; fetch store percent comma star paren less  greater slash  plus minus
;
; [        ~
; bracket  not
;
; Sometimes < and > are used to indicate data transfer and are then
; named to or from. I'm lazy and translate (CREATE) to paren_CREATE,
; not leftparen_CREATE_rightparen.
;
; fetch and store are used in forth names that fetch something from memory
; or store something in memory.
;
; A denotation is a constant value that is generated on the fly by
; the compiler or interpreter.
; Because this is difficult, we postpone it.

; The most important types of definitions are lowlevel code, high level code,
; low level objects(constants, variables/buffers) and high level objects.
; They are gradually introduced by example, but here is an overview of the
; different types. The names starting in "do" are assembler labels.
; - cfield contains docon. The definition is a constant, i.e. when executed it
;   puts a constant on the stack. That constant is present at the DFA.
; - cfield contains dobuf. The definition is a variable or buffer, i.e. when executed it
;    puts an address on the stack of an area where data can be stored.
;    That address is present at the DFA, typically dea+5*cw
; - cfield contains docol. docol is the interpreter of Forth. It takes care that
;   the high level code is executed, that is found via the DFA. This typically
;   contains dea+5*cw. In other words the high level code contained at the post
;   header address is executed. These are the ordinary functions.
; - cfield contains dea+5*cw. In other words, its machine code is
;   unique and contained at the post header address to be executed.
;   These are the regular low level words that make up the Forth
;   language like "+" and "DROP". Of course this code is different for
;   all of those words.
; - cfield contains dodo. The Forth definition is generated using a CREATE DOES>
;   construct, Forth's poor man's objects of the 1970's. We will elaborate on this later.
;

        ;
figrel  =     6
dummymask   =     0x01
invisiblemask   =     0x02
immediatemask   =     0x04
denotationmask   =     0x08
prefixmask = immediatemask+denotationmask
epipe   =     0x20
;
;  The virtual machine reserves some of the Intel registers for its own.
;  In the first place we need an interpretation pointer, to keep track
;  of where we are in the interpreted code. It points to the -- high
;  level -- instruction that is to be executed after the current
;  definitions finishes. This is similar to the program counter in an
;  assembly program and we will use SI for it.
;  Then of course we need a data stack, for which we use
;  the Intel stack, and the stack pointer is just SP.
;  This leaves us with the return stack, that keeps track of
;  where we are. Whenever SI is needed to interpret another high
;  level definition, the previous value is stored there, and restored
;  when we want to continue with the calling definition.
;  Intel has run out of stacks
;  already, but we can emulate a stack using the BP register.
;  It just means that we have to use a couple of instructions to push
;  SI, or pop it.
;
;  Within yourforth you have the constants DSP0 and RSP0 that contain
;  the initial stack pointers for the data and the return stack
;  respectively. [ ex. 2 ]
;   COLD is the Forth definition that starts
;  up Forth. So we load the registers SP and BP with the data field of
;  DSP0 and RSP0 and SI with the post header address of COLD, where its
;  Forth code resides. It ends with machine code that results in executing
;  the next Forth instruction. This is done all the time, so we have
;  a shorthand for it, called next.

macro   next {
        lodsd
        jmp     dword[eax]
}

; Now the choice for SI becomes clear. The lodsd instruction loads the dea
; from the instruction stream into EAX, and increments SI on the way,
; making it point to the next Forth instruction.
; [Actually this is a bit tricky. This requires that the so called
; direction bit is set to forward, using the instruction cld. After
; executing the instruction std, lodsd is switched to decrementing.
; We keep the forward direction always.]
; Then we jump to what is contained in the code field of the dea, so actually
; [eax+0*cw] . We rely on that code to end again with a ``next'', and if
; it needs to use SI (e.g. for nesting), it must restore it beforehand.
; exercise with (CREATE)
; Executing the code is started with an eax that contains the dea of the
; word. So even if the code field is filled with the same pointer,
; the objects data is different and results in different data or even different
; action. OO fan's will recognize this, it is just a self pointer.

        cld     ; This direction must never change, or next stops working
        mov     esp, [DSP_zero+1*cw]
        mov     ebp, [RSP_zero+1*cw]
        mov     esi, COLD+5*cw
        next
;
; The following word is our first high level Forth word or "colon definition"
; in Forth speak.
header  BYE,   docol, BYE+5*cw, 0, FORTH, "BYE"
    dd      _zero_, _, _,   _one_, XOS
    dd      EXIT

; Executing this words means that the program jumps to address docol that takes
; care that SI is going to point to _zero_ , then does next.
; This is possible because eax contains the address BYE of this header
; as discussed with the description of the next macro.

docol:  lea     ebp,[ebp - 1*cw]        ; Push SI on the return stack
        mov     [ebp],esi
        mov     esi,[eax+1*cw]          ; Fill it with the data field
        next

; In the case of BYE the data field contains BYE+5*cw, which is the address
; that contains _zero_.
; So now we have it. Consecutively _zero_ _ _ _one XOS and EXIT are executed.
; The word XOS finds 0 X X 1 on the stack, which instructs it to do linux
; system call 1 (an exit) with one parameter 0 and two dummy parameters.
; This ends the Forth session with a status code of 0, meaning okay. (exercise).

; [One last remark. Because BYE is our first definition, you may expect it to
; have a link of 0 and to be it last in the linked list. But we want the
; word FORTH and the denotations to come last, yet not discuss them until later.]
;
; EXIT is the reverse of docol. ( In the above case EXIT is not reached.)
; This is our first example of a low level word, or "code definition".
; You see that we use our lastlink trick as described with the header macro.

    header  EXIT,   EXIT+5*cw, 0, 0, lastlink, "EXIT"
        mov     esi,[ebp]               ; Pop SI from the return stack
        lea     ebp,[ebp+1*cw]
        next

; The next executed at the end of the FORTH instruction before EXIT,
; jumps to EXIT+5*cw which is the mov instruction.
; So EXIT just abandons the current SI and loads it with what docol has left.
; Note that the data field is not used and the content of AX is not used.

; Because you understand Intel assembly language a bit, I present you
; with a table of the 5 instructions of the virtual machine:
;     Forth machine      cells            Intel equivalent
;     DEA, invocation     1               call XXX
;     EXIT                1               rts
;     BRANCH rel          2               jr rel
;     0BRANCH rel         2               jz rel
;     LIT value           2               pushi value
;     expandable          your choice     whatever
;
; That is all there is to it. If it seems few,
; let me remind you that all operations like + fall under the
; invocation of a definition. The conditional jump can be used to
; construct if-endif's (called IF THEN 's in Forth) and begin-until's.
; Together with the unconditional jump you can have all control
; constructs.  EXIT BRANCH 0BRANCH LIT are the names of actual
; definitions in the dictionary. Their invocation is the same as
; for just any DEA.
; The last line I put in to remind you that this is not the end of it.
; You can add basic constructs e.g. special looping constructs later.
; You can use assembler language in defining it, and you can do this
; in a separate file, that you will choose to include, or not.
; FIXME: actual those looping are still built in.

; LIT does something very similar to next, it fetches
; the cell from SI with auto increment, using the now familiar
; lodsd instruction. Now we have to put that on the data stack.
    header  LIT,   LIT+5*cw, 0, 0, lastlink, "LIT"
        lodsd
        push    eax
        next

; BRANCH also fetches a cell in line that serves as an offset to SI.
; The three instruction
; following round it up to a multiple of cw, an action that is called
; alignment. Why that is done, we'll come back to later.
; Normally the offset is a multiple of cw and nothing happens.
; Si is incremented with the offset and
; code is hence to forth fetched from there.

    header  BRANCH,   BRANCH+5*cw, 0, 0, lastlink, "BRANCH"
BRAN1:  lodsd
        dec     eax
        or      al,  cw - 1
        inc     eax
        add     esi,eax
        next
; 0BRANCH is similar to BRANCH. The difference is just that before
; the offset is added, it can be zeroed. This depends on a flag
; popped from the data stack.
    header  zero_BRANCH,   zero_BRANCH+5*cw, 0, 0, lastlink, "0BRANCH"
        lodsd
        pop     ebx
        or      ebx,ebx
        jz      ZBRAN1
        xor     eax,eax
ZBRAN1: add     esi,eax
        next
; This completes the virtual Forth machine that is used in yourforth.
; You can however at all times add anything that you can think off.

; Probably you will find 0BRANCH confusing and hard to find out what
; code is executed with what flag.
; Also here again we want the offsets calculated for us.
; This leads us to define some macro's.
macro goto  label
{ dd  BRANCH, label-$-cw   }

; 0BRANCH always emulate a control structure, and different macros
; are used to show which one.
macro ifto  label
{ dd  zero_BRANCH, label-$-cw   }
macro whileto  label
{ dd  zero_BRANCH, label-$-cw   }
macro untilto  label
{ dd  zero_BRANCH, label-$-cw   }
; They all have in common that on the preceeding condition
; being true/non-zero/on,
; the code following is executed. Otherwise we skip to "label".
; For ifto that code is executed once up till "label".
; For whileto the code following
; is part of the loop, so we stay in the loop. The label is where we want
; to jump out of the loop.
; For untilto the code following is outside of a loop, so we fall through
; on a true condition. Now the label is the start of the loop.
;  Don't worry, Forthers hate complicated control structures. In the
;  code of <your>forth you will not find a single nested loop.
;
;
; -------------------- low level definitions: operators ----------------------------
; Operators are definitions that take all inputs from the stack,
; do some transformation and put all results back on the stack. In other
; words they have no side effects. Because they are so simple and fundamental
; they are mostly written in assembler.
; Examples are operations like + or <.

; This words does nothing.
    header  NOOP,   NOOP+5*cw, 0, 0, lastlink, "NOOP"
       next
; Another word that does almost nothing, it pushes a "whatever" value to the
;  stack
    header  _,   _+5*cw, 0, 0, lastlink, "_"
        push    eax
        next
; -------------------- low level definitions: stack operations -----------------
; Stack operations reorder, duplicate or remove items from the data stack
; without doing a transformation on them. They are essential to Forth, of course.
    header  _DUP_,   _DUP_+5*cw, 0, 0, lastlink, "DUP"
        pop     eax
        push    eax
        push    eax
        next
    header  OVER,   OVER+5*cw, 0, 0, lastlink, "OVER"
        pop     edx
        pop     eax
        push    eax
        push    edx
        push    eax
        next
    header  SWAP,   SWAP+5*cw, 0, 0, lastlink, "SWAP"
        pop     edx
        pop     eax
        push    edx
        push    eax
        next
    header  DROP,   DROP+5*cw, 0, 0, lastlink, "DROP"
        pop     eax
        next
    header  NIP,   NIP+5*cw, 0, 0, lastlink, "NIP"
        pop     eax
        pop     ebx
        push    eax
        next
    header  two_DROP,   two_DROP+5*cw, 0, 0, lastlink, "2DROP"
        pop     eax
        pop     eax
        next
    header  two_DUP,   two_DUP+5*cw, 0, 0, lastlink, "2DUP"
        pop     eax
        pop     edx
        push    edx
        push    eax
        push    edx
        push    eax
        next
    header  two_SWAP,   two_SWAP+5*cw, 0, 0, lastlink, "2SWAP"
        pop     ebx
        pop     ecx
        pop     eax
        pop     edx
        push     ecx
        push     ebx
        push    edx
        push    eax
        next
    header  two_OVER,   two_OVER+5*cw, 0, 0, lastlink, "2OVER"
        pop     ebx
        pop     ecx
        pop     eax
        pop     edx
        push     edx
        push     eax
        push     ecx
        push     ebx
        push    edx
        push    eax
        next
; The return stack can be used for scratch. For an example see SDSWAP
    header  to_R,   to_R+5*cw, 0, 0, lastlink, ">R"
        pop     ebx
        lea     ebp,[ebp - 1*cw]
        mov     [ebp],ebx
        next
    header  R_from,   R_from+5*cw, 0, 0, lastlink, "R>"
        mov     eax,[ebp]
        lea     ebp,[ebp + 1*cw]
        push    eax
        next
    header  R_fetch ,   R_fetch +5*cw, 0, 0, lastlink, "R@"
        mov     eax,[ebp]
        push    eax
        next
; SDSWAP reorders a,b1,b2 on the stack into b1,b2,a.
; We have no way to directly get b1 into place, but if we first
; move b2 out of the way to the return stack, we can, by swapping.
; Now get b2 back, leaving b1,a,b2. That we can handle.
    header  SDSWAP,   docol, SDSWAP+5*cw, 0, lastlink, "SDSWAP"
        dd      to_R    ; Get b2 out of the way.
        dd      SWAP    ; a,b1 --> b1,a
        dd      R_from  ; b1,a,b2 : almost correct
        dd      SWAP
        dd      EXIT
; ------------------------------------------------------------------------------
; In yourforth a stack is just a block of memory set aside for the purpose.
; We need a few words to control the stacks.
    header  DSP_fetch,   DSP_fetch+5*cw, 0, 0, lastlink, "DSP@"
        mov     eax,esp
        push    eax
        next
    header  DSP_store,   DSP_store+5*cw, 0, 0, lastlink, "DSP!"
        pop     eax
        mov     esp,eax
        next
    header  DEPTH,   docol, DEPTH+5*cw, 0, lastlink, "DEPTH"
        dd      DSP_zero
        dd      DSP_fetch
        dd      _minus_
        dd      LIT, cw, _slash_
        dd      _one_, _minus_
        dd      EXIT
    header  RSP_fetch,   RSP_fetch+5*cw, 0, 0, lastlink, "RSP@"
        push    ebp
        next
    header  RSP_store,   RSP_store+5*cw, 0, 0, lastlink, "RSP!"
        pop     ebp
        next
; ---------------------------- operators with results ------------
; Apart from the reordering or duplicating operators, there is a whole slew of
; operators that have no side effects, i.e. the only result is on the
; stack.
; All the usual logical and arithmetical operators are present in Forth,
; but in this Forth there is nothing floating point related.

; 0<> is the most fundamental of logical operators.
; It takes a dirty flag, anything not zero, and turns it into a proper
; flag, i.e. all bits set. A false flag, zero, remains zero.
; Its code is interesting. neg subtracts the number from zero, which generates
; a borrow if it was not zero. So it transfers the flag to the carry bit.
; sbb transfers the carry bit to a flag in a register. Subtracting a
; register from itself with borrow generates a zero, unless the borrow
; was set to begin with.
    header  zero_unequal,   zero_unequal+5*cw, 0, 0, lastlink, "0<>"
        pop    eax
        neg    eax
        sbb    eax,eax
        push   eax
        next
; Now 0= is easy. To 0<> add an instruction to complement the carry flag
    header  zero_equal,   zero_equal+5*cw, 0, 0, lastlink, "0="
        pop     eax
        neg     eax
        cmc
        sbb     eax,eax
        push    eax
        next
; NOT is just an other name for 0=. We copy the code field of "0="
    header  _NOT_,   (zero_equal+5*cw),  0, 0, lastlink, "NOT"
    header  zero_less,   zero_less+5*cw, 0, 0, lastlink, "0<"
        pop     eax
        shl     eax,1      ; Move eax's sign bit into the carry bit.
        sbb     eax,eax
        push    eax
        next
    header  NEGATE,   NEGATE+5*cw, 0, 0, lastlink, "NEGATE"
        pop     eax
        neg     eax
        push    eax
        next
    header  INVERT,   INVERT+5*cw, 0, 0, lastlink, "INVERT"
        pop     eax
        not     eax
        push    eax
        next
    header  ALIGNED ,   ALIGNED +5*cw, 0, 0, lastlink, "ALIGNED"
        pop     eax
        dec     eax
        or      eax,  1*cw-1
        inc     eax
        push    eax
        next
    header  one_plus,   docol, one_plus+5*cw, 0, lastlink, "1+"
        dd      _one_
        dd      _plus_
        dd      EXIT
    header  CELL_plus,   docol, CELL_plus+5*cw, 0, lastlink, "CELL+"
        dd      LIT, cw
        dd      _plus_
        dd      EXIT
    header  CELLS,   docol, CELLS+5*cw, 0, lastlink, "CELLS"
        dd      LIT, 2
        dd      LSHIFT
        dd      EXIT

; The archetype of an arithmetic operator, pop 2 registers, add them
; and push the result.
    header  _plus_,   _plus_+5*cw, 0, 0, lastlink, "+"
        pop     eax
        pop     ebx
        add     eax,ebx
        push    eax
        next
    header  _AND_,   _AND_+5*cw, 0, 0, lastlink, "AND"
        pop     eax
        pop     ebx
        and     eax,ebx
        push    eax
        next
    header  _OR_,   _OR_+5*cw, 0, 0, lastlink, "OR"
        pop     eax
        pop     ebx
        or      eax,ebx
        push    eax
        next
    header  _XOR_,   _XOR_+5*cw, 0, 0, lastlink, "XOR"
        pop     eax
        pop     ebx
        xor     eax,ebx
        push    eax
        next
    header  _minus_,   _minus_+5*cw, 0, 0, lastlink, "-"
        pop     edx
        pop     eax
        sub     eax,edx
        push    eax
        next
; Intel has a set instruction that moves the condition we need (such as equality)
; into the least significant bit of AX.
    header  _equal_,   _equal_+5*cw, 0, 0, lastlink, "="
         pop     edx
         pop     ebx
         xor     eax,eax  ; Zero all of AX
         cmp     ebx,edx
         sete    al       ; Set least significant bit according to "equal"
         neg     eax      ; 1 -> -1 : a proper flag
         push    eax
         next
    header  _unequal_,   _unequal_+5*cw, 0, 0, lastlink, "<>"
         pop     edx
         pop     ebx
         xor     eax,eax
         cmp     ebx,edx
         setne    al      ; Set bit to "not equal"
         neg     eax
         push    eax
         next
     header  _less_,   _less_+5*cw, 0, 0, lastlink, "<"
         pop     edx
         pop     ebx
         xor     eax,eax
         cmp     ebx,edx
         setl    al       ; Set bit to "less"
         neg     eax
         push    eax
         next
     header  _greater_,   _greater_+5*cw, 0, 0, lastlink, ">"
         pop     edx
         pop     ebx
         xor     eax,eax
         cmp     ebx,edx
         setg    al       ; Set bit to "greater"
         neg     eax
         push    eax
         next
    header  LSHIFT,   LSHIFT+5*cw, 0, 0, lastlink, "LSHIFT"
        pop     ecx
        pop     eax
        shl     eax,cl
        push    eax
        next
    header  RSHIFT,   RSHIFT+5*cw, 0, 0, lastlink, "RSHIFT"
        pop     ecx
        pop     eax
        shr     eax,cl
        push    eax
        next
; ------------------------------------------------------------------------------
; Not all basic instruction must be in assembler. The following operators
; are defined as Forth code, They are simple so you can get used
; to how Forth code looks if expressed in assembler languages.

; To get the absolute value, if it is less than zero, negate it.
    header  _ABS_,   docol, _ABS_+5*cw, 0, lastlink, "ABS"
        dd      _DUP_, zero_less    ; Leave condition
        ifto  abs1                  ; Assembles : 0BRANCH offset
            dd      NEGATE          ; Execute conditionally
        abs1:                       ; Auxiliary label to mark the end.
        dd      EXIT
    header  MIN,   docol, MIN+5*cw, 0, lastlink, "MIN"
        dd      two_DUP, _greater_
        ifto  min1
            dd      SWAP
        min1:
        dd      DROP
        dd      EXIT
    header  MAX,   docol, MAX+5*cw, 0, lastlink, "MAX"
        dd      two_DUP, _less_
        ifto  max1
            dd      SWAP
        max1:
        dd      DROP
        dd      EXIT
; ------------------------------------------------------------------------------
; 32 by 32 bit signed multiplication, with 64 bit product.
; The basic low level word for all multiplications.
    header  M_star,   M_star+5*cw, 0, 0, lastlink, "M*"
        pop     eax
        pop     ebx
        imul     ebx
        xchg    eax,edx
        push    edx
        push    eax
        next
; 64 by 32 bit signed division, with 32 bit quotient and remainder.
; The basic low level word for all divisions and modulo.
    header  SM_slash_REM,   SM_slash_REM+5*cw, 0, 0, lastlink, "SM/REM"
        pop     ebx
        pop     edx
        pop     eax
        idiv     ebx
        push    edx
        push    eax
        next
; ------------------------------------------------------------------------------
; Regular cell*cell to cell multiplication.
; It is assumed that the result fits in a cell!
    header  _star_,   docol, _star_+5*cw, 0, lastlink, "*"
        dd      M_star
        dd      DROP    ; Drop m.s. part.
        dd      EXIT
; Regular cell by cell /MOD. Use the return stack to move the
; divider out of the way.
    header  slash_MOD,   docol, slash_MOD+5*cw, 0, lastlink, "/MOD"
        dd      to_R
        dd      _DUP_, zero_less  ; Sign extend 32->64
        dd      R_from            ; Ready for 64 by 32.
        dd      SM_slash_REM
        dd      EXIT
    header  _slash_,   docol, _slash_+5*cw, 0, lastlink, "/"
        dd      slash_MOD
        dd      NIP
        dd      EXIT
    header  _MOD_,   docol, _MOD_+5*cw, 0, lastlink, "MOD"
        dd      slash_MOD
        dd      DROP
        dd      EXIT
    header  star_slash_MOD,   docol, star_slash_MOD+5*cw, 0, lastlink, "*/MOD"
        dd      to_R
        dd      M_star
        dd      R_from
        dd      SM_slash_REM
        dd      EXIT
    header  star_slash,   docol, star_slash+5*cw, 0, lastlink, "*/"
        dd      star_slash_MOD
        dd      NIP
        dd      EXIT
; --------------------- memory store and fetch ---------------------------------

    header  _fetch_,   _fetch_+5*cw, 0, 0, lastlink, "@"
        pop     ebx
        mov     eax,[ebx]
        push    eax
        next
    header  C_fetch,   C_fetch+5*cw, 0, 0, lastlink, "C@"
        pop     ebx
        xor     eax,eax
        mov     al,[ebx]
        push    eax
        next
    header  two_fetch,   two_fetch+5*cw, 0, 0, lastlink, "2@"
        pop     ebx
        mov     eax,[ebx]
        mov     edx,[ebx+1*cw]
        push    edx
        push    eax
        next
    header  _store_,   _store_+5*cw, 0, 0, lastlink, "!"
        pop     ebx
        pop     eax
        mov     [ebx],eax
        next
    header  C_store,   C_store+5*cw, 0, 0, lastlink, "C!"
        pop     ebx
        pop     eax
        mov     [ebx],al
        next
    header  two_store,   two_store+5*cw, 0, 0, lastlink, "2!"
        pop     ebx
        pop     eax
        mov     [ebx],eax
        pop     eax
        mov     [ebx+1*cw],eax
        next
    header  plus_store,   plus_store+5*cw, 0, 0, lastlink, "+!"
        pop     ebx
        pop     eax
        add     [ebx],eax
        next
; ------------------------- string operations --------------------------------
; In yourforth itself we have elevated strings slightly to a low abstraction
; level, just enough to forget about the individual characters.
; We introduced the macro "string" that lay down a string in memory.
; If we know the address, we can fetch the string and type it.
; On the other hand we can store an (address, length) pair at the
; buffer.
    header  string_fetch,   string_fetch+5*cw, 0, 0, lastlink, "$@"
;;;;;;;;dd    _DUP_, CELL_plus, _SWAP_, _fetch_, EXIT
        pop   ebx
        mov   eax,[ebx]
        lea   edx, [ebx+1*cw]
        push    edx
        push    eax
        next
; Storing a string in memory involves copying a row of bytes.
; MOVE is another fundamental instruction, defined in the next section.
; It is a natural building block of string operations.
    header  string_store,   docol, string_store+5*cw, 0, lastlink, "$!"
        dd two_DUP, _store_, CELL_plus, SWAP, _MOVE_
        dd EXIT
    header  string_plus_store,   docol, string_plus_store+5*cw, 0, lastlink, "$+!"
        dd   _DUP_, _fetch_, to_R
        dd   two_DUP, plus_store
        dd   CELL_plus, R_from, _plus_, SWAP, _MOVE_
        dd EXIT
    header  string_C_plus,   docol, string_C_plus+5*cw, 0, lastlink, "$C+"
        dd   _DUP_, to_R
        dd   _DUP_, _fetch_, _plus_, CELL_plus, C_store
        dd   _one_, R_from, plus_store
        dd EXIT
; This is the Forth equivalent of the "string" macro we use in this source
;  all the time, be it within the "header" macro.
    header  string_comma,   docol, string_comma+5*cw, 0, lastlink, "$,"
        dd HERE, to_R
        dd _DUP_, CELL_plus, ALLOT
        dd R_fetch, string_store, R_from
        dd _ALIGN_
        dd EXIT
; ----------------- low level block operations ------------------------------------------
; Operations on blocks of memory. It is of some importance that they are fast.
; We need to move a block of memory, initialise it and compare two blocks.
; They are in fact wrappers around "rep movsb" "rep stosb" and "rep cmpsb".

    header  _MOVE_,   _MOVE_+5*cw, 0, 0, lastlink, "MOVE"
        mov     ebx,esi
        pop     ecx
        pop     edi
        pop     esi
        cmp     esi,edi
        jc    MOVE1
        jmp short MOVE2
MOVE1:  std
        add     edi,ecx
        dec     edi
        add     esi,ecx
        dec     esi
MOVE2:
        rep     movsb
        cld           ; Make sure the direction is forward again.
        mov     esi,ebx
        next
    header  FILL,   FILL+5*cw, 0, 0, lastlink, "FILL"
        pop     eax
        pop     ecx
        pop     edi
        cld
        rep     stosb
        next
    header  CORA,   CORA+5*cw, 0, 0, lastlink, "CORA"
        mov     edx,esi
; Default result of zero.
; Also set the zero bit, which is essential if the count is zero.
        xor     eax,eax
        pop     ecx
        pop     edi
        pop     esi
        cld
        repz    cmpsb
        jz      CORA3
        mov     al,1
        jnc     CORA3
        neg     eax
CORA3:
        mov     esi,edx
        push    eax
        next
; ------------------------------------------------------------------------------
; In Forth functions or words are first class citizens. That just means that
; they can be passed around as is. The token used for this is of course dea.
; 'fun is comparable to fun without the brackets in c.
; Then when you want to "call" fun, you need this word. In Forth we say that
; we execute the word.
    header  EXECUTE,   EXECUTE+5*cw, 0, 0, lastlink, "EXECUTE"
        pop     eax
        jmp     dword[eax]

; ------------------------------------------------------------------------------
; This leaves a pointer to a character to be found in a string, a fundamental
; operation in parsing and used at critical points in yourforth.
;
    header  string_pointer,   string_pointer+5*cw, 0, 0, lastlink, "$^"
        pop     eax
        pop     ecx
        pop     edi
        or      esi,esi
        cld
        repnz     scasb
        jz      SINDEX1
        xor     edi,edi
        inc     edi
SINDEX1:
        dec     edi
        push    edi
        next
; This splits a string at a character, another fundamental
; operation in parsing and used at critical points in yourforth.
;
    header  string_slash,   string_slash+5*cw, 0, 0, lastlink, "$/"
        pop     eax
        pop     ecx
        mov     ebx,ecx
        pop     edi
        or      edi,edi
        mov     edx,edi
        cld
        repnz     scasb
        jz      SSLAS1
        push    ecx
        jmp short SSLAS2
SSLAS1:
        push    edi
        sub     ebx,ecx
        dec     ebx
SSLAS2:
        push    ecx
        push    edx
        push    ebx
        next
;------------------------------------------------------------------------------
; There is just one thing left to complete our set of primitive
; operations that make up our Forth engine. That is the interface to the
; Operating System Linux. This cannot possibly be defined in a high
; level language, e.g. you will find it as embedded assembler in gcc.
; From here on we can define everything in Forth, i.e. using docol.
    header  XOS,   XOS+5*cw, 0, 0, lastlink, "XOS"
        pop     eax
        pop     edx
        pop     ecx
        pop     ebx
        int     0x80
        push    eax
        next

; ---------------------- high level --------------------------------------------
; You are now familiar with the low level interpreter. The interaction with the
; user and the console or terminal is next. It is similar to a shell, in fact Forth
; is a shell of sorts. The commands are accepted on the standard input, which is
; file descriptor 0 , and the answers are given on standard output, which is file
; descriptor 1. In all error situations yourforth prints an error number on standard
; output. Redirection of input and output works in a standard Unix fashion using
; pipe and redirect symbols in the line that starts up yourforth, e.g.
; (cat examples/bench.frt; echo DO-PRIME-ISO) | yourforth
; This behaves. yourforth knows when the input stops, and doesn't try to print 'OK'.
; All the line-editing applicable to your terminal just works, as well as cutting
; and pasting code with the mouse. (exercise).

; The basic parsing revolves around three variables: the start of the parse area,
; its end, and the parse pointer. Those are three fields in SRC.

; PP points to the last cell of SRC.
    header  PP,   dobuf, SRC+5*cw + 2*cw, 0, lastlink, "PP"
    header  SRC,   dobuf, SRC+5*cw, 0, lastlink, "SRC"
        dd      _, _, _
; Because we sometimes need the character, sometimes a pointer, PP@@ returns
; a pointer after the last character fetched and the character itself.
    header  PP_fetch_fetch,   docol, PP_fetch_fetch+5*cw, 0, lastlink, "PP@@"
        dd      SRC, CELL_plus, two_fetch
        dd      OVER, _equal_
        ifto  then2
        dd      _zero_
        goto  else2
then2:
        dd      _DUP_
        dd      C_fetch
        dd      _one_, PP, plus_store
else2:
        dd      EXIT

; The parsing can be nested, The following two words save and restore the
; total parse state.
    header  SAVE,   docol, SAVE+5*cw, 0, lastlink, "SAVE"
        dd      R_from
        dd      SRC, two_fetch
        dd      PP, _fetch_
        dd      to_R, to_R, to_R
        dd      to_R
        dd EXIT
    header  _RESTORE_,   docol, _RESTORE_+5*cw, 0, lastlink, "RESTORE"
        dd      R_from
        dd      R_from, R_from, R_from
        dd      PP, _store_
        dd      SRC, two_store
        dd      to_R
        dd EXIT
; To complement the above SET-SRC : a word that sets the parse state from a string.
; This is all we need, a file can be transformed into a string in memory.
    header  SET_SRC,   docol, SET_SRC+5*cw, 0, lastlink, "SET-SRC"
        dd      OVER, _plus_
        dd      OVER, SRC, two_store
        dd      PP, _store_
        dd      EXIT

; PP@@ is the basis of parsing numbers, strings and other special notations,
; and is used extensively by the prefixes. For now we will just use it for the
; basic syntactic element of Forth, a blank delimited string.
    header  NAME,   docol, NAME+5*cw, 0, lastlink, "NAME"
        dd      _
begin1: dd      DROP
        dd      PP_fetch_fetch, query_BLANK, _NOT_
        dd      OVER, SRC, CELL_plus, _fetch_, _equal_
        dd      _OR_
        untilto   begin1
        dd      _
begin2: dd      DROP
        dd      PP_fetch_fetch, query_BLANK
        untilto   begin2
        dd      OVER, _minus_
        dd      EXIT

; Irrespective of whether the parse area is a line typed in at the console,
; a file buffer or a string, the interpreting is based on a NAME.
; After separating off a blank delimited string it is passed to FOUND that
; always returns a matching word from the dictionary. This involves some
; magic that we will cover later. It can't fail. The mini-interpreters in the
; prefix words may issue an error.
; Normally the parse pointer is always advanced past the name of the word found,
; not the name in the input stream. On the other hand prefixes there is left a part
; to interpret themselves.                                          *
; So for a normal word we have
; .......... DROP .......
;                ^
;                |
;               PP
; and for a prefix like 0x
; .......... 0x1793 ....
;              ^
;              |
;             PP
; and for the catchall prefix that is an empty string:
; .......... 42 ....
;            ^
;            |
;           PP
; Catchall wants it to be a number, so nonsense words get an error 10.
; .......... !@#$probablynonsense ....
;            ^
;            |
;           PP

; The word INTERPRET knows nothing. It just EXECUTE 's or compiles, using comma.
; Comma expands the dictionary space with data. We'll come back to that.
; STATE regulates this, it is a global control flag.
; So STATE tells us when we are composing a definition between a colon and a semicolon.
; Some words are to be executed despite being in this "compilation state".
; An example is the prefix 0x. It must interpret the remainder till a blank,
; and then compile the resulting number. Compiling a number is different from
; just putting it on the stack, so you should expect 0x to be inspecting STATE.
; That is it for now, more details follow when we treat those prefixes.
; Other examples are auxiliary words for structured programming.
; During compilation there must be a way to calculate those pesky offsets
; for BRANCH automatically. But the we have to do those calculations then and
; there.

    header  INTERPRET,   docol, INTERPRET+5*cw, 0, lastlink, "INTERPRET"
begin3:
        dd      NAME
        dd      _DUP_
        whileto   inte8
        dd      OVER, to_R       ; Remember start of word.
        dd      FOUND
;Skip over the part that is matched, this is the whole word, unless it is a prefix
        dd      _DUP_, to_NFA, _fetch_, _fetch_
        dd      R_from, _plus_, PP, _store_
        dd      _DUP_, to_FFA, _fetch_, LIT, immediatemask, _AND_
        dd      STATE, _fetch_, zero_equal, _OR_
        ifto  else1
        dd      EXECUTE
        goto  endif1
else1:   dd      _comma_
endif1: dd      query_STACK
        goto  begin3

inte8:  dd      DROP, DROP
        dd      EXIT
; EVALUATE is a straightforward combination of setting the parse area, and
; interpreting it. There is one catch. There may be an error during interpretaton,
; and this could mix up the different sources. In yourforth there are no
; resources like open files that must be closed, but they would be left open
; if the error were allowed to propagate to the top level.
; In yourforth you need it in case you want to handle errors before it leads to a message.
    header  EVALUATE,   docol, EVALUATE+5*cw, 0, lastlink, "EVALUATE"
        dd      SAVE
        dd      SET_SRC
        dd      LIT, INTERPRET, CATCH
        dd      _RESTORE_
        dd      THROW
        dd      EXIT
; And then there is the interpret loop: accept user input, interpret line, repeat.
; It is called QUIT in Forth, a strange name until you realize that you can
; put QUIT anywhere in a program and restart basic user interaction.
; This is a seldomly used debugging tool, QUIT leaves the whole program as is,
; and even the data stack can be inspected. (Only errors clear the data stack, and CLS.)
; QUIT is the start of everything, you can only INCLUDE a file by typing an INCLUDE
; command. (But there is a thing called redirection in Linux.)
; Note that QUIT starts with setting a defined state. STATE is set to interpreting,
; all nesting is abandonned, and the error handling is reset.
; We *do* want to terminate by BYE if the user types ^D to end the session and *certainly*
; if the input ends in the case of redirection. (exercise)
; (ACCEPT) just returns a string the user types after ending it with <return>,
; a simple functionality that is not simple internally.
; Ignoring details we just have
;       : QUIT BEGIN (ACCEPT) SET-SRC INTERPRET OK AGAIN ;
    header  QUIT,   docol, QUIT+5*cw, 0, lastlink, "QUIT"
        dd      left_bracket
        dd      RSP_zero, RSP_store
        dd      _zero_, HANDLER, _store_
QUIT1:
        dd      LIT, paren_ACCEPT
        dd      CATCH
        dd      _DUP_, LIT, -epipe, _equal_
        ifto  ENDIF7
        dd      BYE
ENDIF7:
        dd      _zero_, MIN, _DUP_, query_ERROR
        dd      one_plus                ; Include line feed again.
        dd      SET_SRC
        dd      INTERPRET
        dd      OK
        goto  QUIT1
        dd      EXIT

; OK is the first word we encounter that has a string literal inside.
; BRANCH makes us jump over the string. This usage is the reason that
; there is an alignment inside BRANCH. In this way, we continue at the LIT
; after the string even if it doesn't precisely fills up cells.
; You can see that the string macro is compatible with our $@ word.
    header  OK,   docol, OK+5*cw, 0, lastlink, "OK"
        dd      STATE
        dd      _fetch_
        dd      zero_equal
        ifto  OK2
        dd      BRANCH
sb2:
        string    " OK"          ; Without the space: un ugly collation.
        dd      LIT, sb2
        dd      string_fetch
        dd      _TYPE_
        dd      CR
OK2:
        dd      EXIT

; ---------------------- high level --------------------------------------------
    header  DIGIT,   docol , DIGIT+5*cw, 0, lastlink, "DIGIT"
        dd      LIT, '0'
        dd      OVER, LIT, '9', _greater_
        ifto  then1
        dd      DROP, LIT, 'A'-10
then1:  dd      _minus_
        dd      _DUP_, zero_less, OVER, BASE, _fetch_, _less_, _NOT_, _OR_
        dd      EXIT
    header  no_MATCH,   docol, no_MATCH+5*cw, 0, lastlink, "~MATCH"
        dd      to_R
        dd      two_DUP
        dd      R_fetch, to_NFA, _fetch_, string_fetch
        dd      SDSWAP, MIN
        dd      CORA           ; CORA gives 0 for match.
        dd      R_from, SWAP
        dd      EXIT
;       : ~MATCH   >R   2DUP R@ >NFA @ $@   ROT MIN   CORA  R> SWAP ;
    header  query_BLANK,   docol, query_BLANK+5*cw, 0, lastlink, "?BLANK"
        dd      _BL_, one_plus, _less_
        dd      EXIT
    header  PARSE,   docol, PARSE+5*cw, 0, lastlink, "PARSE"
        dd      SRC, CELL_plus, two_fetch
        dd      OVER, _minus_
        dd      SDSWAP, string_slash, two_SWAP
        dd      zero_equal
        ifto  PARSE8
        dd      DROP, SRC, CELL_plus, _fetch_
PARSE8:
        dd      PP, _store_
        dd      EXIT
    header  CR,   docol, CR+5*cw, 0, lastlink, "CR"
        dd      LIT,0x0A
        dd      EMIT
        dd      EXIT
    header  SPACE,   docol, SPACE+5*cw, 0, lastlink, "SPACE"
        dd      _BL_
        dd      EMIT
        dd      EXIT
; ---------------- ??defining?? ------------------------------------------------
    header  TOGGLE,   docol , TOGGLE+5*cw, 0, lastlink, "TOGGLE"
        dd      OVER, _fetch_, _XOR_, SWAP, _store_
        dd      EXIT
    header  _colon_,   docol, _colon_+5*cw, 0, lastlink, ":"
        dd      NAME
        dd      paren_CREATE
        dd      LATEST, HIDDEN
        dd      LIT, docol, LATEST, to_CFA, _store_
        dd      right_bracket
        dd      EXIT
    header  _semis_,   docol, _semis_+5*cw, immediatemask, lastlink, ";"
        dd      LIT, EXIT, _comma_
        dd      LATEST, HIDDEN
        dd      left_bracket
        dd      EXIT
    header  CONSTANT,   docol, CONSTANT+5*cw, 0, lastlink, "CONSTANT"
        dd      NAME
        dd      paren_CREATE
        dd      LATEST, to_DFA, _store_
        dd      LIT, docon, LATEST, to_CFA, _store_
        dd      EXIT
docon:  mov     eax,[eax+1*cw]     ; dea -> data
        push    eax
        next
    header  VARIABLE,   docol, VARIABLE+5*cw, 0, lastlink, "VARIABLE"
        dd      NAME
        dd      paren_CREATE
        dd      _zero_, _comma_
        dd      LIT, dobuf, LATEST, to_CFA, _store_
        dd      EXIT
dobuf:  mov     eax,[eax+1*cw]    ; dea -> data
        push    eax
        next
; ------------------------------------------------------------------------------
    header  _zero_,   docon, 0, 0, lastlink, "0"
    header  _one_,   docon, 1, 0, lastlink, "1"
    header  _BL_,   docon, ' ', 0, lastlink, "BL"
; ------------------------------------------------------------------------------
    header  _BM_,   docon, bm, 0, lastlink, "BM"
    header  _EM_,   docon, em, 0, lastlink, "EM"
    header  DSP_zero,   docon, initdsp0 , 0, lastlink, "DSP0"
    header  RSP_zero,   docon, initrsp0  , 0, lastlink, "RSP0"
    header  CIB,   docon, initcib , 0, lastlink, "CIB"
; ------------------------------------------------------------------------------
    header  _DP_,   dobuf, _DP_+5*cw, 0, lastlink, "DP"
        dd      initdp
    header  _ALIGN_,   docol , _ALIGN_+5*cw, 0, lastlink, "ALIGN"
        dd      _DP_, _fetch_
        dd      ALIGNED
        dd      _DP_, _store_
        dd      EXIT
    header  HERE,   docol, HERE+5*cw, 0, lastlink, "HERE"
        dd      _DP_
        dd      _fetch_
        dd      EXIT
    header  ALLOT,   docol, ALLOT+5*cw, 0, lastlink, "ALLOT"
        dd      _DP_
        dd      plus_store
        dd      EXIT
    header  _comma_,   docol, _comma_+5*cw, 0, lastlink, ","
        dd      HERE
        dd      LIT
        dd      cw
        dd      ALLOT
        dd      _store_
        dd      EXIT
    header  C_comma,   docol, C_comma+5*cw, 0, lastlink, "C,"
        dd      HERE
        dd      _one_
        dd      ALLOT
        dd      C_store
        dd      EXIT
; ------------------------------------------------------------------------------
    header  STATE,   dobuf, STATE+5*cw, 0, lastlink, "STATE"
        dd      _
    header  LITERAL,   docol, LITERAL+5*cw, immediatemask, lastlink, "LITERAL"
        dd      STATE
        dd      _fetch_
        ifto  LITE1
        dd      LIT, LIT, _comma_, _comma_
LITE1:  dd      EXIT
    header  left_bracket,   docol, left_bracket+5*cw, immediatemask, lastlink, "["
        dd      _zero_
        dd      STATE
        dd      _store_
        dd      EXIT
    header  right_bracket,   docol, right_bracket+5*cw, 0, lastlink, "]"
        dd      _one_
        dd      STATE
        dd      _store_
        dd      EXIT

; ------------------------------------------------------------------------------
    header  BASE,   dobuf, BASE+5*cw, 0, lastlink, "BASE"
        dd      _
    header  HLD,   dobuf, HLD+5*cw, 0, lastlink, "HLD"
        dd      _
    header  HANDLER,   dobuf, HANDLER+5*cw, 0, lastlink, "HANDLER"
        dd      _
    header  REMAINDER,   dobuf, REMAINDER+5*cw, 0, lastlink, "REMAINDER"
        rb      2*cw
    header  CONTEXT,   dobuf, CONTEXT+5*cw, 0, lastlink, "CONTEXT"
        dd      _
; ------------------------------------------------------------------------------
    header  LATEST,   docol, LATEST+5*cw, 0, lastlink, "LATEST"
        dd      CONTEXT
        dd      _fetch_
        dd      to_LFA
        dd      _fetch_
        dd      EXIT
    header  to_CFA,   docol, to_CFA+5*cw, 0, lastlink, ">CFA"
        dd      LIT, 0*cw
        dd      _plus_
        dd      EXIT
    header  to_DFA,   docol, to_DFA+5*cw, 0, lastlink, ">DFA"
        dd      LIT, 1*cw
        dd      _plus_
        dd      EXIT
    header  to_FFA,   docol, to_FFA+5*cw, 0, lastlink, ">FFA"
        dd      LIT, 2*cw
        dd      _plus_
        dd      EXIT
    header  to_LFA,   docol, to_LFA+5*cw, 0, lastlink, ">LFA"
        dd      LIT, 3*cw
        dd      _plus_
        dd      EXIT
    header  to_NFA,   docol, to_NFA+5*cw, 0, lastlink, ">NFA"
        dd      LIT,4*cw
        dd      _plus_
        dd      EXIT
    header  to_PHA,   docol, to_PHA+5*cw, 0, lastlink, ">PHA"
        dd      LIT,5*cw
        dd      _plus_
        dd      EXIT
; See also >BODY in the CREATE .. DOES> section.
; ------------------------------------------------------------------------------
    header  HIDDEN,   docol, HIDDEN+5*cw, 0, lastlink, "HIDDEN"
        dd      to_FFA
        dd      LIT,invisiblemask
        dd      TOGGLE
        dd      EXIT
    header  HEX,   docol, HEX+5*cw, 0, lastlink, "HEX"
        dd      LIT,16
        dd      BASE
        dd      _store_
        dd      EXIT
    header  DECIMAL,   docol, DECIMAL+5*cw, 0, lastlink, "DECIMAL"
        dd      LIT,10
        dd      BASE
        dd      _store_
        dd      EXIT
; ------------------------------------------------------------------------------
    header  COUNT,   docol, COUNT+5*cw, 0, lastlink, "COUNT"
        dd      _DUP_
        dd      one_plus
        dd      SWAP
        dd      C_fetch
        dd      EXIT
; ------------------------------------------------------------------------------
    header  HOLD,   docol, HOLD+5*cw, 0, lastlink, "HOLD"
        dd      LIT,-1
        dd      HLD
        dd      plus_store
        dd      HLD
        dd      _fetch_
        dd      C_store
        dd      EXIT
    header  PAD,   dobuf, pad1 , 0, lastlink, "PAD"
pad0:   rb      0x400
pad1:   rb      0x400
    header  NUMBER,   docol, NUMBER+5*cw, 0, lastlink, "NUMBER"
        dd      _zero_
NPNUM1:  dd      PP_fetch_fetch
        dd      _DUP_, query_BLANK, _NOT_
        whileto   NPNUM5
        dd      NIP
        dd      DIGIT
        dd      LIT, 10, query_ERROR
        dd      SWAP
        dd      BASE
        dd      _fetch_
        dd      M_star
        dd      DROP
        dd      _plus_
        goto  NPNUM1
NPNUM5:
        dd      two_DROP
        dd      EXIT
; ------------------------------------------------------------------------------
    header  FOUND,   docol, FOUND+5*cw, 0, lastlink, "FOUND"
        dd      CONTEXT, _fetch_

; ~MATCH is sure in determining a no-match,
; a possible match must be investigated closely.
; STACK: name dea
found0:
        dd      no_MATCH, _NOT_
        ifto  endif4
              ; Ignore invisible and dummy words.
              dd      _DUP_, to_FFA, _fetch_
              dd      LIT, invisiblemask or dummymask, _AND_
              dd      zero_equal
              ifto  endif4
                  dd      two_DUP       ; STACK: string length, dea
                  ; If strings length match ..
                  dd      to_NFA, _fetch_, _fetch_, _equal_
                  ifto  endif3
                      dd      NIP,NIP,EXIT         ; Leave dea
                  endif3:
                  ; We may still have a denotation, such as a number.
                  dd      two_DUP       ; STACK: string length, dea
                  ; if the string has at least the dea's lenght,
                  dd    to_NFA, _fetch_, _fetch_, _less_, _NOT_
                  ifto  endif4
                      ;   and if the word is a denotation prefix,
                      dd      _DUP_, to_FFA, _fetch_,   LIT, denotationmask, _AND_
                      ifto  endif4
                          dd      NIP,NIP,EXIT   ; leave dea, a denotation.
        endif4:

        dd      to_LFA, _fetch_
        dd      _DUP_, zero_equal
        untilto  found0

        dd      NIP, NIP, EXIT          ; DEA is zero: "not found".

    header  PRESENT,   docol, PRESENT+5*cw, 0, lastlink, "PRESENT"
        dd      _DUP_, to_R
        dd      FOUND
        dd      _DUP_
        ifto  PRES1
        dd      _DUP_
        dd      to_NFA, _fetch_, _fetch_
        dd      R_fetch, _equal_
        dd      _AND_
PRES1:
        dd      R_from, DROP
        dd      EXIT
; ------------- error handling -------------------------------------------------
    header  WHERE,   dobuf, WHERE+5*cw, 0, lastlink, "WHERE"
        dd      _, _
    header  _ERROR_,   docol, _ERROR_+5*cw, 0, lastlink, "ERROR"
        dd      WHERE, two_fetch
        dd      OVER
        ifto  ERR2
        dd      OVER, LIT, 20, _minus_
        dd      MAX
        dd      SWAP
        dd      _one_, _minus_
ERR1:   dd      _DUP_, C_fetch, query_BLANK, _NOT_
        whileto    ERR2
        dd      one_plus
        goto  ERR1
ERR2:
        dd      OVER, _minus_
        dd      _TYPE_
        dd      BRANCH
sb0:
        string    " ? ciforth ERROR # "
        dd      LIT, sb0
        dd      string_fetch
        dd      _TYPE_
        dd      BASE, _fetch_
        dd      DECIMAL
        dd      SWAP
        dd      _dot_
        dd      BASE, _store_
        dd      EXIT
    header  CATCH,   docol, CATCH+5*cw, 0, lastlink, "CATCH"
        dd      DSP_fetch, CELL_plus, to_R
        dd      HANDLER, _fetch_, to_R
        dd      RSP_fetch, HANDLER, _store_
        dd      EXECUTE
        dd      R_from, HANDLER, _store_
        dd      R_from, DROP, _zero_
        dd      EXIT
    header  THROW,   docol, THROW+5*cw, 0, lastlink, "THROW"
        dd      _DUP_
        ifto  THROW1
        dd      HANDLER, _fetch_, zero_equal
        ifto  THROW2
        dd      _ERROR_
        dd      DSP_zero, DSP_store
        dd      QUIT
THROW2:
        dd      HANDLER, _fetch_, RSP_store
        dd      R_from, HANDLER, _store_
        dd      R_from, SWAP, to_R
        dd      DSP_store
        dd      R_from
        dd      _
THROW1:
        dd      DROP
        dd      EXIT
    header  query_ERROR,   docol, query_ERROR+5*cw, 0, lastlink, "?ERROR"
        dd      SWAP
        ifto  QERR1
        dd      PP, _fetch_
        dd      SRC, _fetch_
        dd      WHERE, two_store
        dd      THROW
        goto  QERR2
QERR1:  dd      DROP
QERR2:  dd      EXIT
    header  query_STACK,   docol, query_STACK+5*cw, 0, lastlink, "?STACK"
        dd      DSP_fetch
        dd      DSP_zero
        dd      _greater_, LIT, 1, query_ERROR
        dd      DSP_fetch
        dd      HERE, LIT,0x80, _plus_
        dd      _less_, LIT, 7, query_ERROR
        dd      EXIT
        ;
; ------------------------------------------------------------------------------
    header  HEADER,   docol, HEADER+5*cw, 0, lastlink, "HEADER"
        dd      _DUP_, zero_equal, LIT, 5, query_ERROR
        dd      two_DUP
        dd      PRESENT
        dd      _DUP_
        ifto  CREA1
        dd      to_NFA, _fetch_, string_fetch
        dd      _TYPE_
        dd      BRANCH
sb1:
        string    " : ISN'T UNIQUE"
        dd      LIT, sb1
        dd      string_fetch
        dd      _TYPE_, CR
        dd      _
CREA1:  dd      DROP
        dd      _ALIGN_
        dd      string_comma
        dd      _ALIGN_
        dd      HERE,to_R
        dd      R_fetch, to_PHA, _comma_
        dd      R_fetch, to_PHA, _comma_
        dd      _zero_, _comma_
        dd      _zero_, _comma_
        dd      _comma_
        dd      R_from
        dd      EXIT
; ------------------------------------------------------------------------------
    header  _LINK_,   docol, _LINK_+5*cw, 0, lastlink, "LINK"
        dd      to_LFA
        dd      two_DUP
        dd      _fetch_
        dd      SWAP, to_LFA, _store_
        dd      _store_
        dd      EXIT
    header  paren_CREATE,   docol, paren_CREATE+5*cw, 0, lastlink, "(CREATE)"
        dd      HEADER
        dd      CONTEXT, _fetch_
        dd      _LINK_
        dd      EXIT
; ------------------------------------------------------------------------------
    header  IMMEDIATE,   docol, IMMEDIATE+5*cw, 0, lastlink, "IMMEDIATE"
        dd      LATEST
        dd      to_FFA
        dd      LIT, immediatemask
        dd      TOGGLE
        dd      EXIT
    header  PREFIX,   docol, PREFIX+5*cw, 0, lastlink, "PREFIX"
        dd      LATEST
        dd      to_FFA
        dd      LIT, denotationmask
        dd      TOGGLE
        dd      EXIT
    header  _backslash_,   docol, _backslash_+5*cw, immediatemask, lastlink, "\"
        dd      PP_fetch_fetch, two_DROP
        dd      LIT,0x0A
        dd      PARSE
        dd      two_DROP
        dd      EXIT
    header  CLS,   docol, CLS+5*cw, 0, lastlink, "CLS"
        dd      DSP_zero, DSP_store
        dd      EXIT
    header  COLD,   docol, COLD+5*cw, 0, lastlink, "COLD"
        dd      INIT
        dd      CLS, ABORT
        dd      BYE
        dd      EXIT
    header  ABORT,   docol, ABORT+5*cw, 0, lastlink, "ABORT"
        dd      QUIT
        dd      EXIT
    header  INIT,   docol, INIT+5*cw, 0, lastlink, "INIT"
        dd      DSP_zero, DSP_store
        dd      _zero_, HANDLER, _store_
        dd      DECIMAL
        dd      FORTH
        dd      left_bracket, HERE,  string_fetch, EVALUATE
        dd      EXIT
; ------------------------------------------------------------------------------
; ---------------- file interface ----------------------------------------------
    header  ZEN,   docol, ZEN+5*cw, 0, lastlink, "ZEN"
        dd      LIT, pad0, string_store
        dd      _zero_, LIT, pad0, string_C_plus
        dd      LIT, pad0, CELL_plus
        dd      EXIT
    header  OPEN_FILE,   docol, OPEN_FILE+5*cw, 0, lastlink, "OPEN-FILE"
        dd      to_R, ZEN, R_from, _
        dd      LIT, __NR_open, XOS
        dd      _DUP_, _zero_, MIN
        dd      EXIT
    header  CLOSE_FILE,   docol, CLOSE_FILE+5*cw, 0, lastlink, "CLOSE-FILE"
        dd      _, _
        dd      LIT, __NR_close, XOS
        dd      EXIT
    header  CREATE_FILE,   docol, CREATE_FILE+5*cw, 0, lastlink, "CREATE-FILE"
        dd      to_R, two_DUP, DELETE_FILE, DROP
        dd      ZEN, R_from, _
        dd      LIT, __NR_creat, XOS
        dd      _DUP_, _zero_, MAX, SWAP, _zero_, MIN
        dd      EXIT
    header  DELETE_FILE,   docol, DELETE_FILE+5*cw, 0, lastlink, "DELETE-FILE"
        dd      ZEN, _, _
        dd      LIT, __NR_unlink, XOS
        dd      EXIT
    header  READ_FILE,   docol, READ_FILE+5*cw, 0, lastlink, "READ-FILE"
        dd      SDSWAP, SDSWAP
        dd      LIT, __NR_read, XOS
        dd      _DUP_, _zero_, MAX, SWAP, _zero_, MIN
        dd      EXIT
    header  WRITE_FILE,   docol, WRITE_FILE+5*cw, 0, lastlink, "WRITE-FILE"
        dd      SDSWAP, SDSWAP
        dd      LIT, __NR_write, XOS
        dd      _zero_, MIN
        dd      EXIT
; ---------------------------------------------------------------
    header  REFILL_CIB,   docol, REFILL_CIB+5*cw, 0, lastlink, "REFILL-CIB"
        dd      REMAINDER, _fetch_, to_R
        dd      CIB, R_fetch, _plus_
        dd      LIT, cibsize, R_fetch, _minus_
        dd      _zero_
        dd      READ_FILE
        dd      _zero_, MIN, _DUP_, query_ERROR
        dd      _DUP_, zero_equal, LIT, -epipe, _AND_
        dd      _zero_, MIN, _DUP_, query_ERROR
        dd      CIB, SWAP, R_from, _plus_
        dd      REMAINDER, two_store
        dd      EXIT
    header  ACCEPT,   docol, ACCEPT+5*cw, 0, lastlink, "ACCEPT"
        dd      paren_ACCEPT
        dd      two_SWAP, SDSWAP, MIN
        dd      _DUP_, to_R, _MOVE_, R_from
        dd      EXIT
    header  paren_ACCEPT,   docol, paren_ACCEPT+5*cw, 0, lastlink, "(ACCEPT)"
PACCEP2:
        dd      REMAINDER
        dd      two_fetch
        dd      LIT, 0x0A, string_pointer
        dd      zero_equal
        whileto   PACCEP1
        dd      REMAINDER, two_fetch
        dd      CIB
        dd      SWAP, _MOVE_
        dd      CIB
        dd      REMAINDER, CELL_plus, _store_
        dd      REFILL_CIB
        goto  PACCEP2
PACCEP1:
        dd      REMAINDER, two_fetch
        dd      LIT, 0x0A, string_slash
        dd      two_SWAP, REMAINDER, two_store
        dd      EXIT
; ---------------------------------------------------------------
    header  KEY,   docol, KEY+5*cw, 0, lastlink, "KEY"
        dd      _zero_, DSP_fetch, _one_, ACCEPT, DROP
        dd      EXIT
    header  _TYPE_,   docol, _TYPE_+5*cw, 0, lastlink, "TYPE"
        dd      _one_, WRITE_FILE, THROW
        dd      EXIT
    header  EMIT,   docol, EMIT+5*cw, 0, lastlink, "EMIT"
        dd      DSP_fetch, _one_, _TYPE_
        dd      DROP
        dd      EXIT
        ;
; ---------------------------------------------------------------
    header  to_percent,   docol, to_percent+5*cw, 0, lastlink, "<%"
        dd      PAD
        dd      HLD
        dd      _store_
        dd      EXIT
    header  percent_from,   docol, percent_from+5*cw, 0, lastlink, "%>"
        dd      DROP
        dd      HLD
        dd      _fetch_
        dd      PAD
        dd      OVER
        dd      _minus_
        dd      EXIT
    header  percent,   docol, percent+5*cw, 0, lastlink, "%"
        dd      _zero_
        dd      BASE
        dd      _fetch_
        dd      SM_slash_REM
        dd      SWAP
        dd      LIT,9
        dd      OVER
        dd      _less_
        ifto  perc1
        dd      LIT,7
        dd      _plus_
perc1:   dd      LIT,0x30
        dd      _plus_
        dd      HOLD
        dd      EXIT
    header  percent_S,   docol, percent_S+5*cw, 0, lastlink, "%S"
perc_S1:  dd      percent
        dd      _DUP_
        dd      zero_equal
        untilto   perc_S1
        dd      EXIT
    header  SIGN,   docol, SIGN+5*cw, 0, lastlink, "SIGN"
        dd      zero_less
        ifto  SIGN1
        dd      LIT, '-'
        dd      HOLD
SIGN1:  dd      EXIT
    header  _dot_,   docol, _dot_+5*cw, 0, lastlink, "."
        dd      _DUP_, _ABS_
        dd      to_percent
        dd      _BL_, HOLD, percent_S, SWAP, SIGN
        dd      percent_from
        dd      _TYPE_
        dd      EXIT
    header  U_dot,   docol, U_dot+5*cw, 0, lastlink, "U."
        dd      to_percent
        dd      _BL_, HOLD, percent_S
        dd      percent_from
        dd      _TYPE_
        dd      EXIT

; ---------------------------------------------------------------
; Presenting Forth's poor man's objects of the seventies, the CREATE DOES>
; construct. Those objects have one method only and that method is coded
; in interpreted Forth, not assembler. Moreover the method is common to
; all. You see that in CREATE a default method is filled in at the
; first address post the header owned by the object, but this field is
; supposed to be overwritten by DOES>. The address after that is the
; start of the data belonging to the object.
; This is an example of how to define a class called CONSTANT
; which is functionally equivalent to the CONSTANT word defined above.
; : CONSTANT    CREATE ,   DOES> @ ;
; At the time of creating the object its value is put into the dictionary
; using comma. When the constant is executed, the low level interpreter
; pointer SI is loaded from the first address past the header, and the address
; behind that is passed via the stack.
; This is done by dodo. So *all* CREATE DOES> words execute the code dodo,
; which takes care that specific high level code is executed.
; Of course there can be no pointer to high level code in a word's DFA
; because next expects a pointer to machine code.

; The data of course is different for each object, immediately after the
; code pointer,
; This is called the "data field" or body in the ISO standard
; and must not be confused with the datafield in yourforth's headers.
; So the high level code pointer is at the post header address, and
; the body is one cell higher.
    header  to_BODY,   docol, to_BODY+5*cw, 0, lastlink, ">BODY"
        dd      to_DFA, _fetch_
        dd      CELL_plus
        dd      EXIT

    header  CREATE,   docol, CREATE+5*cw, 0, lastlink, "CREATE"
        dd      NAME
        dd      paren_CREATE
        dd      LIT, dodo, LATEST, to_CFA, _store_
        dd      LIT, crnoop, _comma_
        dd      EXIT
dodo:  lea     ebp,[ebp - 1*cw]    ; Push SI to the return stack
        mov     [ebp],esi          ;
        mov     esi,[eax+1*cw]     ; Post header address to SI.
        lea     eax,[esi+1*cw]     ; Body pointer to AX.
        mov     esi,[esi]          ; High level code pointer to SI.
        push    eax                ; Pass address to that code.
        next
crnoop: dd      EXIT
; DOES> just patches the LATEST definition with the address it finds
; on the return stack.  Imagine we compiled `` ... DOES> A B C ; ''
; Withing DOES> the content of the return stack is just a pointer to A,
; exactly the place where we want the object to jump to.
    header  DOES_from,   docol, DOES_from+5*cw, 0, lastlink, "DOES>"
        dd      R_from
        dd      LATEST
        dd      to_DFA
        dd      _fetch_         ; Get the Post Header Address.
        dd      _store_
        dd      EXIT

; Presenting Forth's ugly secret: the code routines to do "convenient" looping,
; not all that convenient actually, but life without it would be unbearable.
; I lied about BRANCH and 0BRANCH being the only words in the Forth
; engine to implement all control structures. I didn't lie about the
; extensibility. We can "just" define a few assembler words to aid in
; having loop limits and indices available. The control words that
; you are to use, notably DO and LOOP , are to be found in the forth
; code section.
; This is tricky code borrowed from ciforth. If you want an explanation
; look there. How to use it is in the pdf.

    header  paren_LOOP,   paren_LOOP+5*cw, 0, 0, lastlink, "(LOOP)"
        mov     ebx,1
XLOO1:  add     [ebp],ebx
        mov     eax,[ebp]
        sub     eax,[ebp+1*cw]
        xor     eax,ebx
        js      BRAN1
        lea     ebp,[ebp+3*cw]
        lea     esi,[esi+1*cw]
        next
    header  paren_plus_LOOP,   paren_plus_LOOP+5*cw, 0, 0, lastlink, "(+LOOP)"
        pop     ebx
        jmp short     XLOO1
        next
    header  paren_DO,   paren_DO+5*cw, 0, 0, lastlink, "(DO)"
        lodsd
        add     eax,esi
        pop     edx
        pop     ebx
        xchg    ebp,esp
        push    eax
        push    ebx
        push    edx
        xchg    ebp,esp
        next
    header  I,   (R_fetch+5*cw), I+5*cw, 0, lastlink, "I"
    header  J,   J+5*cw, 0, 0, lastlink, "J"
        mov     eax,[ebp+3*cw]
        push    eax
        next

; The next word in the linked list is FORTH, but it is not
;   the next word of the assembler source.
; In fact Forth is the first word in the linked list defined
; through this assembler file.
; In order to link from there to here we've to remember this link.
; Apart from FORTH there are only prefix words left.
regularlast EQU lastlink         ; Remember where non-prefix word end.

; The following part of the list is the last part, the first word of it
; ends the dictionary with a link of zero.  (FIXME, vague).
; There is a simple reason that prefixes must be last in the search order.
; A prefix hides all normal words that start with that prefix, .e.g. if the minus
; prefix where at the top of the search order the regular minus would not be found,
; instead it would be considered a malformed-formed number. The other way around there is no harm.
; -12 doesn't match with a non-prefix minus, so the search just continues.
; They are all prefixes, which handles numbers and other constant expressions,
; like strings, by parsing the remainder after the prefix. Take "&" as an example.
; It is supposed to be used like "&C" which leaves a character C on the stack.
; If in compilation state, it combines it with LIT with the effect that when it is run,
; the compiled code leaves a character C on the stack, That is the job
; of LITERAL, that ends all prefix words as you can see. Then there are two lines
; that generates errors, if there is no character following "&" or no blank following
; the character.

; catchall is a prefix, and its Forth name is an empty string, and as such it matches
; anything. So the word is interpreted as a number, and then either interpreted or
; compiled, according to state.
    header  catchall,   docol, catchall+5*cw, prefixmask, 0, ""
        dd      NUMBER, LITERAL, EXIT
    header  TICK,   docol, TICK+5*cw, prefixmask, lastlink, "'"
        dd      NAME, PRESENT
        dd      _DUP_, zero_equal, LIT, 11, query_ERROR
        dd      LITERAL
        dd      EXIT
    header  charprefix,   docol, charprefix+5*cw, prefixmask, lastlink, "&"
        dd      PP_fetch_fetch, NIP
        dd      _DUP_, query_BLANK, LIT, 10, query_ERROR
        dd      LITERAL
        dd      PP_fetch_fetch, NIP, query_BLANK, _NOT_, LIT, 10, query_ERROR
        dd      EXIT
    header  minusprefix,   docol, minusprefix+5*cw, prefixmask, lastlink, "-"
        dd      NUMBER, NEGATE, LITERAL
        dd      EXIT
    header  plusprefix,   docol, plusprefix+5*cw, prefixmask, lastlink, "+"
        dd      NUMBER, LITERAL, EXIT
    header  stringprefix,   docol, stringprefix+5*cw, prefixmask, lastlink, '"'
        dd      LIT, BRANCH, _comma_    ; Jump over string, if need be.
        dd      LIT, '"', PARSE
        dd      string_comma, _ALIGN_, to_R
        dd      R_fetch, CELL_plus, LITERAL, R_from, _fetch_, LITERAL
        dd      PP_fetch_fetch, NIP, query_BLANK, _NOT_, LIT, 10, query_ERROR
        dd      EXIT

; We talked about CREATE and DOES> before, and it is time to introduce
; the only object that we have in this source.
; FORTH is a vocabulary, i.e. a word that changes the
; starting point CONTEXT of the dictionary search.
; It just makes CONTEXT point the a dummy header in its data field.
; It would have been created by a word
;  : NAMESPACE    CREATE  0 , 0 , dummymask , 0 , 'ZERO CELL+ ,
;        DOES> CONTEXT ! ;
; After creating other namespace words, we'd be able to change the list of
; words searched for a match in the interpreter. It is not part of
; yourforth, but it is present in most any serious Forth
dovoc:
        dd      CONTEXT
        dd      _store_
        dd      EXIT

    header  FORTH,   dodo, FORTH+5*cw, 0, lastlink, "FORTH"
        dd      dovoc
        ; Dummy header, use the datafield of 0 as an empty string.
        dd      0, 0, dummymask, regularlast, (_zero_+1*cw)

; Note that outside of this assembler source we would need the above
; word NAMESPACE using CREATE DOES> to define it.

; ------------------------------------------------------------------------------
initdp:

; The string following is a source code file that becomes part of the
; executable and is compiled at startup
; This is just like including a file, except these words are needed to
; tell Forth how to include a file.
; The disadvantage here is that some names are known to the assembler only.
; E.g. the 1 AND in ID. is in fact dummymask, and constants are decimal, such
; as 493 which is better known as 755 octal. And the 4 in POSTPONE means
; immediate. But the advantage is that this is literally the same code that
; you would INCLUDE  ... if had an INCLUDE.
LF EQU 0x0a
        dd endforthcode - startforthcode
startforthcode:
; Reserve some place.
; In this way the source is not overwritten before it has been compiled.
    db "                                                              ", LF
    db "                                                              ", LF
    db "                                                              ", LF
    db "                                                              ", LF
    db "                                                              ", LF
; In this source file we get by with directly using BRANCH. In actual Forth
; source we want to use structured control words like IF .. THEN.
; They use the back patching words which saves us from needing labels.
; (FORWARD remembers where a branch distance has to be filled in, and
; at FORWARD) we know what the distances is and fill it in.
; Similarly (BACK remembers a place where to jump to.
    db ": (BACK HERE ;                                                ", LF
    db ": BACK) HERE CELL+ - , ;                                      ", LF
    db ": (FORWARD HERE _ , ;                                         ", LF
    db ": FORWARD) HERE OVER CELL+ - SWAP ! ;                         ", LF
    db ": BEGIN (BACK ;                             IMMEDIATE         ", LF
    db ": THEN FORWARD) ;                           IMMEDIATE         ", LF
    db ": UNTIL '0BRANCH , BACK) ;                  IMMEDIATE         ", LF
    db ": AGAIN 'BRANCH , BACK) ;                   IMMEDIATE         ", LF
    db ": REPEAT 'BRANCH , BACK) FORWARD) ;         IMMEDIATE         ", LF
    db ": IF '0BRANCH , (FORWARD ;                  IMMEDIATE         ", LF
    db ": ELSE 'BRANCH , (FORWARD SWAP FORWARD) ;   IMMEDIATE         ", LF
    db ": WHILE >R '0BRANCH , (FORWARD R> ;         IMMEDIATE         ", LF
; Ugly looping but indispensible. It is too ugly to document properly. Ugly.
    db ": DO '(DO) , (FORWARD (BACK ;               IMMEDIATE         ", LF
    db ": LOOP '(LOOP) , BACK) FORWARD) ;           IMMEDIATE         ", LF
    db ": +LOOP '(+LOOP) , BACK) FORWARD) ;         IMMEDIATE         ", LF

; What if we want to compile a word like ' that likes to run even during
; compilation? An example of that you will find below in FORGET.
; The solution is a parsing word that gets the name from the input stream.
; This is tricky, because you may not know beforehand if a word is immediate.
    db ": POSTPONE NAME PRESENT DUP 0= 15 ?ERROR                      ", LF
    db "   DUP >FFA @ 4 AND 0= IF 'LIT , , ', THEN , ; IMMEDIATE      ", LF

; Having available almost all of Forth we can use the file interface
; to have one of the most often used words "INCLUDE".
; It adds the definitions in a file to the current Forth.
    db ": GET-FILE 2DUP $, DROP 1699506502 , 0 OPEN-FILE THROW >R HERE", LF
    db "   DUP EM 6 / DUP ALLOT 1000 - R@ READ-FILE THROW R>          ", LF
    db "   CLOSE-FILE THROW 2DUP + DP ! ;                             ", LF
    db ": PUT-FILE 493 CREATE-FILE THROW DUP >R WRITE-FILE THROW R>   ", LF
    db "    CLOSE-FILE THROW ;                                        ", LF
    db ": INCLUDE NAME HERE >R 'GET-FILE CATCH DUP IF R> DP ! THROW   ", LF
    db "    ELSE R> DROP DROP THEN EVALUATE ;                         ", LF

; The crown on the cake are the definitions that makes the work of the
; programmer easier, inspecting the stack, the dictionary and getting rid
; of superfluous stuff.
    db ": ID.   DUP >FFA @ 1 AND IF DROP ELSE >NFA @ $@ TYPE          ", LF
    db "    SPACE SPACE SPACE THEN ;                                  ", LF
    db ": WORDS   0 CONTEXT @ BEGIN >LFA @ DUP DUP 0= UNTIL 2DROP     ", LF
    db "   BEGIN ID. DUP 0= UNTIL DROP ;                              ", LF
    db ":  .S  CR &S EMIT &[ EMIT SPACE                               ", LF
    db "   DSP@ DSP0 BEGIN 2DUP < WHILE 0 CELL+ - DUP @ . REPEAT      ", LF
    db "   DROP DROP &] EMIT ;                                        ", LF
    db ": FORGET   POSTPONE ' DUP >NFA @ DP !                         ", LF
    db "   >LFA @ 'FORTH >BODY >LFA ! ;                               ", LF
    db ": TASK ;                                                      ", LF
endforthcode:
dictsize       =     endforthcode - bm
        rb  forthsize - dictsize - tasksize
        rb  stacksize
initdsp0:
initcib: rb  cibsize
        rb  stacksize
initrsp0:
em:
        ;