\ vandys
\ kernel.f
\ For kernel source code
\
\ To be processed by the metacompiler, to generate a new system
\
\
\ The metacompiler uses two vocabularies; meta and target. The
\ meta vocabulary holds definitions used by code running on the
\ host, which will not interfere with "normal" Forth operations.
\ The "target" vocabulary defines words like ":", ";", "if", and
\ so forth, which must only be seen by code being metacompiled
\ onto the target.
only
vocabulary target
vocabulary meta
meta definitions also extensions
( extensions meta forth -> meta )
\ vandys
\ Before we start the metacompilation proper, we define any words,
\ variables or constants which are used by the metacompilation,
\ but are not intended to be part of the resulting image.
\
\ Version control
1 constant VER \ Major/minor versions
0 constant EXT
\ vandys
\ Constants
$20 constant #compile-only \ Compile-only flag
$40 constant #immediate \ ...immediate
$80 constant #markb \ ...flag first byte of name
4 constant CELLL \ # bytes in a cell
32 constant NBPW \ # bits in a cell
$A constant BASEE \ Default radix
8 constant #VOCS \ Depth of vocabulary stack
3 constant DEFAULT_PRIO \ Default scheduling priority
32 constant AOUT_SIZE \ # bytes in a.out header
1024 CELLL * constant #rstack \ # bytes allocated for return stack
#rstack 2* constant #stack \ ...operand stack twice as big
80 constant #TIBLINE \ Size of input line to TIB
16 constant #HIST \ # lines of history kept
\ vandys
\ Memory allocation
\
\ Our approach here is to put initial data structures down in low
\ memory, and target our actual ForthOS system for the base of
\ high memory (at 1 meg).
\
\ at 0x10000 the low memory layout is:
\ UPP: Base of user area, (8 cells padding), RPP: Top of return stack
\ TIBB: TIB, plus TIB history, (8 cells padding), SPP: Top of opstack
$10000 constant EM \ Start of low memory, uninitialized
64 CELLL * constant US \ Max user area size
EM US - constant UPP \ Start of user area (UP0)
UPP 8 CELLL * - constant RPP \ Start of return stack (RP0)
#HIST 1+ #TIBLINE * #TIBLINE +
constant TIBS \ Size of TIB state (TIB + history)
RPP #rstack - TIBS -
constant TIBB \ Terminal input buffer (TIB)
TIBB 8 CELLL * - constant SPP \ Start of data stack (SP0)
\ (#stack bytes below SPP are used)
\ vandys
$100000 constant BASEM \ Base memory for interpreter
\ Initialize assembly variables
create _USER 4 CELLL * , \ First user variable offset
variable base_mem \ First location of target image
\ These get patched as the target's routines are defined
variable _branch variable _?branch variable _(do) variable _(loop)
variable _doLIT variable _doUSER variable _forth variable cold1
variable _exit variable _doLIST variable _doVAR variable _doCONST
variable _(abort") variable _(?do) variable _(.") variable _(c")
variable _up variable tnumber variable _context variable _current
variable _doVOC variable _(+loop) variable _'rdwt
variable _fence
\ Fields back-patched once the image is fully compiled
variable textlen variable entryptr1 variable entryptr2
\ vandys
\ This is used to reference the patched pointers, to catch
\ cases where a reference is made before the needed routine
\ is defined.
: _@ @ dup 0= abort" bad ordering" ;
\ vandys
\ Once we start using the "target" vocabulary, we won't have
\ access to our regular vocabulary words. We create these words
\ to provide search order control of the host compiler which will
\ work even when words like "only" have their target definition
\ active.
: forth->forth only ;
\ ( forth forth -> forth )
: meta->meta only meta definitions also extensions ;
\ ( extensions meta forth -> meta )
: target->target meta->meta target definitions ;
\ ( target meta forth -> target )
: meta->target target->target extensions ;
\ ( extensions meta forth -> target )
: assembler->target meta->target assembler ;
\ ( assembler meta forth -> target )
: target->meta meta->meta target ;
\ ( target meta forth -> meta )
\ vandys
\ Record of assembly code relocations (which are not word aligned)
8 constant #max_asm_reloc
create asm_reloc 8 cells allot
create #asm_reloc 0 ,
: add_reloc ( a -- )
#asm_reloc @ dup #max_asm_reloc >= abort" relocs"
cells asm_reloc + ! 1 #asm_reloc +! ;
\ How far from the address we search for the unaligned reloc reference
8 constant #asm_fuzz
: (asm_reloc) ( l h a -- ) #asm_fuzz over + 1+ swap do
2dup i @ -rot within if drop i @ swap - BASEM + i !
unloop exit then
loop 1 abort" reloc not found" ;
: asm_relocs ( l h -- )
#asm_reloc @ 0 do 2dup i cells asm_reloc + @ (asm_reloc) loop 2drop ;
\ vandys
\ relocate ( l h -- )
\ Relocate all references in range to BASEM
1 cells constant #cell
: relocate
2dup asm_relocs #asm_reloc @ . ." assembly relocations" cr
0 -rot 2dup cell+ swap do
2dup i @ -rot 1+ within if
rot 1+ -rot
over i @ swap - BASEM + i !
then
#cell +loop
2drop . ." relocations" cr
;
\ write_image ( a u n -- )
\ Write image at "a" starting at block "u"
\ for "n" blocks.
: write_image 0 do 2dup block BLKSIZ move update 1+ swap BLKSIZ + swap
loop 2drop sync ;
\ vandys
\ Format of dictionary entries:
\
\ Code address 32 bits
\ Link to previous entry 32 bits
\ Name length + flags 8 bits (high bit always set)
\ Name (length bytes)
\ padding (to CELLL boundary)
\ then:
\ Assembly code (for CODE word)
\ or:
\ call DOLST (for COLON word)
\ .long w1,w2,... (pointers to other words)
\
\ vandys
\ Convert between the different addresses
: nfa>cfa cell- cell- ;
: nfa>lfa cell- ;
: cfa>nfa cell+ cell+ ;
: cfa>lfa cell+ ;
: lfa>cfa cell- ;
: lfa>nfa cell+ ;
: ca>nfa begin 1- dup c@ $80 and until ;
\ (same?) ( a1 a2 u -- <bool> )
\ Tell if range of bytes is equal
: (same?) 0 do 2dup c@ swap c@ - if unloop 2drop false exit then
1+ swap 1+ loop 2drop true ;
\ same? ( a1 a2 -- bool )
\ Compare dictionary entries
: same? count $1F and >r swap count $1F and dup r> - if
drop 2drop false exit then
(same?) ;
\ vandys
\ Pointer to NFA of most recent entry
create last 0 ,
: lastcode last @ nfa>cfa @ ;
\ find ( a va -- ca na | a F )
\ Look up entry in indicated dictionary
: find
begin @ ?dup while \ Pick up next entry link
2dup same? if \ Compare to target string
nip dup nfa>cfa @ swap exit
then \ Found entry; return CA/NFA
nfa>lfa \ Prepare to advance to next
repeat false ; \ Return failure with addr
\ name? ( a -- ca na | a F )
\ Look up entry across dictionary search list
: name?
_context _@ swap begin over @ ?dup while
find ?dup if rot drop exit then
swap cell+ swap repeat
nip false ;
\ vandys
\ ">here ( b u -- a )
\ Convert pointer to counted string at here
: ">here dup here c! here 1+ swap move here ;
\ meta-' ( -- a )
\ Look up an entry in our target dictionary,
\ return CA
: meta-'
bl parse ">here \ Get next word from input
name? 0= if \ Look up
count type abort then \ Not known
\ CA is left on stack
;
\ Parse word from input into dictionary, advancing "here"
: token
bl parse 31 min dup >r here pack$ r> 1+ allot align ;
\ vandys
\ (compf) ( n -- )
\ OR in a bit in last entry's attributes
: (compf) last @ dup c@ rot or swap c! ;
\ (create) ( -- )
\ Create a word, leaving caller to
\ add appropriate code body
\ In the metacompiler, there is no "overt", therefore the entry
\ is placed on the search chain immediately. Yes, this limits
\ the ability of a word to use a previous instance of the same
\ word.
: (create)
align here 0 , \ CFA to be filled in
_current _@ @ @ , \ Point to words in definitions dict
here last ! \ Link onto chain
here _current _@ @ ! \ Add to definitions dict
token count space type \ Build name, trace output
#markb (compf) \ 1st byte with high bit set
here swap ! \ Point CFA to body
;
\ vandys
\ meta-words ( -- )
\ Dump words in target vocabulary
: meta-words _context _@ @ \ First vocab in search order
begin @ ?dup while
space dup .id nfa>lfa
repeat ;
\ Define a code word
\ Leverage our (create) word, then set the assembler in motion
meta->meta assembler
( assembler meta forth -> meta )
: code (create) ASM-INIT ;
: c; END-CODE ;
meta->meta
( extensions meta forth -> meta )
\ Define a colon definition, but don't build the body
: (:) (create) _doLIST _@ call, ;
\ vandys
\ Compile a user variable header
: user (:) _doUSER _@ , _USER @ , CELLL _USER +! ;
\ constant/ ( n -- )
\ Compile a string constant padded to length
: constant/ [char] / parse dup c, here swap move 1- allot ;
\ Record where to back-patch end of memory image
variable loadend_ptr
\ Location of prototype user area
variable user0
\ Size of user area
variable usize
\ vandys
\ fixups Patch values known after metacompilation
: fixups
\ Align size to 4k boundary
here base_mem @ - $1000 mod $1000 swap - allot
\ Summarize size
." Image size:" here base_mem @ - . ." bytes" cr
\ Fix up the prototype USER area
'ttyops @ user0 @ 6 cells + ! \ Host TTY operations
tnumber _@ user0 @ 20 cells + ! \ 'number
here user0 @ 34 cells + ! \ cp
last @ user0 @ 35 cells + ! \ last
\ Patch disk I/O to simulator
'rdwt @ _'rdwt _@ !
\ Patch "forth" vocabulary word for its runtime behavior
_doLIST _@ _forth _@ call!
_doVOC _@ _forth _@ cell+ cell+ !
\ vandys
\ Patch end-of-memory pointer into Multiboot header
\ (both load end and BSS end)
here loadend_ptr @ !
here loadend_ptr @ cell+ !
\ Fix fence
here _fence _@ !
\ Patch a.out header for text size
here base_mem @ - AOUT_SIZE - textlen @ !
;
\ compile-only Set compile-only flag of target word
: compile-only #compile-only (compf) ;
\ immediate Set immediate execution flag of target word
: immediate #immediate (compf) ;
\ vandys
\ ====================================================================
\ What follows are values and run-time routines needed by metacompiled
\ source. In "normal" forth, you are free to create words, and then
\ use those words to create further words and/or data structures. In
\ the metacompiled world, words compiled into the target are not
\ executable by the host. Thus, we factor out those functions to
\ this section, to make their functionality available to the
\ host metacompiler.
\ ====================================================================
\ Source code to support block.f
4096 constant BLKSIZ \ Byte of data in a block
80 constant BLKCOLS \ Columns in a screen
BLKSIZ 2/ BLKCOLS /
constant BLKROWS \ Rows in a screen (not shadow)
32 constant #BUFS \ # bufs held in memory--at least one
3 CELLL * BLKSIZ +
constant BUFSIZ \ Size of in-core block buffer
\ vandys
\ Source code to support multi.f
4 constant NPRIO \ # distinct task priorities (0..NPRIO-1)
8192 constant #codes \ Size of private code space
\ Source code to support cons.f
4 constant NSCREEN \ # virtual screens supported
80 constant CONS_COLS \ Columns on display
25 constant CONS_ROWS \ Rows on display
CONS_COLS CONS_ROWS *
constant RAM_SIZE \ Words on display
RAM_SIZE 2 *
constant RAM_BYTES \ Bytes on display
6 cells RAM_BYTES +
constant SCRMEM \ # bytes of state per screen
\ Initialize from string rather than individual c,'s
: ,chars bl parse drop begin dup c@ bl <> while
dup c@ c, 1+ repeat drop ;
\ Initialize a sequence of $80 char values
: pad80 ( u -- ) 0 do $80 c, loop ;
\ vandys
\ Source code to support ide.f
512 constant SECSIZ
SECSIZ 2/ constant SECWORDS
BLKSIZ SECSIZ / constant BLKSECS
\ Constants for structures
64 constant (struct_max)
\ vandys
\ ====================================================================
\ Now we start defining words which would interfere with
\ normal Forth compilation. We will place them in the "target"
\ vocabulary, which is not a part of our own search path.
\ ====================================================================
meta->target
( extensions meta forth -> target )
\ Create a variable without any storage allocated
: create (:) _doVAR _@ , ;
\ Variable
: variable [ target ] create [ extensions ] 0 , ;
\ Constant
: constant (:) _doCONST _@ , , ;
\
\ These are host-executed routines which generate code onto the
\ target, mostly for control structures.
\
: if _?branch _@ , here 0 , ;
: else _branch _@ , here 0 , swap here swap ! ;
: then here swap ! ;
: begin here ;
: until _?branch _@ , , ;
: again _branch _@ , , ;
: while [ target ] if [ extensions ] swap ;
: repeat [ target ] again [ extensions ] here swap ! ;
: do _(do) _@ , here 0 , ;
: ?do _(?do) _@ , here 0 , ;
: loop _(loop) _@ , here cell+ over ! cell+ , ;
: +loop _(+loop) _@ , here cell+ over ! cell+ , ;
\ vandys
\ Semicolon compiles in the termination of the definition, as well
\ as switching the host compiler back to interpretive state.
: ; _exit _@ , [compile] [ ;
: unsupported 1 abort" Unsupported operation" ;
: abort" _(abort") _@ , $," ;
: ." _(.") _@ , $," ;
: c" _(c") _@ , $," ;
: ['] meta-' _doLIT _@ , , ;
: [compile] meta-' , ;
: [char] char _doLIT _@ , , ;
: recurse last @ nfa>cfa @ , ;
\ vandys
\ specTab
\ Table of special words in metacompilation
\ These are defined in "meta", but located here
\ among target definitions because it references
\ some target routines.
meta->meta
( extensions meta forth -> meta )
16 dup constant #specName \ Size of name
cell+ constant #specEntry \ Size of each entry
create specTab 0
target->meta
( target meta forth -> meta )
\ vandys
#specName constant/ if/ ' if , 1+ \ Target specific words
#specName constant/ else/ ' else , 1+
#specName constant/ then/ ' then , 1+
#specName constant/ begin/ ' begin , 1+
#specName constant/ until/ ' until , 1+
#specName constant/ again/ ' again , 1+
#specName constant/ while/ ' while , 1+
#specName constant/ repeat/ ' repeat , 1+
#specName constant/ do/ ' do , 1+
#specName constant/ ?do/ ' ?do , 1+
#specName constant/ loop/ ' loop , 1+
#specName constant/ +loop/ ' +loop , 1+
#specName constant/ ;/ ' ; , 1+
#specName constant/ abort"/ ' abort" , 1+
#specName constant/ ."/ ' ." , 1+
#specName constant/ c"/ ' c" , 1+
#specName constant/ [']/ ' ['] , 1+
#specName constant/ [compile]/ ' [compile] , 1+
#specName constant/ [char]/ ' [char] , 1+
#specName constant/ [/ ' unsupported , 1+
#specName constant/ recurse/ ' recurse , 1+
\ vandys
meta->meta
( extensions meta forth -> meta )
#specName constant/ \/ ' \ , 1+ \ Hook to our host words
#specName constant/ (/ ' ( , 1+
constant #specTab \ # entries in specTab
\ >specName ( n -- a )
\ Return name for the given index in specTab
: >specName #specEntry * specTab + ;
\ >specFunc ( n -- a )
\ Return function pointer from index in specTab
: >specFunc >specName #specName + @ ;
\ vandys
\ special? ( a -- a F | vector T )
\ Tell if the word is special
\ Returns execution pointer if it is
\ TBD: think about leveraging a Forth vocab
: special?
#specTab 0 do
dup i >specName same? if
drop i >specFunc true unloop exit then
loop false ;
\ vandys
\ $immediate ( ca -- )
\ Tell if the given routine has a #immediate flag
: $immediate ca>nfa c@ #immediate and ;
\ $metacompile ( a -- )
\ Our 'eval hook for metacompilation
: $metacompile
special? if \ Special execution words
execute exit then
name? if \ Found in target dictionary?
dup $immediate abort" immediate"
, exit then
dup number? if \ Literal
_doLIT _@ , ,
drop exit then
count type \ Otherwise error
1 abort" undefined"
;
\ vandys
\ Ok, the special? support is safely compiled into meta, back to
\ definitions in target.
meta->target
( extensions meta forth -> target )
\ Start compiling a target word. We have a custom 'eval vector
\ to generate code referencing the target dictionary.
: : (:) ['] $metacompile 'eval ! ;
\ vandys
\ Target vocabulary handling is achieved by pre-defining the supported
\ vocabularies in the "target" vocabulary, and attaching their compilation
\ address as they are defined in the target source.
\ Create a host record for a vocabulary. Invoking it causes its
\ value to become the "context".
meta->meta
( extensions meta forth -> meta )
: defVoc create 0 , does> _@ _context _@ ! ;
\ Convert from CA to storage location in word
\ This applies to both vocabularies as well as normal variables.
\ Note: host implementation specific
: >varBody ( ca -- a ) 3 cells + ;
\ Register the "last" definition as a named vocabulary
: regVoc last @ dup nfa>cfa @ >varBody swap
[ ' target >varBody ] literal
find 0= abort" bad vocabulary" >varBody ! ;
\ vandys
\ Return to placing definitions in "target"
meta->target
( extensions meta forth -> target )
\ These are the predefined vocabularies, placed in their own
\ private vocabulary list
defVoc forth defVoc extensions defVoc assembler
defVoc editor defVoc os defVoc drivers
defVoc initialize defVoc fs
\ Target creation of a vocabulary; we both create the vocabulary
\ in the memory image as well as connect it with the host's record
\ of this vocabulary.
: vocabulary
(:) _doVOC _@ ,
here 0 , _current _@ cell+ dup @ , ! regVoc ;
\ vandys
\ Emulate manipulation of the vocabulary environment
: also _context _@ dup cell+ #VOCS cells move ;
: definitions _context _@ @ _current _@ ! ;
: only _context _@ cell+ #VOCS cells erase
_forth _@ >varBody _context _@ !
[ target->target ] also definitions [ meta->target ] ;
\
\ ====================================================================
\ Now we start generating the memory image. We record the starting
\ point so that we have a memory range to scan and relocate after
\ generating all the code.
\ ====================================================================
\
target->target
( target meta forth -> target )
\ When the assembler is active, the search order will become
\ assembler, meta, forth. We require that the meta vocabulary
\ continue to be visible even when the assembler is active.
\ vandys
align
here base_mem !
\ Main entry points and COLD start data
\ First build an a.out-ish header so we can fool Multiboot
\ loaders into loading us. This comes to AOUT_SIZE (32) bytes.
$10B , \ 0413 executable
here textlen ! 0 , \ Back-patch with "text" length
0 , 0 , \ 0-length "data" and "bss"
0 , \ No symbols!
here entryptr1 ! 0 , \ Entry point
0 , 0 , \ Text/data relocation, ignore
\ vandys
\ Multiboot header
\ MULTIBOOT_MAGIC
meta->target \ Suspend assembler while we build the header
( forth meta forth -> target )
here $1BADB002 dup ,
\ MULTIBOOT_PAGE_ALIGN + MULTIBOOT_AOUT_KLUDGE + MULTIBOOT_MEMORY_INFO
1 2 or $10000 or dup ,
\ Multiboot checksum
+ 0 not swap - 1+ ,
\ Pointer back to header
,
\ Load address
base_mem @ ,
\ Load end
here loadend_ptr ! 0 ,
\ BSS end
0 ,
\ Program entry point
here entryptr2 ! 0 ,
\ vandys
here cold1 ! 0 ,
assembler->target ASM-INIT
( assembler meta forth -> target )
here dup entryptr1 @ ! entryptr2 @ !
SPP # esp mov
RPP # ebp mov
cld
ebx push eax push
here add_reloc
cold1 @ # eax mov 0 [eax] jmp
END-CODE
target->target
( target meta forth -> target )
\ vandys
\ COLD start moves the following to USER variables
\ MUST BE IN SAME ORDER AS USER VARIABLES
align
here user0 !
0 , 0 , 0 , 0 , \ reserved space in user area
SPP , \ SP0
RPP , \ RP0
0 , \ 'TTYOPS
0 , \ 'EXPECT
0 , \ 'TAP
0 , \ 'ECHO
0 , \ 'PROMPT
BASEE , \ BASE
0 , \ tmp
0 , \ SPAN
0 , \ >IN
0 , \ #TIB
\ vandys
TIBB , \ TIB
TIBB , \ TIB0
0 , \ CSP
0 , \ 'EVAL
0 , \ 'NUMBER
0 , \ HLD
0 , \ HANDLER
here _context !
0 , \ CONTEXT pointer
0 , 0 , 0 , 0 , \ Vocabulary stack--#VOCS entries
0 , 0 , 0 , 0 ,
here _current !
0 , \ CURRENT pointer
0 , \ Vocabulary link pointer
0 , \ CP
0 , \ LAST
0 , \ OFFSET
0 , \ TTCHAN
0 , \ BLK
\ vandys
DEFAULT_PRIO , \ PRIO
0 , \ Buffered typing from "(key?)"
0 , \ TGENHOOK
0 , \ GENSUSP
0 , 0 , \ TTRAP, abortTrap
0 , 0 , \ CWD, ROOT
0 , 0 , \ tmp1, tmp2
0 , \ (local)
here user0 @ - usize !
\ vandys
\ forth ( -- )
\ Make FORTH the context vocabulary
\ This is really tedious. To break the circular dependency of where
\ a definition goes (this word, "forth", goes in the "forth" vocabulary,
\ which doesn't exist yet, right?), we partially construct the "forth"
\ vocabulary here, and back-patch doVOC once it's defined.
here 4 cells + , \ CFA
0 , \ LFA
here last ! \ NFA, build name by hand, including padding
5 $80 or c,
char f c, char o c, char r c, char t c, char h c,
0 c, 0 c,
here _forth ! \ Record location for back-patches
0 , 0 , 0 , \ CALL, doLIST, doVOC
\ Register us in the vocabulary list
here _current _@ cell+ !
last @ , \ We're the only entry in this vocab initially
0 , \ List of vocabularies
regVoc \ Register our vocabulary, "forth"
\ vandys
\ We can now set our search and definition vocabularies
only
\ Here's the code to implement a high-level execution
code doLIST
here _doLIST !
ebp esp xchg
esi push
ebp esp xchg
esi pop
next c;
\ vandys
\ Device dependent I/O
\ BYE ( -- )
\ Exit eForth
code bye
\ First try via keyboard controller
\ $FE # eax mov $64 byte out#
\ (hangs on my Gateway laptop... Andy 10/30/09)
\ Now attempt shutdown via bad mapping
0 # eax mov eax cr3 movcr -1 # eax mov 0 [eax] eax mov
\ No joy
next c;
\ vandys
\ inb ( port -- n )
\ Do x86 byte inport
code inb
edx pop eax eax xor byte in eax push next c;
\ inw ( port -- n )
\ Do x86 word (2-byte) inport
code inw
edx pop eax eax xor 16: in eax push next c;
\ inl ( port -- n )
\ Do x86 longword (4-byte) inport
code inl
edx pop eax eax xor in eax push next c;
\ vandys
\ outb ( n port -- )
\ Do x86 byte outport
code outb
edx pop eax pop byte out next c;
\ outw ( n port -- )
\ Do x86 word (2-byte) outport
code outw
edx pop eax pop 16: out next c;
\ outl ( n port -- )
\ Do x86 longword (4-byte) outport
code outl
edx pop eax pop out next c;
\ vandys
\ The kernel
\ doLIT ( -- w )
\ Push an inline literal
code doLIT
here _doLIT !
lods
eax push
next c; compile-only
\ doCONST ( -- n )
\ Runtime for a constant word
code doCONST
here _doCONST !
0 [esi] push
0 [ebp] esi mov
CELLL # ebp add
next c; compile-only
\ vandys
\ ?branch ( f -- )
\ Branch if flag is zero
code ?branch
here _?branch !
ebx pop \ Pop flag
ebx ebx or \ ?flag = 0
1 $ je \ Yes, branch
CELLL # esi add \ Point IP to next cell
next
1 $:
0 [esi] esi mov \ Branch to target
next
c; compile-only
\ branch ( -- )
\ Branch to an inline address
code branch
here _branch !
0 [esi] esi mov
next
c; compile-only
\ vandys
\ execute ( ca -- )
\ Execute the word at ca
code execute
ebx pop
ebx jmp
c;
\ exit ( -- )
\ Terminate a colon definition
\ Note: this must be defined before any colon definition
\ is compiled.
code exit
here _exit !
0 [ebp] esi mov
CELLL # ebp add
next c;
\ vandys
\ (do) ( n n -- )
\ Execution time for do..loop
code (do)
here _(do) !
$C # ebp sub
esi 8 [ebp] mov 4 # esi add
eax pop eax 4 [ebp] mov
eax pop eax 0 [ebp] mov
next c;
\ vandys
\ (?do) ( n n -- )
\ Execution time for ?do..loop
code (?do)
here _(?do) !
eax pop
ebx pop
ebx eax cmp
1 $ jl
0 [esi] esi mov
next
1 $: $C # ebp sub
esi 8 [ebp] mov
4 # esi add
eax 4 [ebp] mov
ebx 0 [ebp] mov
next c;
\ vandys
\ (loop) ( -- )
\ Run time code for double index loop
code (loop)
here _(loop) !
4 [ebp] eax mov
eax inc
eax 0 [ebp] cmp
1 $ jle
eax 4 [ebp] mov
0 [esi] esi mov
next
1 $: CELLL 3 * # ebp add
CELLL # esi add
next c; compile-only
\ vandys
\ (+loop) ( -- )
\ Run time code for double index loop with increment
code (+loop)
here _(+loop) !
eax pop
eax eax or \ Handle negative specially
2 $ jl
4 [ebp] eax add
eax 0 [ebp] cmp
1 $ jle \ Increment above limit?
3 $: eax 4 [ebp] mov \ No, update count
0 [esi] esi mov \ ...branch back again
next
1 $: 3 CELLL * # ebp add \ Yes, pop three params
CELLL # esi add \ Continue past branch offset
next
\ vandys
\ ... continuation of (+loop)
2 $: 4 [ebp] eax add
eax 0 [ebp] cmp
1 $ jg
3 $ jmp
c; compile-only
\ i ( -- n)
\ Push current loop counter onto operand stack
code i
4 [ebp] push
next c; compile-only
\ ! ( w a -- )
\ Pop the data stack to memory
code ! ebx pop 0 [ebx] pop next c;
\ !+ ( w a -- a' )
\ Pop data stack to memory, advancing pointer
code !+ ebx pop 0 [ebx] pop CELLL # ebx add ebx push next c;
\ vandys
\ @ ( a -- w )
\ Push memory location to the data stack
code @
ebx pop 0 [ebx] push next c;
\ @+ ( a -- a+ w )
\ Fetch memory, advancing pointer
code @+
eax pop eax ebx mov CELLL # eax add eax push 0 [ebx] push
next c;
\ c! ( c b -- )
\ Pop the data stack to byte memory
code c! ebx pop eax pop al 0 [ebx] mov next c;
\ c!+ ( c b -- b' )
\ Pop the data stack to byte memory, advancing pointer
code c!+ ebx pop eax pop al 0 [ebx] mov ebx inc ebx push
next c;
\ vandys
\ c@ ( b -- c )
\ Push byte memory location to the data stack
code c@
ebx pop eax eax xor 0 [ebx] al mov eax push next c;
\ c@+ ( b -- b+ c )
\ Push byte memory, advancing pointer
code c@+
eax pop eax ebx mov eax inc eax push eax eax xor
0 [ebx] al mov eax push next c;
\ w! ( w a -- )
\ Pop the data stack to word
code w!
ebx pop
eax pop
16: eax 0 [ebx] mov
next c;
\ vandys
\ w@ ( a -- c )
\ Push addressed word to the data stack
code w@
ebx pop
eax eax xor
16: 0 [ebx] eax mov
eax push
next c;
\ rp@ ( -- a )
\ Push the current RP to the data stack
code rp@
ebp push
next c;
\ rp! ( a -- )
\ Set the return stack pointer
code rp!
ebp pop
next c; compile-only
\ vandys
\ r> ( -- w )
\ Pop the return stack to the data stack
code r>
0 [ebp] push
CELLL # ebp add
next c; compile-only
\ r@ ( -- w )
\ Copy top of return stack to the data stack
code r@
0 [ebp] push
next c;
\ >r ( w -- )
\ Push the data stack to the return stack
code >r
CELLL # ebp sub
0 [ebp] pop
next c; compile-only
\ vandys
\ sp@ ( -- a )
\ Push the current data stack pointer
code sp@
esp ebx mov
ebx push
next c;
\ sp! ( a -- )
\ Set the data stack pointer
code sp!
esp pop
next c;
\ drop ( w -- )
\ Discard top stack item
code drop
CELLL # esp add
next c;
\ vandys
\ dup ( w -- w w )
\ Duplicate the top stack item
code dup
esp ebx mov 0 [ebx] push next c;
\ swap ( w1 w2 -- w2 w1 )
\ Exchange top two stack items
code swap
ebx pop eax pop ebx push eax push next c;
\ vandys
\ over ( w1 w2 -- w1 w2 w1 )
\ Copy second stack item to top
code over
esp ebx mov
CELLL [ebx] push
next c;
\ nip ( w1 w2 -- w1 )
\ Remove second stack item
code nip
eax pop
eax 0 [esp] mov
next c;
\ vandys
code tuck ( w1 w2 -- w2 w1 w2 )
eax pop ebx pop eax push ebx push eax push next c;
code 0< ( n -- ? )
eax pop cdq edx push next c;
\ vandys
\ and ( w w -- w )
\ Bitwise AND
code and
ebx pop
eax pop
eax ebx and
ebx push
next c;
\ or ( w w -- w )
\ Bitwise inclusive OR
code or
ebx pop
eax pop
eax ebx or
ebx push
next c;
\ vandys
\ xor ( w w -- w )
\ Bitwise exclusive OR
code xor
ebx pop
eax pop
eax ebx xor
ebx push
next c;
\ um+ ( u u -- udsum )
\ Add two unsigned single numbers and return a double sum
code um+
ecx ecx xor \ ecx == 0, initial carry
ebx pop
eax pop
ebx eax add
ecx 1 rcl \ Get carry
eax push \ Push sum
ecx push \ and carry
next c;
\ vandys
\ System and user variables
\ doVAR ( -- a )
\ Run time routine for VARIABLE and CREATE
code doVAR
here _doVAR !
esi push
0 [ebp] esi mov
CELLL # ebp add
next c; compile-only
\ up ( -- a )
\ Pointer to the user area
create up here _up ! UPP ,
\ vandys
\ doUSER ( -- a )
\ Run time routine for user variables
code doUSER
here _doUSER !
0 [esi] eax mov
here add_reloc
_up _@ # ebx mov
0 [ebx] ebx mov
ebx eax add
eax push
0 [ebp] esi mov \ Pop return address
CELLL # ebp add \ Adjust RP
next c; compile-only
\ sp0 ( -- a )
\ Pointer to bottom of the data stack
user sp0
\ rp0 ( -- a )
\ Pointer to bottom of the return stack
user rp0
\ vandys
\ 'ttyops ( -- a )
\ Execution vectors to operations on terminal
user 'ttyops
\ 'expect ( -- a )
\ Execution vector of EXPECT
user 'expect
\ 'tap ( -- a )
\ Execution vector of TAP
user 'tap
\ 'echo ( -- a )
\ Execution vector of ECHO
user 'echo
\ 'prompt ( -- a )
\ Execution vector of PROMPT
user 'prompt
\ vandys
\ base ( -- a )
\ Storage of the radix base for numeric I/O
user base
\ tmp ( -- a )
\ A temporary storage location used in parse and find
user tmp
\ span ( -- a )
\ Hold character count received by EXPECT
user span
\ >in ( -- a )
\ Hold the character pointer while parsing input stream
user >in
\ #tib ( -- a )
\ Hold current count in, address of terminal input buffer
user #tib
\ vandys
\ tib ( -- a )
\ Terminal input buffer, and its initial one
user tib
user tib0
\ csp ( -- a )
\ Hold the stack pointer for error checking
user csp
\ 'eval ( -- a )
\ Execution vector of EVAL
user 'eval
\ 'number ( -- a )
\ Execution vector of NUMBER?
user 'number
\ hld ( -- a )
\ Hold a pointer in building a numeric output string
user hld
\ vandys
\ handler ( -- a )
\ Hold the return stack pointer for error handling
user handler
\ context ( -- a )
\ A area to specify vocabulary search order
user context
CELLL #VOCS * _USER +! \ vocabulary stack follows context
\ current ( -- a )
\ Point to the vocabulary to be extended
\ "current" is actually a pair of words. The first points to
\ the vocabulary receiving definitions. The second word builds
\ a linked list of all vocabularies defined in the system. This
\ is useful for "forget", which must trim words beyond the
\ forgotten point from all word lists.
user current
CELLL _USER +! \ vocabulary link pointer follows current
\ vandys
\ cp ( -- a )
\ Point to the top of the code dictionary
user cp
\ last ( -- a )
\ Point to the last name in the name dictionary
user last
\ offset ( -- a )
\ Base for BLOCK I/O offsets
user offset
\ ttchan ( -- u )
\ TTY channel to use for this user
user ttchan
\ blk ( -- a )
\ Current block # as source of input
user blk
\ More user variables (comments on shadow) vandys
user prio
user keychar
user 'genhook user gensusp
user 'trap user 'abortTrap
user cwd CELLL _USER +!
user tmp1 user tmp2
user (local)
\ ---- ULAST ----
\ vandys
\ user0 ( -- a )
\ Address of prototype USER area
user0 @ constant user0
\ #user ( -- u )
\ Size of USER area
usize @ constant #user
\ (BASEM) ( -- u )
\ Address of base of memory for Forth image running
BASEM constant BASEM
\ Common functions
\ doVOC ( -- )
\ Run time action of VOCABULARY's
: doVOC r> context ! ;
lastcode _doVOC !
\ #VOCS ( -- )
\ Return # of vocabulary slots available
#VOCS constant #VOCS
\ vandys
\ : ?dup ( w -- w w | 0 ) dup if dup then ;
code ?dup 0 [esp] eax mov eax eax or 1 $ je eax push
1 $: next c;
\ : rot ( w1 w2 w3 -- w2 w3 w1 ) >r swap r> swap ;
code rot eax pop ebx pop ecx pop
ebx push eax push ecx push next c;
\ : -rot ( w1 w2 w3 -- w3 w1 w2 ) swap >r swap r> ;
code -rot eax pop ebx pop ecx pop
eax push ecx push ebx push next c;
\ : 2drop ( d -- ) drop drop ;
code 2drop 8 # esp add next c;
\ : 2dup ( d -- d d ) over over ;
code 2dup 4 [esp] eax mov 0 [esp] ebx mov
eax push ebx push next c;
\ vandys
code + ( w w -- sum )
eax pop ebx pop ebx eax add eax push next c;
: not ( w -- w' ) -1 xor ;
: dnegate ( d -- d' ) not >r not 1 um+ r> + ;
code on ( a -- ) ebx pop true # eax mov eax 0 [ebx] mov next c;
code off ( a -- ) ebx pop eax eax xor eax 0 [ebx] mov next c;
code inc ( a -- ) ebx pop 0 [ebx] inc next c;
code dec ( a -- ) ebx pop 0 [ebx] dec next c;
\ vandys
\ 1+, 2+ ( n -- n )
\ Add one/two to argument
code 1+
0 [esp] inc
next c;
code 2+
eax pop 2 # eax add eax push
next c;
\ negate ( n -- -n )
\ Two's complement of tos
: negate not 1+ ;
\ - ( n1 n2 -- n1-n2 )
\ Subtraction
: - negate + ;
\ abs ( n -- n )
\ Return the absolute value of n
: abs dup 0< if negate then ;
\ vandys
\ 1- ( n -- n )
\ Subtract one from argument
code 1-
0 [esp] dec
next c;
\ 2/ ( n -- n )
\ Divide argument by two
code 2/
0 [esp] 1 sar
next c;
\ 2* ( n -- n )
\ Multiply argument by two
code 2*
0 [esp] 1 shl
next c;
\ vandys
\ <<, lshift ( n u -- n )
\ Shift left by "u" count
code <<
ecx pop
0 [esp] cl shl
next c;
: lshift << ;
\ >>, rshift ( n u -- n )
\ Shift right by "u" count
code >>
ecx pop
0 [esp] cl shr
next c;
: rshift >> ;
\ vandys
\ = ( w w -- t )
\ Return true if top two are equal
code =
eax pop
0 [esp] eax cmp
1 $ jne
true # eax mov
eax 0 [esp] mov
next
1 $:
false # eax mov
eax 0 [esp] mov
next c;
\ vandys
code 0= ( w -- ? )
eax pop eax eax or 1 $ je
false push# next
1 $: true push# next c;
code <> ( w1 w2 -- ? )
eax pop ebx pop ebx eax cmp 1 $ jne
false push# next
1 $: true push# next c;
\ vandys
\ u<= ( u u -- t )
\ Unsigned compare of top two items
code u<=
eax pop
eax 0 [esp] cmp
1 $ ja
true # eax mov
eax 0 [esp] mov
next
1 $:
false # eax mov
eax 0 [esp] mov
next c;
\ vandys
\ u< ( u u -- t )
\ Unsigned compare of top two items
code u<
eax pop
eax 0 [esp] cmp
1 $ jae
true # eax mov
eax 0 [esp] mov
next
1 $:
false # eax mov
eax 0 [esp] mov
next c;
\ vandys
\ < ( n1 n2 -- t )
\ Signed compare of top two items
code <
eax pop
eax 0 [esp] cmp
1 $ jge
true # eax mov
eax 0 [esp] mov
next
1 $:
false # eax mov
eax 0 [esp] mov
next c;
\ Other variations of comparison
: > swap < ;
: >= < not ;
: <= > not ;
\ vandys
\ max ( n n -- n )
\ Return the greater of two top stack items
: max 2dup < if swap then drop ;
\ min ( n n -- n )
\ Return the smaller of top two stack items
: min 2dup swap < if swap then drop ;
\ within ( u ul uh -- t )
\ Return true if ( ul <= u < uh )
: within over - >r - r> u< ;
\ #nbpw Number of bits in a cell
NBPW constant #nbpw
\ vandys
\ um/mod ( udl udh un -- ur uq )
\ Unsigned divide of double by single. Return mod, quotient
: um/mod 2dup u< if
negate #nbpw 0 do
>r dup um+ >r >r dup um+
r> + dup r> r@ swap >r um+ r> or if
>r drop 1+ r>
else
drop
then r>
loop
drop swap
else
drop 2drop -1 dup
then ;
\ vandys
\ m/mod ( d n -- r q )
\ Signed floored divide of double by single
\ Return mod and quotient
: m/mod dup 0< dup >r if negate >r dnegate r> then
>r dup 0< if r@ + then
r> um/mod r> if swap negate swap then
;
\ /mod ( n n -- r q )
\ Signed divide. Return mod and quotient
: /mod over 0< swap m/mod ;
\ mod ( n n -- r )
\ Signed divide. Return mod only
: mod /mod drop ;
\ / ( n n -- q )
\ Signed divide. Return quotient only
: / /mod swap drop ;
\ vandys
\ um* ( u u -- ud )
\ Unsigned multiply. Return double product
: um* 0 swap #nbpw 0 do
dup um+ >r >r
dup um+ r> + r> if
>r over um+ r> +
then
loop rot drop ;
\ * ( n n -- n )
\ Signed multiply. Return single product
code *
eax pop
0 [esp] imul
eax 0 [esp] mov
next c;
\ m* ( n n -- d )
\ Signed multiply. Return double product
: m* 2dup xor 0< >r abs swap abs um* r> if dnegate then ;
\ vandys
\ */mod ( n1 n2 n3 -- r q )
\ Multiply n1 and n2, then divide by n3
\ Return mod and quotient
: */mod >r m* r> m/mod ;
\ ( n1 n2 n3 -- q )
\ Multiply n1 by n2, then divide by n3. Return quotient only
: */ */mod swap drop ;
\ cell+ ( a -- a )
\ Add cell size in byte to address
code cell+
CELLL # eax mov
eax 0 [esp] add
next c;
\ cell- ( a -- a )
\ Subtract cell size in byte from address
code cell-
CELLL # eax mov
eax 0 [esp] sub
next c;
\ vandys
\ cells ( n -- n )
\ Multiply tos by cell size in bytes
code cells
0 [esp] eax mov
eax 2 shl
eax 0 [esp] mov
next c;
\ aligned ( b -- a )
\ Align address to the cell boundary
code aligned
0 [esp] eax mov
CELLL 1- # eax add
CELLL 1- not # eax and
eax 0 [esp] mov
next c;
\ bl ( -- 32 )
\ Return 32, the blank character
32 constant bl
\ vandys
-1 constant true
0 constant false
: >char ( c -- c ) $7F and dup $7F bl within if drop 95 then ;
: depth ( -- n ) sp@ sp0 @ swap - 1 cells / ;
: pick ( ... +n -- ... w ) 1+ cells sp@ + @ ;
: +! ( n a -- ) tuck @ + swap ! ;
: c+! ( n a -- ) tuck c@ + swap c! ;
\ Double, triple words, counted string support words vandys
code 2! ( d a -- ) ebx pop eax pop ecx pop eax 0 [ebx] mov
ecx 4 [ebx] mov next c;
code 2@ ( a -- d ) ebx pop 4 [ebx] eax mov 0 [ebx] ecx mov
eax push ecx push next c;
code 3! ( t a -- ) ebx pop eax pop ecx pop edx pop
eax 0 [ebx] mov ecx 4 [ebx] mov edx 8 [ebx] mov next c;
code 3@ ( a -- t ) ebx pop 8 [ebx] edx mov 4 [ebx] ecx mov
0 [ebx] eax mov edx push ecx push eax push next c;
: count ( b -- b' +n ) dup 1+ swap c@ ;
: do$ ( -- a ) r> r@ r> count + aligned >r swap >r ; compile-only
\ vandys
: catch ( ca -- 0 | err# )
sp@ >r (local) @ >r handler @ >r
rp@ handler ! execute
r> handler ! r> (local) !
r> drop 0 ;
: throw ( err# -- err# )
handler @ rp!
r> handler ! r> (local) ! r>
swap >r sp!
drop r> ;
: @execute ( a -- ) @ ?dup if execute then ;
: (abort) ( a -- ) 'abortTrap @execute throw ;
: (abort") ( ? -- ) do$ swap if (abort) then
drop ; compile-only
lastcode _(abort") !
\ vandys
\ here ( -- a )
\ Return the top of the code dictionary
: here cp @ ;
\ pad ( -- a )
\ Return address of text buffer above code dictionary
#TIBLINE constant #TIBLINE
: pad here #TIBLINE + ;
\ align ( -- )
\ Align HERE with a cell boundary
: align here aligned cp ! ;
\ allot ( n -- )
\ Allocate n bytes to the code dictionary
: allot cp +! ;
\ unloop Remove current do..loop state from return stack
: unloop r> r> drop r> drop r> drop >r ;
\ vandys
\ cmove ( b1 b2 u -- )
\ Copy u bytes from b1 to b2
code cmove
ecx pop
edi pop
eax pop
esi push
eax esi mov
rep byte movs
esi pop
next c;
\ vandys
\ cmove> ( b1 b2 u -- )
\ Copy u bytes from b1 to b2, from higher to lower
code cmove>
ecx pop
edi pop
eax pop
esi push
eax esi mov
ecx edi add
ecx esi add
esi dec
edi dec
std
rep byte movs
cld
esi pop
next c;
\ vandys
\ move ( a1 a2 u -- )
\ Copy u bytes from a1 to a2, avoiding copy ripple
code move
ecx pop edi pop eax pop esi push eax esi mov
edi esi cmp \ Determine direction
1 $ jg
ecx eax mov \ Scale count by word size
eax dec \ Point to last byte
eax edi add \ Copy from high to low
eax esi add
std rep byte movs cld esi pop next
\ Copy forward
1 $: rep byte movs esi pop next c;
\ vandys
code fill ( a u c -- )
eax pop ecx pop edi pop rep byte stos next c;
code wfill ( a u-count u-val -- )
eax pop ecx pop edi pop rep stos next c;
: erase ( b u -- ) 0 fill ;
\ vandys
\ -trailing ( b u -- b u )
\ Adjust the count to eliminate trailing white space
: -trailing
begin dup 0= if exit then
2dup 1- + c@ bl > if exit then
1- again ;
\ pack$ ( b u a -- a )
\ Build a counted string with u chars from b. Null fill
: pack$ aligned dup >r \ Strings on cell boundary
over dup 0 1 cells um/mod drop \ Count mod cell
- over + 0 swap ! \ Null fill cell
2dup c! 1+ \ Save count
swap cmove r> ; \ Move string, return address
\ digit ( u -- c )
\ Convert digit u to a character
: digit 9 over < 7 and + 48 + ;
\ vandys
\ extract ( n base -- n c )
\ Extract the least significant digit from n
: extract 0 swap um/mod swap digit ;
\ <# ( -- )
\ Initiate the numeric output process
: <# pad hld ! ;
\ hold ( c -- )
\ Insert a character into the numeric output string
: hold hld @ 1- dup hld ! c! ;
\ # ( u -- u )
\ Extract one digit from u and append digit to out string
: # base @ extract hold ;
\ #s ( u -- 0 )
\ Convert u until all digits are added to the output string
: #s begin # dup 0= if exit then again ;
\ vandys
\ sign ( n -- )
\ Add a minus sign to the numeric output string
: sign 0< if 45 hold then ;
\ #> ( w -- b u )
\ Prepare the output string to be TYPE'd
: #> drop hld @ pad over - ;
\ str ( w -- b u )
\ Convert a signed integer to a numeric string
: str dup >r abs <# #s r> sign #> ;
\ hex ( -- )
\ Use radix 16 as base for numeric conversions
: hex 16 base ! ;
\ decimal ( -- )
\ Use radix 10 as base for numeric conversions
: decimal 10 base ! ;
\ Digit parsing vandys
: -digit ( c -- n ) $30 - dup 9 > if 7 - dup $A < or then
dup base @ u< not if tmp1 @ base ! tmp @ throw then ;
: 10*+ ( u a n - u a ) -digit rot base @ * + swap ;
: +ch ( a n -- a' n' ) 1- swap 1+ swap ;
\ Number parsing, also keyboard primitive vandys
: number ( a -- n )
dup tmp ! base @ tmp1 !
count over c@ $2D = dup >r if +ch then
over c@ $24 = if hex +ch then
over c@ $27 = over 2 = and if drop 1+ c@
else 0 -rot ( 0 a #)
0 do ( u a ) dup c@ 10*+ 1+ loop drop
then
r> if negate then tmp1 @ base ! ;
lastcode tnumber !
: (key?) ( -- c T | F ) 2 'ttyops @execute ;
\ vandys
\ key? ( -- T | F )
\ Map (key?) onto the standard key? semantics.
: key?
\ A previously detected keystroke is still available
keychar c@ if true exit then
\ Have a new key, save it and flag its presence
(key?) dup if swap keychar c! then
;
\ key ( -- c )
\ Spin until we get a keystroke
: key
\ Wait for a key
begin key? until
\ Pull it from keychar, clear it, and done
keychar c@ 0 keychar c!
;
\ vandys
\ emit ( c -- )
\ Send a character to the output device
: emit 1 'ttyops @execute ;
\ 'rdwt ( -- a )
\ Vector to disk I/O services
create 'rdwt here _'rdwt ! 0 ,
\ rdwt ( a blockno flag -- bool )
\ Hook out to block driver (if any)
: rdwt 'rdwt @ ?dup if execute else 2drop drop true then ;
\ nuf? ( -- T | F )
\ Return false if no input, else pause and if CR return true
: nuf? (key?) dup if 2drop key 13 = then ;
\ space ( -- )
\ Send the blank character to the output device
: space bl emit ;
\ vandys
\ spaces ( +n -- )
\ Send n spaces to the output device
: spaces 0 ?do space loop ;
\ type ( b u -- )
\ Output u characters from b
: type 0 ?do dup c@ emit 1+ loop drop ;
\ cr ( -- )
\ Output a carriage return and a line feed
: cr 13 emit 10 emit ;
\ (c") ( -- a )
\ Run-time to return address of compiled string
: (c") do$ ;
lastcode _(c") !
\ (.") ( -- )
\ Run time routine of ." . Output a compiled string
: (.") do$ count type ;
lastcode _(.") !
\ vandys
\ .r ( n +n -- )
\ Display integer in a field of n columns, right justified
: .r >r str r> over - spaces type ;
\ u.r ( u +n -- )
\ Display an unsigned integer in n column, right justified
: u.r >r <# #s #> r> over - spaces type ;
\ u. ( u -- )
\ Display an unsigned integer in free format
: u. <# #s #> space type ;
\ . ( w -- )
\ Display an integer in free format, preceeded by a space
: . base @ 10 xor if u. else str space type then ;
\ ? ( a -- )
\ Display the contents in a memory cell
: ? @ . ;
\ vandys
\ vandys
code (parse) edx pop 0 [esp] ecx mov 4 [esp] ebx mov
ecx ecx or 1 $ je
32 # dl cmp 2 $ jne
3 $: 0 [ebx] al mov 32 # al cmp 5 $ jg ebx inc
ecx dec 1 $ je 3 $ jmp
5 $: ebx push
7 $: ecx ecx or 4 $ je 0 [ebx] al mov 32 # al cmp 6 $ jle
ebx inc ecx dec 7 $ jmp
2 $: ebx push
8 $: ecx ecx or 4 $ je 0 [ebx] al mov dl al cmp 6 $ je
ebx inc ecx dec 8 $ jmp
4 $: edx pop ebx eax mov edx eax sub eax 0 [esp] mov
ebx eax mov 4 [esp] eax sub edx 4 [esp] mov eax push next
1 $: ecx 0 [esp] mov ebx 4 [esp] mov 0 push# next
6 $: edx pop ebx eax mov edx eax sub eax 0 [esp] mov
ebx eax mov 4 [esp] eax sub edx 4 [esp] mov eax inc
eax push next
c;
\ vandys
\ vandys
\ parse ( c -- b u <string> )
\ Scan input stream and return counted string delimited by c
: parse >r tib @ >in @ + #tib @ >in @ - r> (parse) >in +! ;
\ .( ( -- )
\ Output following string up to next )
: .( 41 parse type ; immediate
\ ( ( -- )
\ Ignore following string up to next ) . A comment.
: ( 41 parse 2drop ; immediate
\ \ ( -- )
\ Ignore following text till the end of line
: \ #tib @ >in ! ; immediate
\ char ( -- c )
\ Parse next word and return its first character
: char bl parse drop c@ ;
\ vandys
\ token ( -- a <string> )
\ Parse word from input stream, build it into the pad
: token bl parse 31 min pad pack$ ;
\ word ( c -- a <string> )
\ Parse word from input stream, copy to code dictionary
: word parse here pack$ ;
\ Dictionary search
\ name> ( na -- ca )
\ Return a code address given a name address
: name> cell- cell- @ ;
\ vandys
$1F constant lenmask
\ find ( a va -- ca na | a F )
code find ecx pop
2 $: 0 [ecx] ecx mov ecx ecx or 1 $ je
0 [esp] ebx mov 0 [ebx] al mov lenmask # eax and
0 [ecx] dl mov lenmask # edx and dl al cmp 3 $ jne
ebx inc ecx edx mov edx inc
4 $: 0 [ebx] ah mov 0 [edx] ah cmp 3 $ jne
al dec 5 $ je
ebx inc edx inc 4 $ jmp
3 $: 4 # ecx sub 2 $ jmp
1 $: 0 push# next
5 $: -8 [ecx] eax mov eax 0 [esp] mov ecx push next
c;
\ See shadow for lotsa comments
\ vandys
\ Return dot position or 0
: (dot?) ( a -- a a' | a 0 ) dup count over + swap do
i c@ [char] . = if i unloop exit then loop 0 ;
\ Access dotted string in its various forms
: (str>len) ( a a' -- a a' u ) 2dup swap - 1- ;
: (str>base) ( a a' -- a a' ) 2dup swap c@ swap c!
(str>len) >r over r> swap c! ;
: (ext>str) ( a a' -- a a' ) [char] . over c! ;
: (base>str) ( a a' -- a a' ) 2dup c@ swap c! (ext>str) ;
: (str>ext) ( a a' -- a a' ) (str>len) >r over c@ r> - 1- over c! ;
: (unbase) ( a a' va -- a a' va ) -rot (base>str) rot ;
: ca>nfa ( a -- a' ) begin 1- dup c@ $80 and until ;
: voc>nfa ( voc -- nfa ) 3 cells - ca>nfa ;
: (cnt) ( a -- a' u ) count lenmask and ;
: (ent=) ( a1 a2 -- bool ) (cnt) >r swap (cnt) r> over - if
drop 2drop false exit then
0 do 2dup i + c@ swap i + c@ - if
2drop unloop false exit then
loop 2drop true ;
\ vandys
: (vocab?) ( a a' -- a 0 | a a' va )
(str>base) current begin
cell+ @ dup while 2 pick over voc>nfa (ent=) if
(unbase) exit then
repeat (unbase) nip ;
: dotname? ( a -- ca na | a F )
(dot?) dup 0= if exit then
(vocab?) dup 0= if exit then >r (str>ext) dup r> find
?dup if >r >r (ext>str) 2drop r> r> exit then
drop (ext>str) drop false ;
variable 'local?
: name? ( a -- ca na | a F )
'local? @ ?dup if execute ?dup if exit then then
context dup 2@ xor if cell- then
>r begin r> cell+ dup >r
@ ?dup 0= if r> drop dotname? exit then
find ?dup if r> drop exit then
again ;
\ shacham
\ Terminal response and line editing
: (#tib@) ( -- a ) #tib @ cell+ ;
: (#tib>dist) ( a -- a') (#tib@) ;
: (#tib>c) ( a -- a' ) (#tib>dist) cell+ ;
: (>dist) ( n -- ) dup (#tib>dist) c! ;
: (<dist) ( -- n ) (#tib>dist) c@ ;
: (notbol?) ( bot eot cur -- bot eot cur ) >r over r> swap over = not ;
: (lchar) ( cur -- cur c ) dup 1 - c@ ;
: (rchar) ( cur -- cur c ) dup 1+ c@ ;
: (echoc) ( c -- ) 'echo @execute ;
: (bs) ( bot eot cur -- bot eot cur ) 8 (echoc) ;
: (^b) ( bot eot cur -- bot eot cur ) (bs) 1 - ;
: (^f) ( bot eot cur -- bot eot cur ) dup c@ (echoc) 1+ ;
: (keyc) ( bot eot cur c -- bot eot cur ) dup (echoc) over c! 1+ ;
: (char>r) ( bot eot cur -- bot eot cur ) (lchar) (keyc) 2 - ;
: (char<r) ( bot eot cur -- bot eot cur ) (rchar) (keyc) ;
: (dist^b) ( bot eot cur -- bot eot cur ) (<dist) 0 do (^b) loop ;
: (n^f) ( bot eot cur n -- bot eot cur ) 0 do (^f) loop ;
\ shacham
: (dist>0) ( cur eob eot -- cur u ) nip over - dup 0< if drop 0 then ;
\ (cur>eot) ( bot eot cur -- bot eot cur n )
\ Distance between cur and right most non-blank char (i.e. eot')
\ Note: only scenarios where cur is left of eot' are handled
: (cur>eot) >r 2dup r> rot rot begin 2dup = not while
(lchar) bl = if 1 - else (dist>0) exit then
repeat 2drop 0 ;
\ Stack for all line editing words -- ^a ^b ^d ^e ^f ^h ^k ^u -- is
\ ( bot eot cur -- bot eot cur )
: ^a begin (notbol?) while (^b) repeat ;
: ^b (notbol?) if (^b) then ;
: ^d (cur>eot) ?dup if (>dist) 0 do (char<r) loop (dist^b) then ;
: ^e (cur>eot) ?dup if (n^f) then ;
: ^f (cur>eot) if (^f) then ;
: ^h (notbol?) if (^b) ^d then ;
: ^k (cur>eot) ?dup if (>dist) 0 do bl (keyc) loop (dist^b) then ;
: ^u begin (notbol?) while ^h repeat ;
\ shacham
\ (1char>) ( bot eot cur -- bot eot cur )
\ Shift command line one char right starting at cur as
\ preparation for insertion of a new char at cur
: (1char>) (cur>eot) ?dup if (>dist) (n^f)
(<dist) 0 do (char>r) (bs) (bs) loop then ;
\ tap ( bot eot cur c -- bot eot cur )
\ Accept and echo the key and bump the cursor
: tap (#tib>c) c! (1char>) (#tib>c) c@ (keyc) ;
\ vandys
\ History of commands
#HIST constant #HIST #HIST 1- constant HISTMASK 72 constant #HISTSH
: (#tib) ( -- u ) #tib @ #TIBLINE min ;
: (histmask) ( n -- u ) HISTMASK and ;
\ Locating history under tib
: (hist@) ( -- a ) tib @ #TIBLINE + ;
: (hist>put) ( a -- a' ) (hist@) ;
: (hist>pos) ( a -- a' ) (hist@) cell+ ;
: (hist>str) ( a -- a' ) (hist>pos) cell+ ;
\ (#histib) ( -- u )
\ History slot for current command
: (#histib) (hist>put) @ (histmask) ;
\ (histib>) ( u -- a )
\ Address of n-th counted string in history array
: (histib>) #TIBLINE 1+ * (hist>str) + ;
\ vandys
\ (>hist) ( -- )
\ Keep current command, if not empty
: (>hist) #tib @ 0 > if
(#tib) (#histib) (histib>) tuck c! \ keep command length
tib @ swap count move \ and string
(hist>put) inc \ increment history counter
then ;
\ history ( -- )
\ Show command history, oldest first
: history cr #HIST 0 do
(hist>put) @ #HIST - i + dup 0< if drop else
dup . space
(histmask) (histib>) count #HISTSH min type cr
then loop ;
\ shacham
\ (>histp) ( n -- )
\ History slot displacement, range is 0(current) to -#HIST(oldest)
: (>histp) (hist>pos) @ + dup 0 > if drop exit then
dup #HIST + 0< if drop exit then
dup (hist>put) @ + 0< if drop exit then
(hist>pos) ! ;
\ (clrbl) ( bot eot cur - bot eot cur )
\ Remove trailing blanks of a command line
: (clrbl) begin (lchar) bl = while ^h repeat ;
\ (<hist) ( bot eot cur a -- bot eot cur )
\ Fetch a command from history into CLI
: (<hist) count over + swap do i c@ tap loop ;
\ (^p) ( bot eot cur n -- bot eot cur )
: (^p) (>histp) ^e ^u (hist>pos) @ ?dup if
(hist>put) @ + (histmask) (histib>) (<hist) (clrbl) then ;
\ ^p and ^n ( bot eot cur -- bot eot cur )
\ Recall the previous or newer history command, if any
: ^p -1 (^p) ;
: ^n 1 (^p) ;
\ vandys
: kTAP ( bot eot cur c -- bot eot cur )
dup 1 = if drop ^a exit then dup 2 = if drop ^b exit then
dup 4 = if drop ^d exit then dup 5 = if drop ^e exit then
dup 6 = if drop ^f exit then dup 8 = if drop ^h exit then
dup 11 = if drop ^k exit then dup 14 = if drop ^n exit then
dup 16 = if drop ^p exit then dup 21 = if drop ^u exit then
13 = if ^e swap drop dup else bl tap then ;
: blank ( b u -- ) bl fill ;
: accept ( b u -- b u' ) 2dup blank over + over begin
2dup = if drop over - exit then
key dup
bl 127 within if tap else 'tap @execute then
again ;
: expect ( b u -- ) 'expect @execute span ! drop ;
\ vandys
\ vandys
\ vandys
: query ( -- ) (hist>pos) off
tib @ #TIBLINE 'expect @execute #tib ! drop >in off ;
create null$ 0 ,
: abort ( -- ) null$ throw ;
\ The text interpreter
\ #compile-only, #immediate, #markb
\ Flags in byte of dictionary string count
#compile-only constant #compile-only
#immediate constant #immediate
#markb constant #markb
\ vandys
: $interpret ( a -- )
name? ?dup if
c@ #compile-only and abort" compile only" execute
else 'number @execute then ;
: [ ( -- ) ['] $interpret 'eval ! ; immediate
: compiling? ( -- ? ) ['] $interpret 'eval @ <> ;
: .ok ( -- ) compiling? 0= if ." Ok" then cr ;
: ?stack ( -- ) depth 0< abort" underflow" ;
\ vandys
\ eval ( -- )
\ Interpret the input stream
: eval
begin
token dup c@ 0= if drop 'prompt @execute exit then
'eval @execute ?stack
again ;
\ Shell
\ preset ( -- )
\ Reset data stack pointer and the terminal input buffer
: preset sp0 @ sp! tib0 @ tib ! #tib off blk off ;
\ xio ( a a a -- )
\ Reset the I/O vectors 'EXPECT, 'TAP, 'ECHO and 'PROMPT
: xio ['] accept 'expect 2! 'echo 2! ; compile-only
\ vandys
\ hand ( -- )
\ Select I/O vectors for terminal interface
: hand ['] .ok ['] emit ['] kTAP xio ;
\ console ( -- )
\ Initiate terminal interface
: console hand ;
\ vandys
\ quit ( -- )
\ Reset return stack pointer and start text interpreter
: quit rp0 @ rp! console handler off
begin
preset
[compile] [ begin
query (>hist) ['] eval catch
?dup until
'prompt @ >r
console null$ over xor if
space count type ." ?? "
then
r> ['] .ok xor if
27 emit
then
again ;
\ vandys
\ The compiler
: ' ( -- ca ) token name? if exit then throw ;
: , ( w -- ) here dup cell+ cp ! ! ;
: [compile] ( -- <string> ) ' , ; immediate
: (compile) r> dup @ , cell+ >r ; compile-only
: (genhook) ( -- ) gensusp @ ?dup if 1- gensusp ! else
'genhook @execute then ;
: compile ( -- ) (genhook)
1 gensusp ! ['] (compile) , ; immediate
\ vandys
\ literal ( w -- )
\ Compile tos to code dictionary as an integer literal
: literal (genhook) (compile) doLIT , ; immediate
\ $," ( -- )
\ Compile a literal string up to next "
: ($,c) ( c -- ) word count + aligned cp ! ;
: $," [char] " ($,c) ;
\ recurse, tailrecurse ( -- )
\ Make the current word available for compilation
: recurse (genhook) last @ name> , ; immediate
: tailrecurse (genhook)
(compile) branch last @ name> cell+ cell+ , ; immediate
\ Control structures
\ leave ( -- ) Depart innermost do..loop
code leave
8 [ebp] eax mov 0 [eax] esi mov $C # ebp add next c;
\ vandys
\ do ( n n -- )
\ Start a do..loop structure in a colon definition
: do (genhook) (compile) (do) here 0 , ; immediate compile-only
\ (resloop) ( n -- )
\ Resolve compilation of do..loop construct
: (resloop) here cell+ over ! cell+ , ;
\ loop ( -- )
\ Iterate do..loop
: loop
(genhook)
(compile) (loop) (resloop) ; immediate compile-only
\ qdo ( n n -- )
\ Start a ?do..loop structure in a colon definition
: ?do
(genhook)
(compile) (?do) here 0 , ; immediate compile-only
\ vandys
\ +loop ( -- )
\ Iterate do..loop with increment
: +loop
(genhook)
(compile) (+loop) (resloop) ; immediate compile-only
\ begin ( -- a )
\ Start an infinite or indefinite loop structure
: begin here ; immediate compile-only
\ until ( a -- )
\ Terminate a BEGIN-UNTIL indefinite loop structure
: until
(genhook)
(compile) ?branch , ; immediate compile-only
\ again ( a -- )
\ Terminate a BEGIN-AGAIN infinite loop structure
: again
(genhook)
(compile) branch , ; immediate compile-only
\ vandys
\ (if) ( -- a )
\ Begin a conditional branch structure
: (if)
(genhook)
(compile) ?branch here 0 , ;
\ if ( -- a )
\ Compile-time invocation of (if)
: if (if) ; immediate compile-only
\ ahead ( -- a )
\ Compile a forward branch instruction
: ahead (compile) branch here 0 , ; immediate
\ repeat ( A a -- )
\ Terminate a BEGIN-WHILE-REPEAT indefinite loop
: repeat
(genhook)
(compile) branch , here swap ! ; immediate compile-only
\ vandys
\ (then) ( a -- )
\ Terminate a conditional branch structure
: (then) here swap ! ;
\ then ( a -- )
\ Compile-time invocation of (then)
: then (then) ; immediate compile-only
\ else ( a -- a )
\ Start the false clause in an IF-ELSE-THEN structure
: else [compile] ahead swap (then) ; immediate compile-only
\ while ( a -- A a )
\ Conditional branch out of a BEGIN-WHILE-REPEAT loop
: while (if) swap ; immediate compile-only
\ abort" ( -- <string> )
\ Conditional abort with an error message
: abort"
(genhook)
(compile) (abort") $," ; immediate
\ vandys
\ c" ( -- <string> )
\ Compile an inline string literal
: c"
(genhook)
(compile) (c") $," ; immediate compile-only
\ ." ( -- <string> )
\ Compile inline string literal to be typed out at run time
: ."
(genhook)
(compile) (.") $," ; immediate compile-only
\ Name compiler
\ unique? ( a -- a )
\ Display a warning message if the word already exists
: unique?
dup name? if
." reDef " over count type
then drop ;
\ vandys
\ (compf) ( f -- )
\ Set header flag in LAST's entry
: (compf) last @ c@ or last @ c! ;
\ $,n ( a -- )
\ Build a new dictionary name using the string at "a"
: $,n align
dup c@ 0= if c" name" throw then \ Edge case
unique? \ Redefinition?
here swap 0 , \ CFA will be filled in shortly
current @ @ , \ LFA
here last ! \ Save NFA for vocab link
count here pack$ \ Copy name into place
c@ 1+ aligned allot \ Get room for name
#markb (compf) \ Flag first byte of entry name
here swap ! \ Fill in CFA pointer
;
\ vandys
\ FORTH compiler
variable (tracing?)
: $compile ( a -- )
(tracing?) @ if bl emit dup count type then
name? ?dup if @ #immediate and if execute else (genhook) , then
else 'number @execute [compile] literal
then ;
\ Compilation--finishing & cleanup vandys
: overt ( -- ) last @ ?dup if current @ ! then ;
code (;) ( -- ) next c;
: ?csp ( -- ) sp@ csp @ xor abort" stacks" ;
variable 'endDef variable 'semiHook
: ; ( -- ) 'semiHook @execute
(genhook) gensusp off 'local? off
(compile) exit (compile) (;)
[compile] [ overt
'endDef @execute ?csp ; immediate compile-only
\ vandys
\ (c;ode) ( -- ) */
\ Terminate a colon definition, jumping into assembly
code (c;ode)
esi jmp
c;
\ ] ( -- )
\ Start compiling the words in the input stream
: ] ['] $compile 'eval ! ;
\ call, ( ca -- )
\ Assemble a call instruction to ca
: call, $E82E2E2E , here cell+ - , ;
\ call! ( ca addr -- )
\ Back-patch a call instruction at addr to ca
: call! $E82E2E2E over ! cell+ swap over cell+ - swap ! ;
\ !csp ( -- )
\ Save stack pointer in CSP for error checking.
: !csp sp@ csp ! ;
\ vandys
: (:) ( a -- ) $,n ['] doLIST call, ] !csp ;
: : ( -- <string> ) token (:) ;
: immediate ( -- ) #immediate (compf) ;
: compile-only ( -- ) #compile-only (compf) ;
\ Defining words
: user ( u -- <string> ) token $,n overt
['] doLIST call, (compile) doUSER , ;
\ vandys
: (listent) ( a -- ) $,n overt ['] doLIST call, ;
: (create) ( a -- ) (listent) (compile) doVAR ;
: create token (create) ;
: variable create 0 , ;
: (constant) ( n a -- ) (listent) (compile) doCONST , ;
: constant ( n -- ) token (constant) ;
: _type ( b u -- ) 0 ?do dup c@ >char emit 1+ loop drop ;
\ vandys
\ dm+ ( a u -- a )
\ Dump u bytes from , leaving a+u on the stack.
: dm+ over 4 u.r space 0 ?do
dup c@ 3 u.r 1+
loop ;
\ dump ( a u -- )
\ Dump u bytes from a, in a formatted manner.
: dump base @ -rot hex
15 + 16 / 0 do
cr 16 2dup dm+
rot rot 2 spaces _type nuf? if leave then
loop drop base ! ;
\ .s ( ... -- ... )
\ Display the contents of the data stack.
: .s depth begin dup 0 > while dup pick . 1- repeat
drop ." <sp" ;
\ vandys
\ Other field pointer conversions
\ nfa - Name Field Address cfa - Code Field Address
\ lfa - Link Field Address
\ vandys
: nfa>cfa cell- cell- ;
: nfa>lfa cell- ;
: cfa>nfa cell+ cell+ ;
: cfa>lfa cell+ ;
: lfa>cfa cell- ;
: lfa>nfa cell+ ;
\ .id ( na -- )
\ Display the name at address
: .id ?dup if count $1F and _type else ." {noName}" then ;
\ (>name) Compare next entry against our desired code address
: (>name) ( ca lfa -- ca nfa' bool | ca 0 F )
@ dup if 2dup nfa>cfa @ xor else false then ;
\ vandys
\ >name ( ca -- nfa | F )
\ Convert code address to a name address.
\ Verifies that it's actually the code address of a word, unlike
\ ca>nfa.
: >name
current begin
cell+ @ ?dup 0= if drop false exit then
( ca voc )
2dup begin (>name) while
( ca voc ca nfa )
nfa>lfa
repeat
( ca voc ca nfa/0 )
nip
( ca voc nfa/0 )
?dup until
nip nip ;
\ Decompilation, word listing vandys
: (see) ( a -- ) cr cell+ begin
cell+ dup @ dup if
dup ['] (;) = if 2drop exit then
>name then
?dup if space .id else dup @ u. then
again ;
: see ( -- <word> ) ' (see) ;
: words ( -- ) cr context @ begin
@ ?dup 0= if exit then
dup space .id nfa>lfa again ;
\ vandys
\ Hardware reset
\ ver ( -- n )
\ Return Major version * 256 plus Minor
VER 256 * EXT + constant ver
\ 'pause ( -- a )
\ Vector out to multi-tasking
variable 'pause
\ pause ( -- )
\ Hook out to multi-tasking (if any)
: pause 'pause @execute ;
\ only ( -- )
\ Set search order and definitions to "forth"
variable ('endDef)
: only forth context cell+ #VOCS cells erase
context @ dup context cell+ ! current ! ('endDef) @execute ;
\ vandys
\ initialize ( -- )
\ Vocabulary holding words to run at system init
vocabulary initialize
\ Flag if we're cold starting the system, or continuing from a
\ memory snapshot
create (warm?) false , \ Default, cold start system image
: cold? (warm?) @ not ;
\ vandys
\ (initialize) ( -- )
\ Run all initialization words
\ Our "special" vocabulary "initialize" holds words, each of which
\ is executed during system startup. Thus, any module which wants
\ some intialization code to run can compile its own word into
\ this vocabulary.
\ Each word is invoked with a boolean flag; if the flag is false,
\ the word returns its initialization order index, but does not
\ otherwise execute any initialization actions. If the flag is true,
\ the word executes its initialization (it is guaranteed that it
\ will only be invoked with a true flag once).
\ This index from the initialization word tells the system which order
\ init routines should be invoked; the word with the lowest index
\ executes first, followed by successively larger index values.
\ The lowest legal index value is 1, the highest is 100,000. Each
\ index value must be unique.
\ Execute function with each entry in the initialization dictionary
: (each-init) ( fn -- ) initialize
context @ begin @ ?dup while
over execute nfa>lfa repeat drop only ;
\ vandys
\ Return lowest entry above "n", and its index
variable (low-n) variable (low-seen) variable (low-fn)
: (low-scan) ( nfa -- nfa )
false over nfa>cfa @execute
dup (low-n) @ > over (low-seen) @ < and if
(low-seen) ! dup (low-fn) !
else drop then ;
: (low-above) ( n -- n' fn )
(low-n) ! 100001 (low-seen) ! 0 (low-fn) !
['] (low-scan) (each-init) (low-seen) @ (low-fn) @ ;
\ Execute init routines in their defined order, until all are run
: (initialize)
0 begin
(low-above)
dup if true over nfa>cfa @execute then
0= until drop ;
\ vandys
variable (mem_upper)
: hi ( -- ) cr ." ForthOS v" ver dup 256 / 1 u.r ." ." 256 mod 1 u.r
cold? not if ." (restored from snapshot)" then cr
(mem_upper) ? ." bytes of upper memory" cr ;
: init-bootinfo ( ebx eax -- ) 4194304 (mem_upper) !
$2BADB002 = if dup @ 1 and if
cell+ cell+ @ 1024 * (mem_upper) ! then then ;
: cold ( ebx eax -- )
init-bootinfo begin
user0 up @ #user cmove (hist>put) off
preset
(initialize)
hi
quit
again ;
\ Patch cold1 to cold's CFA
lastcode cold1 @ !
\ vandys
\ ====================================================================
\ The metacompiled image now lies between base_mem and here. We
\ riffle through the image and relocate all references to our target
\ address.
\ ====================================================================
\ This is the point when we should incorporate additional source
\ like the assembler, console and disk driver, ...
\
\ meta->target \ Stop referencing "target" vocabulary
\ ( extensions meta forth -> target )
\ fixups \ Back-patch needed values
\ base_mem @ dup here relocate
\ \ <base mem> <dest block #> <# blocks> write_image
\ here over - >blocks dup . ." blocks" cr IMAGE_BLOCK swap write_image
\ forth->forth \ Return to basic system search order
These flags bits are in the length count byte of the name string
of an entry in a vocabulary.
History state TIB itself
Room for return stack, then TIB state
Place to back-patch "cold"'s CFA
Set up ForthOS environment and start executing words
Set operand and return stack to our memory
Initialize direction
Record eax/ebx, filled in by Multiboot loader
Jump to our cold start code
Pointer to vocabulary which is receiving definitions
This cell points to a list of all vocabularies on the system
code (do)
Register our support code for the metacompiler
Make room for our three return stack arguments:
Iteration point (with ptr to exit point)
And our current count and termination value
code tuck Insert copy of top below second
code 0< Return true if n is negative
Priority of user task
A keystroke seen from (key?) and stored for key?/key
A word is about to be compile, this hook lets a debugging system
insert some trap code. We also have a count so this can be suspended
temporarily when needed (e.g., exec:)
Trap to debugger, for generated code and for aborts
Current working directory, followed by root directory
Reentrant temporary storage for applications
Pointer to stack frame on return stack for local variables
: ?dup Dup tos if it is not zero
: rot Rot 3rd item to top
: -rot Rot top item to 3rd
: 2drop Discard two items on stack
: 2drop Duplicate top two items
code + Add top two items
: not Bitwise inversion
: dnegate Two's complement negation of double value
code on/off Put boolean value into cell at location
code inc/dec Increment/decrement cell at location
code 0= Return true if top is 0
code <> Return true if two words are not equal
Our boolean values
: >char Filter non-printing characters
: depth Return the depth of the data stack
: pick Copy the nth stack item to tos
: +! Add n to the contents at address a
: c+! Add n to the byte contents at address a
Load/store of double and triple words
: count Return count byte of a string and add 1 to byte address
: do$ Return the address of a compiled string
: catch Execute word at ca and set up an error frame for it
Save error frame
Mark error frame, then execute passed routine
Restore error frame
No error, no need to reset stack, just return 0
: throw Reset system to current local error frame, update err flag
Restore return stack
Restore handler frame
Save error # on return stack, then restore data stack
Drop old "ca" from "catch", get error # back, and return
: @execute Fetch vector and execute if non-zero
: (abort) Do the actual abort
: (abort") Run time routine of abort" . Abort with a message.
Hook for metacompiler use
Make #TIBLINE visible to the source
code fill Fill u bytes of character c to area beginning at a
code wfill Fill u-count words (cells) of value u-val beginning at a
: erase Zero u bytes at area beginning at b
: -digit Convert digit to value, abort on bad digit. (Abort path
has to restore base, which may have been overriden in "number")
: 10*+ Accumulate another numeric position
: +ch Advance char pointer one position
: number Convert a number string to integer
Save string pointer (for error display), also save base
Flag negative number, we'll build as positive and convert at end
Switch to hex input on $<hex>
$c puts in "c"'s ASCII value
Otherwise loop across digits, assembling a value
: (key?) Return input character and true, or a false if no input
code (parse) ( b u c -- b u <delta> )
dl has delim, ebx has ptr, ecx has count
Original count & ptr are left on stack; ptr used to generate delta
If delim is blank, skip leading whitespace
This is the loop for skipping leading whitespace
Now scan bytes until delim, any non-blank delim will do
This is the same as the loop above, but looking for a single, specific
delim
Assembled word until end of input; no delim found at end
No word assembled, restore pointers and return delta of 0
Assembled until delim found
Mask of length bits in name field of directory entry
code find Search a vocabulary for a counted string, see notes below
ecx points to current vocab entry being checked
Advance to next vocab entry
ebx points to name, check count against current vocab entry
Advance ebx, edx points to rest of entry name, count in al
Check next char, leave on mismatch
Decrement count of chars in strings
Advance string pointers and loop
Point back to LFA of entry, then iterate loop
Search failed, return search string and 0
Success, entry points at name so back up to CFA and fetch it to get
actual code address. NFA and CA are returned on stack.
Notes: ecx holds the current vocab entry being checked. We leave the
string being searched on the stack, as we're a little short of registers.
Since the string compare moves the pointers, we have the entry's string
in edx for the compare, and the search string in ebx.
vandys
: (dot?) Tell if there's a dot embedded in the string. Returns
original pointer, and pointer to dot or 0.
: (str>len) Calculate length of base portion of string
: (str>base) Make "a" point to just base portion of string
(the part up to, but not including, the dot)
: (ext>str) Restore "a" to the whole string
: (base>str) Switch from base back to whole string
: (str>ext) Make a' point to just extension portion of string
: (unbase) Move from base back to str, avoiding vocab addr on TOS
: ca>nfa Walk from beginning of code back to NFA
: voc>nfa Walk back from body of vocab to its NFA
: (cnt) Return count for vocab entry
: (ent=) Compare two vocab entries, return whether they're the same
name.
: (vocab?) Find a vocabulary based on its name
Convert to base and walk vocabulary chain...
Next vocabulary... Compare names
Found, return success
Loop... return just ( a 0 ) for failure
: dotname? Handle vocab.name format
Burst to dotted components
Find vocabulary; Find name in vocabulary
Found; restore string and return ca/na
Not found; restore string and return base of string and false
Vector for local variable names, which take precedence over others
: name? Search all vocabularies for a string
If locals, search'em first
Don't search vocab twice if context == 1st vocab in search order
Loop Get next vocab to search, advancing pointer
End of list, not found so try <vocab>.<name> format
Search this vocab, leave if we find the name
shacham
(#tib>c) and (#tib>dist) store the current key and the distance
from cur to end-of-text when intermediate words require
usage of ( bot eot cur ) on the stack. '3 roll' and '3 pick'
promise the functionality of moving top-of-stack under
the said triple and back, but the words are not available.
shacham
Line editing bash/emacs style -
: ^a place cursor at begining of buffer
: ^b move cursor one char left, if possible
: ^d remove char under cursor and move command line one char left
: ^e place cursor at end-of-text, i.e. following right-most non-blank char
: ^f move cursor one char right, up to end of text
: ^h remove char left of cursor and move command line one char left
: ^k delete all text from cursor till end of line
: ^u delete all text left of cursor
Line editing words get as input the triple
bot - start of input buffer, i.e. bob
eot - end of input buffer, i.e. eob
cur - current location of cursor
thus nowhere is the location of end of actual text entered by user.
Therfore, (cur>eot) calculates the number of chars from cur to
the right-most non-blank char. The info is used for placing
the cursor at the end of text. Another example of usage is for
shifting text when deleting/adding a char within the string.
If there are trailing blanks beteween cur and end-of-text, the distance
is considered 0, i.e. the trailing blanks are considered text.
A caveat: Trailing blanks are lost in ^e when the cursor is left of eot.
: tap In insert mode, when cursor is not at end-of-text, move command line
one char to right, then put the current key in place.
TODO: Handle override mode.
\ vandys
History counters and buffer are all in 'user tib'. The variables
start after tib, and the array of history commands follows.
The history command buffer should have a power of 2 entries.
The history command index (hist>put) is a running counter, which warps
around at cell boundary. (histmask) maps the counter to a buffer index
by masking the relevant least significant bits.
Browsing history commands from the CLI, aka ^p and ^n, is using (hist>pos)
to keep the current location.
History commands are stored as counted strings, i.e. 1 byte length
followed by #TIBLINE chars.
btw, #tib is not trusted to be in the range 0 to 80.
TODO: Is counted-string of 81 char align-friendly?
vandys
history
Show history commands, each line starting with a running index.
The command string show is limited to #HISTSH chars in order
to allow show of a 32-bit index and avoid display line wraparound.
The history buffer is presented oldest first. As fewer commands
may be present, non-existing indices are quietly ignored.
TODO: 32-bit counter wraparound - verify no history loss.
(As 32-bit cell becomes negative after 2G operations
and rollover after 4G, the issue seems, ahem, not too urgent...)
shacham
(>histp) makes sure the user stays within the history buffer boundaries,
i.e. -1 to -#HIST, where -#HIST is the oldest command in the history
buffer. The corner case where the buffer is yet to be full is taken
into consideration. In all cases, the user is guided not to walk
past the oldest command in history buffer. Reaching index 0 is
equivalent to clearing the line.
(clrbl) aims to remove user-inserted trailing blanks.
(<hist) uses string-end as limit for do and sring-start as init value,
which is available via i and keeps incrementing, enabling fetching
the present char for 'tap'.
: kTAP Process a non-printable key stroke, CR, backspace et al
Process keys outside the printable range (bl to ~)
Supported control keys processed are: CR, command history,
and line editing.
Unsupported keys are echoed as bl.
CR is preceeded by ^e as the line is cut at cur.
Keys >127 are not reaching here.
: blank Fill in a range with the blank character
: accept Accept characters to input buffer. Return actual count.
Note that unused trailing part of buffer will be blanked
: expect Accept input stream and store count in SPAN
: query Accept input stream to terminal input buffer
Address of a null string with zero count
: abort Reset data stack and jump to QUIT
: $interpret Interpret word. If failed, try to convert it to an integer
: [ Start the text interpreter
: compiling? Tell if in compilation mode
: .ok Display 'ok' only while interpreting
: ?stack Abort if the data stack underflows
Reset return stack, console state
Clean up operand stack and TIB
Begin interpretation
Get and evaluate
Until error...
Save input device (this needs to be deleted... obsolete)
Display error message
Obsolete: in file I/O mode, display special escape char
: ' Search context vocabularies for next word in input stream
: , Compile an integer into the code dictionary
: [compile] Compile the next immediate word into code dictionary
: (compile) Run-time for "compile"
: (genhook) Next word is about to be compiled, provide hook
: compile Compile the next address in colon list to code dictionary
Flag whether to watch tokens coming into the compiler
: $compile Compile next word to code dictionary as a token or literal
: overt Link a new word into the current vocabulary
If "last" is 0, the current compilation is a :noname, so no action needed
: (;) Flag end of high-level def
: ?csp Abort if stack pointer differs from that saved in CSP.
: ; Terminate a colon definition, hook for OO to catch stray ;
Let debugger generate a closing hook; turn off generation suspender
Compile actual exit code, then marker for end of code body
Switch mode back to interpreting, thread defined word into dictionary
Hook for local variables, then verify operand stack
: (:) Create new colon definition using passed string
: : Start a new colon definition using next word as its name
: immediate Make the last compiled word an immediate word
: compile-only Make the last compiled word a compile-only word
: user Compile a new user variable
: (listent) Create a new dictionary entry which executes high-level code
: (create) Build a create-type entry with passed string
: create Build new entry whose runtime action is to push its address
: variable Create new entry with one cell of body, initialized to 0
: (constant) Create constant-type entry with passed name and value
: constant Build new constant
: _type Display string, omitting non-printing chars
: (see) Decompile words starting at the given address
Stop decompiling at end of definition
Try converting to a name
If converted, .id it, otherwise just dump its address
: see Parse word from input, decompile at that address
: words Display names in 1st dictionary in search order
vandys
('endDef) Hook to know when definition target is set
vandys
Size in bytes of memory starting at 1 meg
: hi Display the sign-on message of ForthOS
: init-bootinfo Parse Multiboot info if available, save memory config.
If it isn't available, default to assuming 4 megs of upper memory.
(Note on warm restart we just need to trust the saved value.)
: cold The hilevel cold start sequence
Parse Multiboot input, set up memory config values
Initialize the user area
Init the data stack
Execute boot words
Init TTY I/O and print the startup message
Start interpretation... should not return