stack
/
nforth
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
nforth/nforth.asm

1281 lines
29 KiB
NASM
Raw Permalink Blame History

if 0
==============================================================================
nForth - a minimalist i386 forth
-------------------------------------------------------------------------------
Everything in this repo is subject to this license unless otherwise specified
Copyright 2022 stacksmith
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
1) Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
2) Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
3) Neither the name of the copyright holder nor the names of its contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
end if
LASTHEAD = 0 ;search terminates on 0
include "config.asm"
include "macros.asm"
format ELF executable 3
entry start
segment readable executable writeable
;argc: dd 0
argv: dd 0
start:
mov [argv],esp
; pop eax ;argc
; pop dword[argv] ;argv
; pop dword[argv]
; dec eax ;one argument?
; jz noargs ;then, no arguments
; xor eax,eax
; lea ecx,[eax-1]
; repne scasb
noargs:
;-----------------------------------------------------------------------
; First brk gets the top of allocated memory; second attempts to allot
; more memory.
mov eax,45
xor ebx,ebx
int 0x80
mov [HERE+4],eax ; start of allocated memory
lea ebx,[eax+MEMSIZE] ;
mov eax,45 ; brk
int 0x80 ; eax = top of allocated memory
and eax,$FFFFF000 ; page-align memory top
lea ebp,[eax-4096] ;datastack
lea edx,[ebp-4096] ;tib
mov [TIB+4],edx
DSTACK
push 1
push 2
RSTACK
; xor ebx,ebx
mov ebx,[argv]
mov dword [PARSE.PTR+4],BOOTSTRAP
mov esi,OUTER.cold ; enter OUTER without resetting PARSE.PTR
NEXT
_promptstr: db 10,"OK> "
HEAD bye,$+4
mov eax,1
int 0x80
HEAD osclose,$+4
mov eax,6
int 0x80
NEXT
; kernel calls expect: ;eax ebx ecx edx esi edi
; our system:
;
;
HEAD oscall3,$+4 ;TOS 3 2 1
DSTACK
pop edx
_oscall2: ;TOS 2 1
pop ecx
_oscall1: ;TOS 1
pop eax
xchg eax,ebx ; load eax with TOS, call id
RSTACK
int 0x80
xchg eax,ebx ;return value
NEXT
HEAD oscall2,$+4
DSTACK
jmp _oscall2
HEAD oscall1,$+4
DSTACK
jmp _oscall1
HEAD osopen,docol ;path,flags,mode--res
dd lit,5,oscall3,return
HEAD write,docol ;buffer,count,handle
dd rot ;count,handle,buffer
dd rot ;handle,buffer,count
dd lit,4
dd oscall3
dd return
HEAD read,docol ;buffer,count,handle
dd rot,rot
dd lit,3,oscall3,return
if CFG_TIME
HEAD sys_time,$+4
DSTACK
push ebx
RSTACK
mov eax,13 ;sys_time
push ebx ;return value on stack
mov ebx,esp
int 0x80
pop ebx
NEXT
end if
;; On entry: ebx = base
_number:
;; push esi
;; mov esi,[PARSE.PTR+4]
cmp byte[esi],'$'
jne @f
inc esi
mov ebx,16
@@: DSTACK
push ebx
RSTACK
xor edi,edi
jmp .in
;; process an ASCII digit in al, in a given base; result in ebx
;;
.digit: push edi ;
mov edi,HEXTAB+4
mov ecx,[ebp] ; base
inc ecx
mov ebx,ecx ; ebx = base+1
repne scasb
pop edi
jecxz .err
sub ebx,ecx ; ebx = result + 1!
;; multiply accumulator by base, and add digit (it's +1)
;;
mov eax,edi ;eax = accumulated value
mov edx,[ebp] ;load base into edx
mul edx ;multiply by base
lea edi,[eax+ebx-1] ;add digit+1, accum in edi
;; get an ASCII character and process, unless ws
.in: lodsb
_IS_WS al
jnc .digit
.x:
add ebp,4 ;done with base
mov ebx,edi ;accumulated value
ret
.err: DSTACK
pop ebx ;get rid of base
RSTACK
mov ebx,ERRNUM_PARSE
jmp ERXIT+4
;;=============================================================================
; wsp scan past ws and return character found, or 0 if at end.
HEAD wsp,$+4
DSTACK
push ebx
RSTACK
mov ecx,[PARSE.PTR+4]
dec ecx ; will immediately increment
.loop:
inc ecx
movzx ebx,byte[ecx]
test bl,bl ; 0 means
jz .done ; at end of line, return 0
cmp bl,' ' ; space or anything below
jbe .loop ; is considered ws
.done:
mov [PARSE.PTR+4],ecx
NEXT
;;-----------------------------------------------------------------------------
; reload TIB from HANDLE.IN, up to CR. 0-terminate. On error ERXIT with EOF!
;
HEAD reload,docol
dd TIB,fetch,xdup,PARSE.PTR,xstore ; ptr
dd minus1
.loop:
dd plus1
dd xdup,one,HANDLE.IN,fetch,read
dd zbranch,.readerr
dd xdup,fetchc,lit,10,equal,zbranch,.loop
dd plus1,zero,swap,xstorec
dd return
.readerr:
dd drop,lit,ERRNUM_EOF,ERXIT
;;-----------------------------------------------------------------------------
; prompt - only when input is from STDIN!
HEAD prompt,docol
dd HANDLE.IN,fetch,nzbranch,.done
dd lit, _promptstr,lit,5,type
.done: dd return
;;-----------------------------------------------------------------------------
;; ws - skip whitespaces, reloading as needed. May erxit with EOF!
;;
HEAD ws,docol
.loop:
dd wsp,zbranch,.reload
dd return
.reload:
dd prompt,reload,branch,.loop
;;=============================================================================
; Parsing
;;;----------------------------------------------------------------------------
;;; _search for a hash, from LATEST to first. Return 0 or entry.
;;;
_search: ;(hash--0/zr or --entry/nz)
mov edx,[LATEST+4]
xchg edx,ebx ;ebx = entry; edx = hash
.loop:
cmp [ebx-4],edx ;is entry's hash = needle?
je .done ;found
mov ebx,[ebx-8] ;link
and ebx,ALIGN_MASK ;mask off control bits
jnz .loop
ret
.done:
test ebx,ebx ;0/zr = fail
ret
;;; ----------------------------------------------------------------------------
;;; parse Parse a word in TIB at PARSE.PTR, as a word, and then as a number.
;; word: -- word,1
;; number: -- num,0
;; otherwise, num will force an error.
HEAD parse,$+4
push esi
mov esi,[PARSE.PTR+4]
push esi ; keep around in case of search failure
mov cl,' '
call _FNV1a ; hash it
call _search ; try to find it (NZ=found)
jnz .found
pop esi ; restore parse position
mov ebx,[BASE+4] ; try to find as a number
call _number ; number
DSTACK
push ebx
RSTACK
xor ebx,ebx
jmp .x
.found:
pop eax ; drop ptr to name
DSTACK
push ebx ; --entry,entry ;anything nz will do
RSTACK
.x: mov [PARSE.PTR+4],esi ; update parse position
pop esi
NEXT
;;; ****************************************************************************
;;; ****************************************************************************
;;; ****************************************************************************
;;; ****************************************************************************
;;-------------------------------------------------------------------------------
;; During bootstrapping, TIB points to bootstrap Forth code appended to binary.
;; As we hit CRs, we update TIB to each line start (for error reporting).
;; At the end of the bootstrap (upon hitting a 0), TIB is
;; During normal operation (not initial load), lines are read into TIB
;;
HEAD parsereset,$+4 ;"
mov edx,[TIB+4]
mov [PARSE.PTR+4],edx ;reset parse ptr
mov byte[edx],0
NEXT
HEAD emit,docol
dd XDSP ;push char, load pointer
dd one ;length
dd HANDLE.OUT,fetch ;stdout (1)
dd write,drop,drop
dd return
;;; buf,cnt
HEAD type,docol
dd HANDLE.OUT,fetch,write,drop,return
HEADN comment,"\",$+4,1 ;"
push esi
mov esi,[PARSE.PTR+4]
@@: lodsb
test al,al
jz skipword.x
cmp al,10
jne @b
jmp skipword.x
HEAD skipword,$+4
push esi
mov esi,[PARSE.PTR+4]
@@: lodsb
_IS_WS al
jnc @b
.x: dec esi
mov [PARSE.PTR+4],esi
pop esi
NEXT
; eax=scan,mulresult
;
; ecx=temp,cnt
; edx
; esi=string
; edi=accum
; ebp=dsp
; [ebp+4]=base
; [ebp]=accum
;;; ----------------------------------------------------------------------------
;;; Hash a string at esi, advancing esi until WS. Hash returned in TOS.
;;; also, exits when cl is matched!
_FNV1a: ;from esi
DSTACK
push ebx
RSTACK
mov ebx,FNV_OFFSET_BASIS
jmp .in
.loop:
inc esi
xor eax,ebx ;eax = char xor hash
mov edx,FNV_PRIME
mul edx ;eax = (char xor hash) * FNV_PRIME
mov ebx,eax
.in:
movzx eax,byte[esi] ;eax = char
cmp al,cl
je .out
_IS_WS al ;set C if WS
jnc .loop
.out:
ret
HEADN XHASH,"HASH",$+4
push esi
mov cl,' '
mov esi,[PARSE.PTR+4]
call _FNV1a
pop esi
NEXT
;
;;-----------------------------------------------------------------------------
;; Hash an environment variable, updating the variable to 0-terminated value
;; (ptr--ptr,hash)
HEADN ENVHASH,"ENVHASH",$+4
push esi
mov cl,'='
mov esi,ebx
call _FNV1a
inc esi
mov [ebp],esi ;save updated ptr
pop esi
NEXT
HEAD strlen,$+4 ; (str--str,len)
DSTACK
push ebx
RSTACK
mov edi,ebx ;starting from string start
mov ecx,-1 ;infinite count
xor eax,eax ;seek 0
repne scasb
neg ecx
lea ebx,[ecx-2] ;negation, starting at -1, 0-term
NEXT
docol:
push esi ;stack instruction pointer
lea esi,[eax+4]
NEXT
HEADN docolcomma,"docol,",docol
dd lit,docol,comma,return
dovar:
DSTACK
push ebx
RSTACK
lea ebx,[eax+4]
NEXT
HEADN dovarcomma,"dovar,",docol
dd lit,dovar,comma,return
;;; Numeric parsing, output
HEAD HEXTAB,dovar
db "0123456789ABCDEF"
;;;
;;; Stack digits, and return count in TOS.
;;; (num--...digits,cnt)
HEAD output,$+4
mov ecx,[BASE+4] ;ecx = BASE
xchg eax,ebx ;eax = number
xor ebx,ebx ;ebx = digit counter
DSTACK
.loop:
xor edx,edx
div ecx
push edx ;push digit
inc ebx ;count it
test eax,eax
jnz .loop
RSTACK
NEXT
HEADN dot,".",docol
dd output,dotprim,return
HEAD dotprim,docol
dd xpush
@@: dd HEXTAB,plus,fetchc,emit
dd dbra,@b
dd return
HEAD LATEST,dovar
dd FINALHEAD
HEAD HANDLE.IN,dovar
dd 0
HEAD HANDLE.OUT,dovar
dd 1
;HEAD MEM.START,dovar
dd 0
HEAD STATE,dovar
dd 0 ; dictionary pointer
dd 0 ; head pointer
dd 0 ; runptr
HEAD HERE,dovar
dd 0
;HEAD MEM.END,dovar
; dd 0
;HEAD MEM.ORIG,dovar
; dd 0
HEAD ERR.FRAME,dovar
dd 0
HEAD TIB,dovar
dd 0
HEAD PARSE.PTR,dovar
dd 0
HEAD FIXUP.IF,dovar
dd 0
HEAD BASE,dovar
dd 10
HEAD RUNPTR,dovar
dd 0
HEADN HEREfetch,"HERE@",docol
dd HERE,fetch,return
;-----------------------------------------------------------------------------
; We maintain a safe STATE. At any point we are happy with the state
; of the dictionary, we can call sync to commit STATE to current state.
; In case of an error, we can rollback to the previous known-good state.
;
HEAD state.commit,$+4
; dd STATE
; dd HERE,fetch,xover,xstore
; dd LATEST,fetch,swap, lit,4,plus,xstore
; dd return
mov eax,[HERE+4]
mov [STATE+4],eax ;HERE
mov eax,[RUNPTR+4]
mov [STATE+12],eax
mov eax,[LATEST+4]
mov [STATE+8],eax
NEXT
HEAD state.rollback,$+4
mov eax,[STATE+4]
mov [HERE+4],eax
mov eax,[STATE+8]
mov [LATEST+4],eax
mov eax,[STATE+12]
mov [RUNPTR+4],eax
NEXT
HEAD state.push, $+4
push dword[STATE+4]
push dword[STATE+8]
NEXT
HEAD state.pop,$+4
pop dword[STATE+8]
pop dword[STATE+4]
NEXT
HEAD sync,docol,1
dd state.commit,return
HEAD abort,docol,1
dd state.rollback,return
if CFG_TIME
HEAD TIMEZONE,dovar
dd -14400
end if
HEAD cr,docol
dd lit
dd $A
dd emit
dd return
;-----------------------------------------------------------------------------
; 2x ..definition.. Evaluate the code block that follows twice
HEADN twox,"2x",$+4
add esi,8 ;skip the 8-byte header, to execute the next definition
push esi
NEXT
HEAD sp2,docol
dd twox
HEADN space,"sp",docol
dd lit,$20,emit,return
HEADN spaces,"sps",docol
dd xdup,zbranch,.x
dd xpush
@@: dd space
dd dbra,@b
dd return;
.x: dd drop,return
HEAD INTERP,docol
.loop:
dd HEREfetch,RUNPTR,xstore ; save HERE to run later
dd COMPILE ; compile a single unit
dd lit,return,comma ; compile a return
dd RUNPTR,fetch,xdup,HERE,xstore,eval ; restore HERE, then run
dd branch,.loop
;;;===========================================================================
; OUTER interpreter
;
; Note: initially we enter .cold without parsereset, with PARSE.PTR at code
; appended to this file, for secondary boot.
;
HEAD OUTER,docol
.in:
dd parsereset ; abort source in TIB (
.cold:
dd state.commit ; initially, commit point.
dd ERR.CATCH,xdup,nzbranch,.err ; we catch errors
dd drop ; 0 means no error
.loop:
dd INTERP
.err:
dd xdup,lit,ERRNUM_EOF,minus,zbranch,.eof ; handle EOF
dd TIB,fetch,strlen,type ; print the error line
dd PARSE.PTR,fetch,TIB,fetch,minus ; compute offset in line
dd cr,spaces,lit,'^',emit ; show wherehe
dd state.rollback ; abort to checkpoint
dd branch, .in
.eof:
dd drop,zero,HANDLE.IN,xstore ; force STDIN
dd branch, .in ; not really an error
;;; on entry, esp has 2 return addresses.
HEAD _sysp, $+4
DSTACK ; |
push ebx ;1,2,3, 3
push dword[esp+8] ;1,2,3,1, 3
push dword[esp+8] ;1,2,3,1,2, 3
RSTACK
NEXT
HEADN XDSP,"DSP",$+4
DSTACK
push ebx ;value to stack
RSTACK
mov ebx,ebp ;load pointer to value
NEXT
HEADN XRSP,"RSP",$+4
DSTACK
push ebx ;value to stack
RSTACK
mov ebx,esp
NEXT
if CFG_DEBUG
HEAD sys,docol
dd _strlit
mstring <"DSP",9," RSP",9," HERE",9," SRC">
dd type,cr
dd XDSP,hexd,space,XRSP,hexd,space
dd HEREfetch,hexd,space
dd PARSE.PTR,fetch,hexd,cr
dd _sysp
dd hexd,space,hexd,space,hexd,cr
dd return
end if
HEAD dbra,$+4
dec dword[esp] ;decrement counter
jz .done
.continue:
mov esi,[esi] ;go there
NEXT
.done:
add esp,4 ;drop 0 count
add esi,4 ;skip loop target
NEXT
;; (char--char)
HEAD printable,$+4
xor eax,eax
mov al,$7E
cmp bl,20
cmovc ebx,eax
cmp bl,$7F
cmovnc ebx,eax
NEXT
;;; ------------------------------------------------------------------------------
;;; ERROR HANDLING
;;; ERR.CATCH (--0/zr) or (--errno/nz)
HEAD ERR.CATCH,$+4
DSTACK
push ebx
RSTACK
push esi ;save IP just after catch
push dword[ERR.FRAME] ;save old frame
mov [ERR.FRAME],esp ;establish new frame
xor ebx,ebx ;return 0
NEXT
HEAD ERR.CLR,$+4
mov esp,[ERR.FRAME] ;restore stack to frame
pop dword[ERR.FRAME] ;restore previous frame
pop edx ;drop unused IP
NEXT
; ERXIT, (id--) non-zero ID.
HEAD ERXIT,$+4
mov esp,[ERR.FRAME] ;restore stack to frame
pop dword[ERR.FRAME] ;restore previous frame
pop esi ;restore IP
NEXT
HEAD gettype,$+4 ;entry--type
movzx ebx,word[ebx-8]
and ebx,ALIGN_NONCE
NEXT
;;-------------------------------------------------------------------
;; ' [srcword]
;; Parse the input stream and find the word.
;; Compile: <lit><word>
;; If srcword is a number, the number, compile lit.
HEADN TICK,"'",docol,1 ;IMMEDIATE (parses!)
dd ws,parse
dd zbranch,.err
dd lit,lit,comma ;compile <lit>
dd comma ;compile parsed value
dd return
.err:
dd lit,ERRNUM_PARSE
dd ERXIT
HEAD COMPILE.ONE,docol
dd parse ;don't forget to WS prior to this
dd zbranch,.number
.word:
dd xdup, gettype
dd zbranch,.proc
;;; Immediate word; execute now
.self: dd execute,return
;;; If a procedure, simply compile its token
.proc: dd comma,return
;;; Number? Compile <lit><number>
.number:
;dd sys
dd lit,lit,comma ;compile <LIT>
dd comma ;compile <number>
dd return
HEAD COMPILE,docol
dd ws,COMPILE.ONE
dd return
HEAD COMPILE.UNTIL,docol ;delim
dd branch,.in
.ne: dd COMPILE.ONE ;todo: fix redundant hashing
.in: dd ws
dd xdup,XHASH,equal ;is current hash = delim?
dd zbranch,.ne
dd drop,skipword ;delimiter skipped
dd return
;; Hashes for closing braces of all sorts
;;
hCBRACE = $D80C1648
hCPAREN = $2C0C9A84
hCCURLY = $F80C48A8
;; ( paren is a grouping operator; compiled expression
HEADN OPAREN,"(",docol,1 ;immediate!
dd lit,hCPAREN,COMPILE.UNTIL,return
;; { is a compiling operator (suppresses execution)
HEADN OCURLY,"{",docol,1 ;immediate!
dd lit,hCCURLY,COMPILE.UNTIL ; compile some code
dd HEREfetch,RUNPTR,xstore ; assure non-interpretation
dd return
;; Create a header with specified name hash
;; (hash--)
HEAD CREATE,docol
dd LATEST,fetch,comma ; backlink
dd comma ; hash
dd HEREfetch,LATEST,xstore ; update link chain
dd return
HEADN colon,":",docol,1
dd ws,XHASH,skipword ; hash from source
dd CREATE
dd lit,docol,comma
dd HEREfetch,RUNPTR,xstore ; compile, do not interp
dd return
HEADN XIMMEDIATE,"IMMEDIATE",$+4,1
mov eax, [LATEST+4]
or dword[eax-8],1
NEXT
; lit - ( -- num) push the value in the cell straight after lit.
;;-------------------------------------------------------------------
;; When executed, load the next slot as a literal into TOS
;;
HEADN lit,"lit",$+4
lodsd ;load next token
.load:
DSTACK
.dload:
push ebx
RSTACK
xchg eax,ebx ; into TOS
NEXT
;;; string ( -- str cnt)
HEADN zero,"zero",$+4
xor eax,eax
jmp lit.load
HEADN one,"one",$+4
mov eax,1
jmp lit.load
; rot - ( x y z -- y z x )
HEAD rot,$+4
DSTACK
pop edx
pop eax
push edx
jmp lit.dload
; # swap - ( x y -- y x ) exchange x and y
HEAD swap,$+4
DSTACK
pop eax
jmp lit.dload
HEAD hexb,$+4
shl ebx,24
mov ecx,2
jmp hexloop
HEAD hexw,$+4
shl ebx,16
mov ecx,4
jmp hexloop
HEAD hexd,$+4
mov ecx,8
hexloop:
rol ebx,4
pusha
mov eax,4
and ebx,$0000000F ;nybble
lea ecx,[4+HEXTAB+ebx] ;address of character
mov ebx,1 ;stdout
mov edx,ebx ;length 1
int 0x80
popa
loop hexloop
jmp drop.popret
;;============================================================================
;; Lambdas are unexecuted blocks of code, passed by address:
;; 0 4
;; <lambda><addr-after-lambda>....
HEAD lambdaop,$+4
DSTACK
push ebx
RSTACK
lodsd ; eax = post-lambda
mov ebx,esi ; ebx = start of lambda
xchg esi,eax ; adjust IP past lambda
NEXT
; (lambda--) evaluate a lambda and continue
HEAD eval,$+4
push esi
mov esi,ebx
jmp drop.popret
; , - ( x -- ) compile x to the current definition.
; Stores the number on the stack to the memory location currently
; pointed to by dp.
HEADN comma,",",$+4
mov edi,[HERE+4]
xchg eax,ebx
stosd
mov [HERE+4],edi
jmp drop.popret
; drop - ( x -- ) remove x from the stack.
HEAD drop,$+4
.popret:
DSTACK
pop ebx
RSTACK
NEXT
; dup - ( x -- x x ) add a copy of x to the stack
HEADN xdup,"dup",$+4
DSTACK
push ebx
RSTACK
NEXT
; -------------------
; Flow Control
; -------------------
; 0branch - ( x -- ) jump if x is zero
HEADN zbranch,"0branch",$+4
lodsd ;eax = address to maybe jump to
test ebx,ebx ;zr?
cmovz esi,eax
@@: jmp drop.popret
HEADN nzbranch,"nzbranch",$+4
lodsd ;eax = address to maybe jump to
test ebx,ebx ;zr?
cmovnz esi,eax
jmp drop.popret
; branch - ( -- ) unconditional jump
HEADN branch,"branch",$+4
mov esi,[esi]
NEXT
HEADN xpush,"push",$+4
push ebx
jmp drop.popret
HEADN xpop,"pop",$+4
DSTACK
push ebx
RSTACK
pop ebx
NEXT
; ( ..n -- nth) 0 nth = dup; 1 nth = over; etc.
HEAD nth,$+4
mov ebx,[ebp + ebx*4]
NEXT
HEADN xover,"over",$+4
DSTACK
push ebx
RSTACK
mov ebx,[ebp+4]
NEXT
; -------------------
; Maths / Logic
; -------------------
; + - ( x y -- z) calculate z=x+y then return z
HEADN plus,"+",$+4
DSTACK
pop eax
RSTACK
add ebx,eax
NEXT
; + - ( x y -- z) calculate z=x-y then return z
HEADN minus,"-",$+4
DSTACK
pop eax
RSTACK
sub eax,ebx
xchg eax,ebx
NEXT
HEADN shiftlt,"<<",$+4
mov ecx,ebx
DSTACK
pop ebx
RSTACK
shl ebx,cl
NEXT
HEADN is_negative,"neg?",$+4
DSTACK
push ebx
RSTACK
shl ebx,1
jmp equal.sbb
; = ( x y -- flag ) return true if x=y
HEADN equal,"=",$+4
DSTACK
pop eax ; if = if !=
sub ebx,eax ; 0, ZR !0, NZ
RSTACK
sub ebx,1 ;-1, C ?, NC
.sbb:
sbb ebx,ebx ; -1 0
NEXT
; < ( x y -- flag ) return true if x < y
HEADN less,"<",$+4
DSTACK
pop eax ;eax = x
RSTACK
cmp eax,ebx ;c, want true
setge al
movzx ebx,al
sub ebx,1
NEXT
HEADN minus1,"1-",$+4
dec ebx
NEXT
HEADN plus1,"1+",$+4
inc ebx
NEXT
; (val,addr--)
HEADN plusstore,"+!",$+4
DSTACK
pop eax
add [ebx],eax
pop ebx
RSTACK
NEXT
HEADN minusstore,"-!",$+4
DSTACK
pop eax
sub [ebx],eax
pop ebx
RSTACK
NEXT
;; a,b -- rem,res
HEADN smod,"/MOD",$+4
mov eax,[ebp]
xor edx,edx
idiv ebx
jmp ummod.1
;;; a,b --- rem,res
HEADN ummod,"UM/MOD",$+4
mov eax,[ebp] ;dividing this
xor edx,edx
div ebx ;by tos
.1: xchg eax,ebx ;tos is result
mov [ebp],edx ;remainder above
NEXT
;; (a,b -- a*b)
HEADN umul,"*",$+4
xchg eax,ebx
xor edx,edx
mul dword[ebp]
add ebp,4
xchg eax,ebx
NEXT
; -------------------
; Peek and Poke
; -------------------
; @ - ( addr -- x ) read x from addr
HEADN fetch,"@",$+4
mov ebx,[ebx]
NEXT
HEADN fetchc,"@c",$+4
movzx ebx,byte[ebx]
NEXT
HEADN fetchw,"@w",$+4
movzx ebx,word[ebx]
NEXT
; ! - ( x addr -- ) store x at addr
HEADN xstore,"!",$+4
DSTACK
pop dword[ebx]
.1: pop ebx
RSTACK
NEXT
HEADN xstorec,"!c",$+4
DSTACK
pop eax
mov [ebx],al
jmp xstore.1
HEADN xstorew,"!w",$+4
DSTACK
pop eax
mov [ebx],ax
jmp xstore.1
; execute - ( xt -- ) call the word's xt
HEAD execute,$+4
mov eax,ebx
DSTACK
pop ebx
RSTACK
jmp dword[eax]
if CFG_DEBUG
HEAD dumpbyte,docol
dd xdup,fetch,hexb,space,plus1,return
HEAD dumpascii,docol
dd xdup,fetch,printable,emit,plus1,return
HEAD dump16,docol ;addr
dd xdup,hexd,space,space
dd lit,16,xpush ;16 times
@@: dd dumpbyte
dd dbra,@b
dd space
dd lit,16,minus
dd lit,16,xpush ;16 times
@@: dd dumpascii
dd dbra,@b
dd cr,return
HEAD hd,docol
dd dump16,dump16,dump16,dump16,return
end if
HEADN return,";",$+4
pop esi
NEXT
;;; ============================================================================
;;; Strings (short) are stored as:
;;; <_strlit><bytesize><string...>..aligned
;;;
HEAD _strlit,$+4
lodsb ;load string size (byte)
DSTACK
push ebx
push esi ;
RSTACK
movzx ebx,al ;TOS = cnt
lea esi,[esi+ebx+1+1] ;bump IP, aligning. +1 for the 0-term
and esi,ALIGN_MASK;
NEXT
;;; primitive to copy string from source into dictionary, preceded by its byte
;;; size. Line boundary may not be crossed!
ANON _getstr,$+4
push esi
mov esi,[PARSE.PTR+4]
mov edi,[HERE+4]
mov edx,edi ;edx points at count byte
xor ecx,ecx
lodsb ;skip past space following "
.loop:
inc ecx
stosb
lodsb
test al,al
je .err
cmp al,'"' ;"
jne .loop
xor eax,eax
stosb ;null-term
dec ecx ;-1 for the byte count itself.
mov [edx],cl ;byte count, update
add edi,ALIGN_NONCE
and edi,ALIGN_MASK ;align
mov [HERE+4],edi
mov [PARSE.PTR+4],esi ;just past "
pop esi
NEXT
.err:
DSTACK
push ebx
RSTACK
mov ebx,ERRNUM_RANGE
jmp ERXIT+4
;;; " string" At compile time, compile the string that follows.
;;; at runtime, (--string,size)
HEADN stringlit,'"',docol,1 ;"
dd lit,_strlit,comma ; compile <_strlit>
dd _getstr ; copy string
dd return
;;; ." msg" At compile time, compile string followed by <type>
;;; At runtime, print the message.
HEADN prstringlit,'."',docol,1 ;"
dd stringlit
dd lit,type,comma
dd return
if 0
;;; --------------------------------------------------------------------
;;; CONTROL STRUCTURES
;;; compile: <push>|... <timesp><loopstart>
HEADN xtimes,"times",docol,1 ;(n-- n times (...)
dd lit,xpush,comma ;compile <push>. During compile,
dd HEREfetch,xpush ;save target address on RSP
dd ws,COMPILE.ONE ;compile expression
dd lit,dbra,comma ;complile <decibranz>
dd xpop,comma ;compile target
dd return
hthanx = $07596E46
HEADN xif,"if",docol,1
dd FIXUP.IF,fetch,xpush ;reentrant: push old IF
dd lit,zbranch,comma ;compile <zbranch>
dd HEREfetch,FIXUP.IF,xstore ;this is the fixup position
dd zero,comma
dd lit,hthanx,COMPILE.UNTIL ;compile to thanx
dd HEREfetch,FIXUP.IF,fetch,xstore ;fixup to here, past thanx
dd xpop,FIXUP.IF,xstore ;restore for reentrant if
dd return
HEADN xelse,"else",docol,1
dd FIXUP.IF,fetch,zbranch,.err
dd lit,branch,comma ;complie <branch> over else clause
dd HEREfetch,zero,comma ;keep next fixup position
dd HEREfetch,FIXUP.IF,fetch,xstore ;fixup if's target
dd FIXUP.IF,xstore ;and save else's fixup
dd return
.err: dd lit,$99,ERXIT
end if
if 1
;;; Loader
;;;
;;;(handle--) Load a forth file from an open file handle
HEADN xloadh,"loadh",docol
dd HANDLE.IN, fetch, xpush ; keep old input handle on stack
dd HANDLE.IN, xstore ; use provided handle
dd ERR.CATCH,xdup,nzbranch,.err
dd drop,parsereset ; will force a line load
dd INTERP ; no way out except EOF
.err:
dd HANDLE.IN,fetch,osclose,drop
dd xpop,HANDLE.IN,xstore
dd lit,ERRNUM_EOF,xover,equal,nzbranch,.err1
dd ERXIT
.err1:
dd drop,parsereset
dd return
end if
if 0
;;HEADN included,"included;",docol
;; dd uncompile
;; dd xloadh
;; dd xpop,drop ;return up
;; dd return
HEADN included,"included",docol
dd drop
dd xpush,zero,zero,xpop ;0,0,path
dd osopen
dd xloadh
dd return
;;;(name,namelen--)
HEADN included_ret,"included;",docol
dd drop
dd xpush,zero,zero,xpop ; --0,0,path
dd osopen
dd uncompile
dd xloadh
dd xpop,drop
dd return ; --handle or error..
end if
FINALHEAD = LASTHEAD
BOOTSTRAP: file "nforth.f"
db 0
Reference in New Issue View Git Blame Copy Permalink