aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJustin Bedo <cu@cua0.org>2012-11-19 10:11:44 +1100
committerJustin Bedo <cu@cua0.org>2012-11-19 10:11:44 +1100
commit1b30051ee29fbf6a0ddf989a1faac2481d601bd9 (patch)
tree58d2298c95afd282cbca1b15eb469c53e6b778d9
Import of untracked forth codebase.HEADmaster
-rw-r--r--README3
-rwxr-xr-xbuild3
-rw-r--r--forth.f110
-rw-r--r--forth.s1712
4 files changed, 1828 insertions, 0 deletions
diff --git a/README b/README
new file mode 100644
index 0000000..26bd541
--- /dev/null
+++ b/README
@@ -0,0 +1,3 @@
+This is a Forth interpreter for Linux written in ASM. It uses
+call-based threading and optimises small ASM primitives by inlining to
+avoid the call.
diff --git a/build b/build
new file mode 100755
index 0000000..1c4d419
--- /dev/null
+++ b/build
@@ -0,0 +1,3 @@
+#!/bin/bash
+nasm -f elf forth.s
+ld -melf_i386 forth.o
diff --git a/forth.f b/forth.f
new file mode 100644
index 0000000..e8e8044
--- /dev/null
+++ b/forth.f
@@ -0,0 +1,110 @@
+: -+ - + ;
+: / /mod nip ;
+: if immediate ' 0branch ,, here 0 , ;
+: then immediate ] here swap ! ;
+
+: find-) key 41 != if find-) ; then ;
+: ( immediate find-) ;
+( now there's parenthetical comments :)
+
+: find-cr key 10 != if find-cr ; then ;
+: \ immediate find-cr ;
+\ and now line comments
+
+: '@ @ ; \ A tickable @
+: variable here 0 , word create ' lit ,, , exit ;
+: constant here swap , word create ' lit ,, , ' '@ ,, exit ;
+: array word create ' lit ,, here 0 , exit here swap ! ;
+
+\ Some stuff for printing/compiling number strings
+: cr 10 emit ;
+: space 32 emit ;
+: tab 9 emit ;
+
+\ strings
+: read-until-" key dup 34 = if 2drop ; then
+ c, 1 over +! read-until-" ;
+: read-str
+ ' lit ,, here 0 , \ ptr
+ ' lit ,, here 0 , \ cnt
+ ' branch ,, here 0 , \ branch
+ rot here swap ! \ ptr set
+ swap
+ read-until-"
+ 0 c, \ Null terminate strings for syscalls
+ here swap !
+;
+: s" immediate read-str ;
+: print dup 0<= if 2drop ; then
+ 1- swap dup c@ emit 1+ swap print ;
+: ." immediate
+ read-str
+ ' print ,,
+;
+
+\ Exit back to linux
+: bye 0 1 syscall1 ;
+: fatal 1 1 syscall1 ;
+
+\ File IO
+0 constant OREAD
+1 constant OWRITE
+2 constant ORW
+100 constant OCREATE
+1 constant PROT_READ
+2 constant PROT_WRITE
+1 constant MAP_SHARED
+variable zero 0 zero !
+: ?error -1 = if ." file syscall error" cr fatal ; then ;
+: write 4 syscall3 dup ?error ;
+: _open 5 syscall3 dup ?error ;
+: close 6 syscall1 ?error ;
+: lseek 19 syscall3 dup ?error ;
+: truncate 92 syscall2 ?error 42 emit ;
+: open nip 0 _open ;
+: screate nip OCREATE or 420 _open ;
+: rswap <r <r swap >r >r ;
+: mmap ( path -- ptr )
+ ORW open dup dup >r fsize dup <r swap >r >r 0 swap
+ PROT_READ PROT_WRITE or MAP_SHARED <r 0 192 syscall6 dup ?error
+ swap close <r ;
+: mmap-screate ( path len -- ptr ) ( fl )
+ >r ORW screate <r
+ 2dup 1- 0 lseek drop over zero 1 write drop
+ swap dup >r >r 0 swap
+ PROT_READ PROT_WRITE or MAP_SHARED <r 0 192 syscall6 dup ?error
+ <r close ;
+
+\ String tokeniser
+variable cur
+variable len
+variable end
+array buffer 50 allot
+: ?end end @ >= ;
+: ?sep 33 < ;
+: cnt-word ( cnt ptr -- cnt )
+ dup ?end if drop ; then
+ dup c@ ?sep if drop ; then
+ swap 1+ swap 1+ cnt-word ;
+: find-first-char ( ptr -- ptr )
+ dup ?end 0= if
+ dup c@ ?sep if 1+ find-first-char ; then
+ then ;
+: tokenise ( ptr len -- ) over + end ! cur ! 0 len ! ;
+: token ( -- ptr len ) cur @ len @ + find-first-char dup cur !
+ 0 over cnt-word dup len ! ;
+
+\ log math
+: lsqrt 0.5 lpow ;
+: sq dup l* ;
+
+
+\ High level operators
+variable map-fun
+variable map-stat
+: do-map dup 0<= if drop ; then
+ 1- @+ map-fun @ execute !+ do-map ;
+: map ( pnf -- ) map-fun ! swap dup >a >b do-map ;
+: do-sweep dup 0<= if drop ; then
+ @+ map-stat @ map-fun @ execute !+ 1- do-sweep ;
+: sweep ( pnsf -- ) map-fun ! map-stat ! swap dup >a >b do-sweep ;
diff --git a/forth.s b/forth.s
new file mode 100644
index 0000000..8566a9c
--- /dev/null
+++ b/forth.s
@@ -0,0 +1,1712 @@
+[bits 32]
+; /usr/include/asm/unistd.h
+
+%macro pushs 1 ; Pushes something onto the stack
+ lea ebp, [ebp - 4]
+ mov dword [ebp], %1
+%endmacro
+
+%macro pops 1 ; Pops something from the stack
+ mov dword %1, [ebp]
+ lea ebp, [ebp + 4]
+%endmacro
+
+ %define link 0
+ F_IMMED equ 0x80
+ F_LENMASK equ 0x1f
+ F_INLINE equ 0x40
+
+%macro defcode 4 ; name, namelen, flags, label
+ section .rodata
+ align 4
+ global name_%4
+name_%4:
+ dd link
+ %define link name_%4
+ db %2+%3
+ db %1
+ align 4
+ global %4
+%4:
+%endmacro
+
+%macro defvar 5 ; name, namelen, flags, label, initial
+ defcode %1, %2, %3, %4
+ pushs eax
+ mov eax, [var_%4]
+ ret
+ section .data
+ align 4
+var_%4:
+ dd %5
+%endmacro
+
+%macro defconst 5 ; name, namelen, flags, label, value
+ defcode %1, %2, %3, %4
+ pushs %5
+ ret
+%endmacro
+
+section .text
+
+global _start
+
+_start:
+ cld
+ mov ebp, stack_top
+ mov [var_rz],esp
+ finit
+ fldcw [rnd_near]
+ call alloc_dict
+ call quit
+
+ section .data
+rnd_trunc:
+ dw 0xfff
+rnd_near:
+ dw 0x3ff
+rnd_ceil:
+ dw 0xbff
+rnd_floor:
+ dw 0x7ff
+
+defcode 'lit', 3, 0, lit
+ pushs eax
+ mov ebx, [esp]
+ mov eax, [ebx]
+ add ebx, 4
+ mov [esp], ebx
+ ret
+
+defcode 'drop', 4, F_INLINE, drop
+ pops eax
+ ret
+
+defcode 'swap', 4, F_INLINE, swap
+ pops ebx
+ pushs eax
+ mov eax, ebx
+ ret
+
+defcode 'dup', 3, F_INLINE, dup
+ pushs eax
+ ret
+
+defcode '2drop', 5, F_INLINE, twodrop
+ mov eax, [ebp + 4]
+ lea ebp, [ebp + 8]
+ ret
+
+defcode 'over', 4, F_INLINE, over
+ mov ebx,[ebp]
+ pushs eax
+ mov eax, ebx
+ ret
+
+defcode '2dup', 4, F_INLINE, twodup
+ mov ebx,[ebp]
+ pushs eax
+ mov eax, ebx
+ mov ebx,[ebp]
+ pushs eax
+ mov eax, ebx
+ ret
+
+defcode 'nip', 3, F_INLINE, nip
+ pops ebx
+ ret
+
+defcode 'rot', 3, F_INLINE, rot
+ pops ebx
+ pops ecx
+ pushs ebx
+ pushs eax
+ mov eax,ecx
+ ret
+
+defcode '-rot', 4, F_INLINE, irot
+ pops ebx
+ pops ecx
+ pushs eax
+ pushs ecx
+ mov eax, ebx
+ ret
+
+defcode '+', 1, F_INLINE, plus
+ pops ebx
+ add eax,ebx
+ ret
+
+defcode '-', 1, F_INLINE, minus
+ neg eax
+ ret
+
+defcode '+-', 2, F_INLINE, plusminus
+ pops ebx
+ sub eax, ebx
+ ret
+
+defcode 'not', 3, F_INLINE, lnot
+ not eax
+ ret
+
+defcode '1+', 2, F_INLINE, add1
+ inc eax
+ ret
+
+defcode '1-', 2, F_INLINE, sub1
+ dec eax
+ ret
+
+defcode 'under1+', 7, F_INLINE, underadd1
+ pops ebx
+ inc ebx
+ pushs ebx
+ ret
+
+defcode 'under1-', 7, F_INLINE, undersub1
+ pops ebx
+ dec ebx
+ pushs ebx
+ ret
+
+defcode '4+', 2, F_INLINE, add4
+ add eax, 4
+ ret
+
+defcode '4-', 2, F_INLINE, sub4
+ sub eax, 4
+ ret
+
+defcode 'under4+', 7, F_INLINE, underadd4
+ pops ebx
+ sub ebx, -4
+ pushs ebx
+ ret
+
+defcode 'under4-', 7, F_INLINE, undersub4
+ pops ebx
+ sub ebx, 4
+ pushs ebx
+ ret
+
+defcode '4*', 2, F_INLINE, mul4
+ sal eax, 2
+ ret
+
+defcode '4/', 2, F_INLINE, div4
+ sar eax, 2
+ ret
+
+defcode '*', 1, F_INLINE, mult
+ pops ebx
+ imul dword ebx
+ ret
+
+defcode '*/', 2, F_INLINE, divmul
+ mov ecx, eax
+ pops ebx
+ pops eax
+ imul dword ebx
+ xor edx, edx
+ idiv ecx
+ ret
+
+defcode '/mod', 4, 0, divmod
+ mov ebx, eax
+ pops eax
+ xor edx, edx
+ idiv dword ebx
+ pushs edx
+ ret
+
+defcode 'abs', 3, F_INLINE, iabs
+ cmp eax, 0
+ jge abs_pos
+ neg eax
+abs_pos:
+ ret
+
+ ; Morton dilations
+defcode 'undilate', 8, 0, dilate
+ mov ebx, eax
+ sar ebx, 1
+ or eax, ebx
+ and eax, 0x33333333
+
+ mov ebx, eax
+ sar ebx, 2
+ or eax, ebx
+ and eax, 0x0f0f0f0f
+
+ mov ebx, eax
+ sar ebx, 4
+ or eax, ebx
+ and eax, 0x00ff00ff
+
+ mov ebx, eax
+ sar ebx, 8
+ or eax, ebx
+ and eax, 0x0000ffff
+ ret
+
+defcode 'dilate', 6, 0, undilate
+ mov ebx, eax
+ sal ebx, 8
+ or eax, ebx
+ and eax, 0x00ff00ff
+
+ mov ebx, eax
+ sal ebx, 4
+ or eax, ebx
+ and eax, 0x0f0f0f0f
+
+ mov ebx, eax
+ sal ebx, 2
+ or eax, ebx
+ and eax, 0x33333333
+
+ mov ebx, eax
+ sal ebx, 1
+ or eax, ebx
+ and eax, 0x55555555
+ ret
+
+ ; Prints out a number
+defcode '.', 1, 0, dot
+ push esi
+ push edi
+ mov ebx, eax
+ test ebx, ebx
+ jg dot_pos
+ je dot_zero
+ neg ebx
+ pushs eax
+ mov eax, 45
+ push ebx
+ call emit
+ pop ebx
+dot_pos:
+ ; Calculate number of digits (log10 effectivly)
+ ; Uses some bit hacks
+ bsr ecx, ebx
+ inc ecx
+ imul ecx, 1233
+ sar ecx, 12
+ inc ecx
+ mov eax, [log10 + ecx * 4]
+ cmp ebx, eax
+ jge dot_pdigs
+ dec ecx
+dot_pdigs:
+ mov eax, ebx
+ xor edx,edx
+ mov ebx, 10
+ push ecx
+dot_split:
+ xor edx, edx
+ idiv ebx
+ add edx, 48
+ pushs edx
+ loop dot_split
+ pop ecx
+ pops eax
+dot_emit:
+ push ecx
+ call emit
+ pop ecx
+ loop dot_emit
+ pop edi
+ pop esi
+ ret
+dot_zero:
+ mov eax, 48
+ pop edi
+ pop esi
+ jmp emit
+
+log10:
+ dd 0
+ dd 1
+ dd 10
+ dd 100
+ dd 1000
+ dd 10000
+ dd 100000
+ dd 1000000
+ dd 10000000
+ dd 100000000
+
+ ; Converts to logrep from string
+ ; Implements a little FSM
+defcode 'lnumber', 7, 0, lnumber
+ push esi
+ push edi
+ pops esi
+ pushs eax
+ mov ecx, eax
+ xor eax, eax
+ xor ebx, ebx
+ xor edi, edi
+
+lnumber_whole:
+ test ecx, ecx
+ jz lnumber_whole_terminate
+ lodsb
+ dec ecx
+ cmp al, '+'
+ je lnumber_whole
+ cmp al, '-'
+ je lnumber_whole_neg
+ cmp al, '.'
+ je lnumber_whole_frac
+ cmp al, 'e'
+ je lnumber_whole_exp
+ cmp al, 'E'
+ je lnumber_whole_exp
+ imul ebx, 10
+ sub al, '0'
+ add ebx, eax
+ jmp lnumber_whole
+lnumber_whole_neg:
+ inc edi
+ jmp lnumber_whole
+lnumber_whole_frac:
+ mov [ebp],ebx
+ fild dword [ebp]
+ test edi, edi
+ jz lnumber_frac_init
+ fchs
+ jmp lnumber_frac_init
+lnumber_whole_exp:
+ mov [ebp],ebx
+ fild dword [ebp]
+ test edi, edi
+ jz lnumber_exp_init
+ fchs
+ jmp lnumber_exp_init
+lnumber_whole_terminate:
+ mov [ebp],ebx
+ fild dword [ebp]
+ test edi, edi
+ jz lnumber_whole_terminate_pos
+ fchs
+lnumber_whole_terminate_pos:
+ call tolog
+ call fisteax
+ pop edi
+ pop esi
+ ret
+
+lnumber_frac_init:
+ mov edx, 1
+ xor ebx, ebx
+lnumber_frac:
+ cmp edx, 1000000000
+ jge lnumber_frac_long
+ test ecx, ecx
+ jz lnumber_frac_terminate
+ lodsb
+ dec ecx
+ cmp al, 'e'
+ je lnumber_frac_exp
+ cmp al, 'E'
+ je lnumber_frac_exp
+ imul ebx, 10
+ sub al, '0'
+ add ebx, eax
+ imul edx, 10
+ jmp lnumber_frac
+lnumber_frac_exp:
+ mov [ebp],ebx
+ fild dword [ebp]
+ test edi, edi
+ jz lnumber_frac_exp_pos
+ fchs
+lnumber_frac_exp_pos:
+ mov [ebp], edx
+ fild dword [ebp]
+ fdivp st1
+ faddp st1
+ jmp lnumber_exp_init
+lnumber_frac_terminate:
+ mov [ebp],ebx
+ fild dword [ebp]
+ test edi, edi
+ jz lnumber_frac_terminate_pos
+ fchs
+lnumber_frac_terminate_pos:
+ mov [ebp], edx
+ fild dword [ebp]
+ fdivp st1
+ faddp st1
+ call tolog
+ call fisteax
+ pop edi
+ pop esi
+ ret
+lnumber_frac_long:
+ test ecx, ecx
+ jz lnumber_frac_terminate
+ lodsb
+ dec ecx
+ cmp al, 'e'
+ je lnumber_frac_exp
+ cmp al, 'E'
+ je lnumber_frac_exp
+ jmp lnumber_frac_long
+
+lnumber_exp_init:
+ xor ebx, ebx
+ xor eax, eax
+ xor edi, edi
+lnumber_exp:
+ test ecx, ecx
+ jz lnumber_exp_terminate
+ lodsb
+ dec ecx
+ cmp al, '+'
+ je lnumber_exp
+ cmp al, '-'
+ je lnumber_exp_neg
+ imul ebx, 10
+ sub al, '0'
+ add ebx, eax
+ jmp lnumber_exp
+lnumber_exp_neg:
+ inc edi
+ jmp lnumber_exp
+lnumber_exp_terminate:
+ mov [ebp],ebx
+ fild dword [ebp]
+ test edi, edi
+ jz lnumber_exp_pos
+ fchs
+lnumber_exp_pos:
+ fldl2t
+ fmulp
+ fld st0
+ frndint
+ fsub st1, st0
+ fxch st1
+ f2xm1
+ fld1
+ fadd
+ fscale
+ fstp st1
+ fmulp
+ call tolog
+ call fisteax
+ pop edi
+ pop esi
+ ret
+
+tolog:
+ ftst
+ push eax
+ xor edx, edx
+ xor ebx, ebx
+ fstsw ax
+ fwait
+ sahf
+ pop eax
+ ja tolog_pos
+ jz tolog_zero
+ mov edx, 0x80000000
+ fchs
+tolog_pos:
+ inc ebx
+ fld1
+ fxch st1
+ fyl2x
+ fimul dword [var_sfactor]
+tolog_zero:
+ ret
+
+fromlog:
+ fidiv dword [var_sfactor]
+ fld st0
+ frndint
+ fsub st1, st0
+ fxch st1
+ f2xm1
+ fld1
+ faddp st1, st0
+ fscale
+ fstp st1
+ test edx,edx
+ jz fromlog_pos
+ fchs
+fromlog_pos:
+ ret
+
+fldeax:
+ mov edx, eax
+ and edx, 0x80000000
+ and eax, 0x7fffffff
+ sub eax, 0x40000000
+ pushs eax
+ fild dword [ebp]
+ ret
+
+fisteax:
+ test ebx, ebx
+ jz fisteax_zero
+ fistp dword [ebp]
+ pops eax
+ add eax, 0x40000000
+ or eax, edx
+ ret
+fisteax_zero:
+ fstp st0
+ pops eax
+ xor eax, eax
+ ret
+
+ ; Prints out a logrep number
+defcode 'l.', 2, 0, ldot
+ push esi
+ push edi
+ call fldeax
+ call fromlog
+
+ ; Sign
+ test edx, edx
+ jz ldot_pos
+ fchs
+ mov eax, 45
+ call emit
+ pushs eax
+ldot_pos:
+ fldlg2
+ fld st1
+ fyl2x
+ fild dword [floor]
+ fcomip st0, st1
+ ja ldot_zero ; Catch zeros
+ fild dword [ceil]
+ fcomip st0, st1
+ jb ldot_inf ; Catch inf
+
+ fldcw [rnd_floor]
+ frndint
+ fist dword [ebp]
+ mov edx, [ebp] ; exponent base 10
+
+ ; Scale number
+ fchs
+ fldl2t
+ fmulp
+ fld st0
+ frndint
+ fsub st1, st0
+ fxch st1
+ f2xm1
+ fld1
+ fadd
+ fscale
+ fstp st1
+ fmulp
+
+ ; Print first digit
+ fldcw [rnd_trunc]
+ fist dword [ebp]
+ pops eax
+ add eax, 48
+ push edx
+ call emit
+ pushs eax
+ mov eax, 46
+ call emit
+ pop edx
+ pushs eax
+ pushs eax
+
+ ; Print remaining digits
+ mov ecx, [sigdigs]
+ldot_pdigs:
+ fld st0
+ frndint
+ fsubp st1
+ fimul dword [ten]
+ fist dword [ebp]
+ pops eax
+ add eax, 48
+ push ecx
+ push edx
+ call emit
+ pop edx
+ pop ecx
+ pushs eax
+ pushs eax
+ loop ldot_pdigs
+
+ pops eax
+ mov eax, 101
+ push edx
+ call emit
+ pop edx
+ pushs eax
+ mov eax, edx
+ call dot
+
+ pop edi
+ pop esi
+ fldcw [rnd_near]
+ fstp st0
+ ret
+ldot_zero:
+ pops eax
+ pop edi
+ pop esi
+ mov eax, 48
+ fstp st0
+ fstp st0
+ jmp emit
+ldot_inf:
+ pops eax
+ pop edi
+ pop esi
+ mov eax, 105
+ call emit
+ pushs eax
+ mov eax, 110
+ call emit
+ pushs eax
+ mov eax, 102
+ fstp st0
+ fstp st0
+ jmp emit
+
+ section .data
+floor:
+ dd -50
+ceil:
+ dd 50
+ten:
+ dd 10
+sigdigs:
+ dd 5
+
+defcode 'l*', 2, 0, lmult
+ pops ebx
+ test eax, 0x7fffffff
+ jz lmult_zero
+ test ebx, 0x7fffffff
+ jz lmult_zero
+ add eax, ebx
+ sub eax, 0x40000000
+ ret
+lmult_zero:
+ xor eax, eax
+ ret
+
+defcode 'l/', 2, F_INLINE, linv
+ xor eax, 0x7fffffff
+ ret
+
+defcode 'l/*', 3, 0, ldiv
+ pops ebx
+ test ebx, 0x7fffffff
+ jz ldiv_zero
+ xor eax, 0x7fffffff
+ add eax, ebx
+ sub eax, 0x40000000
+ ret
+ldiv_zero:
+ xor eax, eax
+ ret
+
+defcode 'l+', 2, 0, ladd
+ test eax, 0x7fffffff
+ jz ladd_zero
+ mov ebx, [ebp]
+ test ebx, 0x7fffffff
+ jz ladd_zero2
+ xor ebx, 0x7fffffff
+ add eax, ebx
+ sub eax, 0x40000000
+ call l1plus
+ pops ebx
+ add eax, ebx
+ sub eax, 0x40000000
+ ret
+ladd_zero:
+ pops eax
+ ret
+ladd_zero2:
+ pops ebx
+ ret
+
+defcode 'l-', 2, F_INLINE, lsgn
+ xor eax, 0x80000000
+ ret
+
+defcode 'l-+', 3, 0, lsub
+ test eax, 0x7fffffff
+ jz lsub_zero
+ xor eax, 0x80000000
+ mov ebx, [ebp]
+ test ebx, 0x7fffffff
+ jz lsub_zero2
+ xor ebx, 0x7fffffff
+ add eax, ebx
+ sub eax, 0x40000000
+ call l1plus
+ pops ebx
+ add eax, ebx
+ sub eax, 0x40000000
+ ret
+lsub_zero:
+ pops eax
+ ret
+lsub_zero2:
+ pops ebx
+ ret
+
+defcode 'lpow', 4, 0, lpow
+ call fldeax
+ call fromlog
+ fimul dword [pow_factor]
+ fistp dword [ebp]
+ pops ebx
+ pops eax
+ sub eax, 0x40000000
+ imul eax, ebx
+ xor edx, edx
+ sar eax, 8
+ add eax, 0x40000000
+ ret
+
+ section .data
+pow_factor:
+ dd 0x100
+
+defcode "l1+", 3, 0, l1plus
+ call fldeax
+ call fromlog
+ fld1
+ faddp
+ call tolog
+ jmp fisteax
+
+defcode 'labs', 4, F_INLINE, labs
+ and eax, 0x7fffffff
+ ret
+
+defcode "log", 3, 0, log
+ call fldeax
+ call fromlog
+ fldln2
+ fxch st1
+ fyl2x
+ call tolog
+ jmp fisteax
+
+defcode "exp", 3, 0, exp
+ call fldeax
+ call fromlog
+ fldl2e
+ fmulp
+ fld st0
+ frndint
+ fsub st1, st0
+ fxch st1
+ f2xm1
+ fld1
+ fadd
+ fscale
+ fstp st1
+ call tolog
+ jmp fisteax
+
+defcode 'ilog', 4, F_INLINE, ilog
+ bsr eax,eax
+ ret
+
+defcode "ltoi", 4, 0, ltoi
+ call fldeax
+ call fromlog
+ fistp dword [ebp]
+ pops eax
+ ret
+
+defcode "itol", 4, 0, itol
+ pushs eax
+ fild dword [ebp]
+ call tolog
+ jmp fisteax
+
+defcode 'rnd', 3, 0, rnd
+ call fldeax
+ call fromlog
+ frndint
+ call tolog
+ jmp fisteax
+
+defcode '=', 1, F_INLINE, eq
+ pops ebx
+ cmp eax, ebx
+ sete al
+ movzx eax, al
+ ret
+
+defcode '!=', 2, F_INLINE, neq
+ pops ebx
+ cmp eax, ebx
+ setne al
+ movzx eax, al
+ ret
+
+defcode '<', 1, F_INLINE, lt
+ pops ebx
+ cmp eax, ebx
+ setg al
+ movzx eax, al
+ ret
+
+defcode '>', 1, F_INLINE, gt
+ pops ebx
+ cmp eax, ebx
+ setl al
+ movzx eax, al
+ ret
+
+defcode '<=', 2, F_INLINE, le
+ pops ebx
+ cmp eax, ebx
+ setge al
+ movzx eax, al
+ ret
+
+defcode '>=', 2, F_INLINE, ge
+ pops ebx
+ cmp eax, ebx
+ setle al
+ movzx eax, al
+ ret
+
+defcode 'l0=', 3, F_INLINE, lzeq
+ test eax, 0x7fffffff
+ setz al
+ movzx eax, al
+ ret
+
+defcode 'l0!=', 4, F_INLINE, lnzeq
+ test eax, 0x7fffffff
+ setnz al
+ movzx eax, al
+ ret
+
+defcode '0=', 2, F_INLINE, zeq
+ test eax, eax
+ setz al
+ movzx eax, al
+ ret
+
+defcode '0!=', 3, F_INLINE, nzeq
+ test eax, eax
+ setnz al
+ movzx eax, al
+ ret
+
+defcode '0<', 2, F_INLINE, zlt
+ test eax, eax
+ setl al
+ movzx eax, al
+ ret
+
+defcode '0>', 2, F_INLINE, zgt
+ test eax, eax
+ setg al
+ movzx eax, al
+ ret
+
+defcode '0<=', 3, F_INLINE, zle
+ test eax, eax
+ setle al
+ movzx eax, al
+ ret
+
+defcode '0>=', 3, F_INLINE, zge
+ test eax, eax
+ setge al
+ movzx eax, al
+ ret
+
+defcode 'and', 3, F_INLINE, and
+ pops ebx
+ and eax, ebx
+ ret
+
+defcode 'or', 2, F_INLINE, or
+ pops ebx
+ or eax, ebx
+ ret
+
+defcode 'xor', 3, F_INLINE, xor
+ pops ebx
+ xor eax, ebx
+ ret
+
+defcode '2*', 2, F_INLINE, twotimes
+ sal eax, 1
+ ret
+
+defcode '2/', 2, F_INLINE, twodiv
+ sar eax, 1
+ ret
+
+defcode 'lshift', 6, F_INLINE, lshift
+ shl eax, 1
+ ret
+
+defcode 'rshift', 6, F_INLINE, rshift
+ shr eax, 1
+ ret
+
+defcode 'char', 4, 0, char
+ call rword
+ pops ebx
+ xor eax, eax
+ mov byte al, [ebx]
+ ret
+
+defcode '>r', 2, F_INLINE, tor
+ push eax
+ pops eax
+ ret
+
+defcode '<r', 2, F_INLINE, fromr
+ pushs eax
+ pop eax
+ ret
+
+defcode '>a', 2, F_INLINE, toa
+ mov esi, eax
+ pops eax
+ ret
+
+defcode '<a', 2, F_INLINE, froma
+ pushs eax
+ mov eax, esi
+ ret
+
+defcode '@a', 2, F_INLINE, ata
+ pushs eax
+ mov eax, [esi]
+ ret
+
+defcode '!a', 2, F_INLINE, puta
+ mov [esi], eax
+ pops eax
+ ret
+
+defcode 'c@a', 3, F_INLINE, cata
+ pushs eax
+ xor eax, eax
+ mov al, [esi]
+ ret
+
+defcode 'c!a', 3, F_INLINE, putca
+ mov [esi], al
+ pops eax
+ ret
+
+defcode '@+', 2, F_INLINE, getinca
+ pushs eax
+ lodsd
+ ret
+
+defcode 'c@+', 3, F_INLINE, getcinca
+ pushs eax
+ xor eax, eax
+ lodsb
+ ret
+
+defcode '>b', 2, F_INLINE, tob
+ mov edi, eax
+ pops eax
+ ret
+
+defcode '<b', 2, F_INLINE, fromb
+ pushs eax
+ mov eax, edi
+ ret
+
+defcode '@b', 2, F_INLINE, atb
+ pushs eax
+ mov eax, [edi]
+ ret
+
+defcode '!b', 2, F_INLINE, putb
+ mov [edi], eax
+ pops eax
+ ret
+
+defcode 'c@b', 3, F_INLINE, atcb
+ pushs eax
+ xor eax, eax
+ mov al, [edi]
+ ret
+
+defcode 'c!b', 3, F_INLINE, putcb
+ mov [edi], al
+ pops eax
+ ret
+
+defcode '!+', 2, F_INLINE, putincb
+ stosd
+ pops eax
+ ret
+
+defcode 'c!+', 3, F_INLINE, puctincb
+ stosb
+ pops eax
+ ret
+
+defcode '+!', 2, F_INLINE, addput
+ pops ebx
+ mov ecx, [eax]
+ add ecx, ebx
+ mov [eax], ecx
+ pops eax
+ ret
+
+defcode 'b+', 2, F_INLINE, incb
+ inc edi
+ ret
+
+defcode 'a+', 2, F_INLINE, inca
+ inc esi
+ ret
+
+defcode 'memcpy', 6, 0, memcpy
+ mov ecx, eax
+memcpy_loop:
+ lodsd
+ stosd
+ loop memcpy_loop
+ pops eax
+ ret
+
+defcode 'branch', 6, 0, branch
+ mov ebx,[esp]
+ mov ecx, [ebx]
+ mov [esp], ecx
+ ret
+
+defcode '0branch', 7, 0, nbranch
+ test eax,eax
+ pops eax
+ jz branch
+ mov ebx, [esp]
+ add ebx, 4
+ mov [esp], ebx
+ ret
+
+defcode 'quit', 4, 0, quit
+ mov esp,[var_rz]
+ call interpret
+ jmp quit
+
+defcode 'abort', 5, 0, abort
+ mov ebp, stack_top
+ jmp quit
+
+defcode 'interpret', 9, 0, interpret
+ call rword
+ call twodup
+ call find
+ test eax,eax
+ jz push_lit ; a number
+ call nip
+ call nip
+ mov dword ebx, [var_state]
+ test ebx, ebx
+ jz execute
+ mov byte bl, [eax+4]
+ and bl, F_IMMED
+ jnz execute
+
+ ; we are compiling a word
+compile_word:
+ ; Check to see if we inline
+ mov bl, [eax + 4]
+ test bl, F_INLINE
+ jnz compile_inline_word
+ call tcfa
+ call ccomma
+ ret
+
+compile_inline_word:
+ call tcfa
+ push esi
+ push edi
+
+ mov esi, eax
+ mov edi, [var_here]
+compile_inline_word_loop:
+ lodsb
+ cmp al, 0xc3
+ je compile_inline_word_done
+ stosb
+ jmp compile_inline_word_loop
+
+compile_inline_word_done:
+ mov [var_here], edi
+ pop edi
+ pop esi
+ pops eax
+ ret
+
+execute:
+ call tcfa
+exaf:
+ mov ebx, eax
+ pops eax
+ call ebx
+ ret
+
+push_lit:
+ pops eax
+ pusha
+ mov ecx, eax
+ mov edi, [ebp]
+ mov al, 46
+ cld
+ repne scasb
+ popa
+ jne push_int
+ call lnumber
+ jmp push_cont
+push_int:
+ call number
+push_cont:
+ mov dword ebx, [var_state]
+ test ebx, ebx
+ jnz compile_lit
+ ret
+
+compile_lit:
+ push edi
+ mov edi, [var_here]
+ push eax
+ mov eax, lit
+ sub eax, edi
+ add eax, -5
+ push eax
+ mov al, 0xe8
+ stosb
+ pop eax
+ stosd
+ pop eax
+ stosd
+ mov [var_here], edi
+ pops eax
+ pop edi
+ ret
+
+defcode 'number', 6, 0, number
+ mov ecx, eax
+ pops edx
+ xor eax, eax
+ xor ebx, ebx
+ mov byte [is_neg], 0
+ test ecx, ecx
+ jle number_end
+ mov byte bl, [edx]
+ inc edx
+ dec ecx
+ cmp bl, '+'
+ je number_parse_digits
+ cmp bl, '-'
+ je number_neg
+ sub bl, '0'
+ mov al, bl
+
+number_parse_digits:
+ test ecx, ecx
+ jz number_end
+ imul eax, 10
+ mov byte bl, [edx]
+ inc edx
+ dec ecx
+ sub bl, '0'
+ add eax, ebx
+ jmp number_parse_digits
+
+number_neg:
+ inc byte [is_neg]
+ jmp number_parse_digits
+
+number_end:
+ mov byte bl, [is_neg]
+ test bl, bl
+ jz number_pos
+ neg eax
+
+number_pos:
+ ret
+
+ section .data
+is_neg: db 0
+
+defcode 'key',3,0,key
+ pushs eax
+ mov eax, 3
+ xor ebx, ebx
+ mov ecx, buffer
+ mov edx, 1
+ int 0x80
+ test eax, eax
+ jbe dead
+ mov eax, [buffer]
+ ret
+
+dead:
+ mov eax, 1
+ xor ebx, ebx
+ int 0x80
+
+defcode 'emit', 4, 0, emit
+ mov [buffer], eax
+ mov eax, 4
+ mov ebx, 1
+ mov ecx, buffer
+ mov edx, 1
+ int 0x80
+ pops eax
+ ret
+
+ section .data
+ align 4
+buffer:
+ dd 0
+
+defcode 'word', 4, 0, rword
+ call key
+ cmp al, ' '
+ je word_space
+ cmp al, 10
+ je word_space
+ cmp al, 9
+ je word_space
+ push edi
+ mov edi, word_buffer
+ mov ebx, 1
+ stosb
+ pops eax
+fill:
+ push ebx
+ call key
+ pop ebx
+ cmp al, ' '
+ je end_word
+ cmp al, 9
+ je end_word
+ cmp al, 10
+ je end_word
+ stosb
+ pops eax
+ inc ebx
+ jmp fill
+
+end_word:
+ mov eax, word_buffer
+ pushs eax
+ mov eax, ebx
+ pop edi
+ ret
+
+word_space:
+ pops eax
+ jmp rword
+
+ section .data
+ align 4
+word_buffer:
+ times 64 db 0
+
+defcode 'find', 4, 0, find
+ pops ebx
+ mov ecx, eax
+ mov edx, var_latest
+check_name:
+ test edx, edx
+ je nothing_found
+
+ ; length check
+ xor eax, eax
+ mov al, [edx + 4]
+ and al, F_LENMASK
+ cmp cl, al
+ jne mismatch
+
+ ; full check
+ push ecx
+ push esi
+ push edi
+ mov edi, ebx
+ lea esi, [edx + 5]
+ repe cmpsb
+ pop edi
+ pop esi
+ pop ecx
+ jne mismatch
+
+ ; match
+ mov eax, edx
+ ret
+
+mismatch:
+ mov edx, [edx]
+ jmp check_name
+
+nothing_found:
+ xor eax, eax
+ ret
+
+defcode '>cfa', 4, 0, tcfa
+ add eax, 4
+ xor ecx, ecx
+ mov byte cl, [eax]
+ inc eax
+ and cl, F_LENMASK
+ add eax, ecx
+ add eax, 3
+ and eax, ~3
+ ret
+
+defcode 'create', 6, 0, create
+ mov ecx, eax ; nlen
+ push esi
+ push edi
+ pops esi ; str ptr
+ mov edi, [var_here]
+ add edi, 3
+ and edi, ~3
+ mov eax, [var_latest]
+ mov [var_latest], edi
+ stosd ; link pointer
+ mov al, cl
+ stosb ; nlen
+ rep movsb ; store name
+ ; pad
+ add edi, 3
+ and edi, ~3
+ ; update here
+ mov eax,[var_here]
+ mov [var_here], edi
+ pops eax
+ pop edi
+ pop esi
+ ret
+
+defcode ',', 1, 0, comma
+ push edi
+ mov edi,[var_here]
+ stosd
+ mov [var_here], edi
+ pop edi
+ pops eax
+ ret
+
+defcode 'c,', 2, 0, commac
+ push edi
+ mov edi,[var_here]
+ stosb
+ mov [var_here], edi
+ pop edi
+ pops eax
+ ret
+
+defcode '[', 1, F_IMMED, lbrac
+ mov dword [var_state], 0
+ ret
+
+defcode ']', 1, 0, rbrac
+ mov dword [var_state], 1
+ ret
+
+defcode ':', 1, 0, colon
+ call rword
+ call create
+ jmp rbrac
+
+defcode 'exit', 4, 0, exit
+ jmp semicolon
+
+defcode 'nop', 3, 0, donothing
+ ret
+
+defcode '!h', 2, F_INLINE, writehere
+ mov [var_here], eax
+ pops eax
+ ret
+
+ ; Tail-call optimised
+defcode ';', 1, F_IMMED, semicolon
+ push eax
+ push edi
+ mov edi, [var_here]
<