From 1b30051ee29fbf6a0ddf989a1faac2481d601bd9 Mon Sep 17 00:00:00 2001 From: Justin Bedo Date: Mon, 19 Nov 2012 10:11:44 +1100 Subject: Import of untracked forth codebase. --- README | 3 + build | 3 + forth.f | 110 ++++ forth.s | 1712 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 1828 insertions(+) create mode 100644 README create mode 100755 build create mode 100644 forth.f create mode 100644 forth.s 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 ; +: mmap ( path -- ptr ) + ORW open dup dup >r fsize dup r >r 0 swap + PROT_READ PROT_WRITE or MAP_SHARED r ORW screate r >r 0 swap + PROT_READ PROT_WRITE or MAP_SHARED = ; +: ?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 'a', 2, F_INLINE, toa + mov esi, eax + pops eax + ret + +defcode 'b', 2, F_INLINE, tob + mov edi, eax + pops 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] + ; if last op was a call convert to jmp + lea ebx,[edi - 5] + mov byte al, [ebx] + cmp al, 0xe8 + jne compile_ret + inc al + mov byte [ebx], al + pop edi + pop eax + jmp lbrac +compile_ret: + ; compile in a ret call + mov al, 0xc3 + stosb + mov [var_here], edi + pop edi + pop eax + jmp lbrac + +defcode 39, 1, 0, tick + pushs eax + mov ebx,[esp] + inc ebx + mov eax, [ebx] + add ebx, 4 + mov [esp], ebx + add eax, ebx + ret + + +defcode ',,', 2, 0, ccomma + push edi + mov edi,[var_here] + sub eax, edi + add eax, -5 + push eax + mov al, 0xe8 + stosb + pop eax + stosd + mov [var_here], edi + pop edi + pops eax + ret + +defcode 'allot', 5, 0, allot + mov ebx, [var_here] + add eax, ebx + mov [var_here],eax + pops eax + ret + +defcode 'immediate', 9, F_IMMED, immediate + mov ebx, [var_latest] + add ebx, 4 + mov byte cl, [ebx] + add cl, F_IMMED + mov byte [ebx], cl + ret + +defcode '@', 1, F_INLINE, get + mov ebx, [eax] + mov eax, ebx + ret + +defcode '!', 1, F_INLINE, put + pops ebx + mov [eax], ebx + pops eax + ret + +defcode 'c@', 2, F_INLINE, getc + mov byte bl, [eax] + xor eax, eax + mov byte al, bl + ret + +defcode 'c!', 2, F_INLINE, putc + pops ebx + mov byte [eax], bl + pops eax + ret + +defcode 'fsize', 5, 0, fsize + mov ebx, eax + mov eax, 108 + sub esp, 88 ; size of struct + mov ecx, esp + int 0x80 + test eax, eax + jnz fsize_fail + mov eax, [esp+20] ; size field + add esp, 88 + ret +fsize_fail: + mov eax, -1 + add esp, 80 + ret + +defcode 'execute', 7, 0, exec + mov ebx, eax + pops eax + jmp ebx + + ; Radix sort +defcode 'sort' , 4, 0, sort + push esi + push edi + mov ebx, 1 + push eax + + ; Convert to offset binary + mov esi, [ebp] + mov edi, [ebp] + mov ecx, [esp] +sort_offset: + lodsd + xor eax, 0x80000000 + stosd + loop sort_offset + +sort_again: + mov edi, [var_here] + + ; Copy 0s + mov esi, [ebp] + mov ecx, [esp] +sort_0cpy: + lodsd + test eax, ebx + jnz sort_0cpy_next + stosd +sort_0cpy_next: + loop sort_0cpy + + ; Copy 1s + mov esi, [ebp] + mov ecx, [esp] +sort_1cpy: + lodsd + test eax, ebx + jz sort_1cpy_next + stosd +sort_1cpy_next: + loop sort_1cpy + + ; Copy back + mov esi, [var_here] + mov edi, [ebp] + mov ecx, [esp] +sort_cpy_back: + lodsd + stosd + loop sort_cpy_back + + shl ebx, 1 + test ebx,ebx + jnz sort_again + + ; Convert from offset binary + mov esi, [ebp] + mov edi, [ebp] + mov ecx, [esp] +sort_offset2: + lodsd + xor eax, 0x80000000 + stosd + loop sort_offset2 + + pop ecx + pop edi + pop esi + + pops eax + pops eax + ret + +defvar 'state', 5, 0, state, 0 +defvar 'here', 4, 0, here, 0 +defvar 'latest', 6, 0, latest, name_syscall0 +defvar 'sfactor', 7, 0, sfactor, 0x00010000 +defvar 'sign-bit', 8, 0, sign_bit, 0x80000000 +defvar 'exp-bit', 7, 0, exp_bit, 0x40000000 +defvar 'inf', 3, 0, inf, 0x7fffffff +defvar '-inf', 4, 0, ninf, 0xffffffff +defvar 'oddbits', 7, 0, oddbits, 0x55555555 +defvar 'evenbits', 8, 0, evenbits, 0xaaaaaaaa + + ; increases dictionary memory +defcode 'brkinc', 6, 0, brkinc + xor ebx, ebx + mov ecx, eax + mov eax, 45 ; brk + int 0x80 + add eax, ecx + mov ebx, eax + mov eax, 45 ; brk + int 0x80 + pops eax + ret + +defcode 'syscall6', 8, 0, syscall6 + push eax + pops eax + pops edi + pops esi + pops edx + pops ecx + pops ebx + push ebp + mov ebp, eax + lea eax,[esp + 4] + mov eax,[eax] + int 0x80 + pop ebp + pop ebx + ret + +defcode 'syscall3', 8, 0, syscall3 + pops edx + pops ecx + pops ebx + int 0x80 + ret + +defcode 'syscall2', 8, 0, syscall2 + pops ecx + pops ebx + int 0x80 + ret + +defcode 'syscall1', 8, 0, syscall1 + pops ebx + int 0x80 + ret + +defcode 'syscall0', 8, 0, syscall0 + int 0x80 + ret + + section .rodata + align 4 +alloc_dict: + xor ebx, ebx + mov eax, 45 ; brk + int 0x80 + mov [var_here], eax + add eax, 65536 ; initial data-segment size + mov ebx, eax + mov eax, 45 ; brk + int 0x80 + ret + + section .data + +var_rz: dd 0 + +stack: + times 128 db 0 +stack_top: -- cgit v1.2.3