урря, нашлось:
Код:
; 14.01.2010 mOleg
; набросок трехстековой Форт Виртуальной Машины (ФВМ)
; стеки: данных, возвратов, адресов
; подпрограммный шитый код без оптимизаций
; в двух секциях: код отдельно от пространства имен
; без VALUE и VECT переменных
; без многопоточности и локальных областей данных
; без словарей (один список слов)
; без опроса клавиш (через readfile)
; без поддержки механизма исключений
; без ускорения поиска имен в списке слов
; без отдельного распознавания чисел (спец префиксы перед числами)
format PE console ; под винду
entry _cold ; стартовый адрес
include 'include\win32a.inc'
include 'include\macro\struct.inc'
; ------------------------------------------------------------------------------
section '.import' import data readable writeable
;
library kernel,'KERNEL32.DLL'
import kernel,\
LoadLibrary, 'LoadLibrary',\
GetProcAddress, 'GetProcAddress',\
ExitProcess, 'ExitProcess',\
GetStdHandle, 'GetStdHandle',\
WriteFile, 'WriteFile',\
ReadFile, 'ReadFile'
; ------------------------------------------------------------------------------
; использование регистров
tos equ EAX ; кеш вершины стека данных
toa equ EBX ; кеш вершины стека возвратов
temp equ EDX ; временный регистра
cnt equ ECX
tad equ EBP ; указатель на вершину стека данных
tar equ ESP ; указатель на вершину стека возвратов
taa equ ESI ; указатель на вершину стека адресов
; типы данных
struct cell
body dd ? ;
ends
struct addr
body dd ? ;
ends
struct token
call db 0xE8
ref dd ?
ends
struct scnt
body db ?
ends
struct ref
body dd ?
ends
; ------------------------------------------------------------------------------
; объявление констант
ADDR = sizeof.addr ; размер адресной ссылки
CELL = sizeof.cell ; размер ячейки данных
REF = sizeof.ref ; размер ссылки
TOKEN = sizeof.token ; размер токена
SCNT = sizeof.scnt ; размер счетчика длины
dStack equ 0x1000 ; размер стека данных
aStack equ 0x1000 ; размер стека адресов
rStack equ 0x1000 ; размер стека возвратов
TIB_size = 0x50
PAD_size = 0x50
NamesSpace = 0x10000
CodeSpace = 0x10000
ImmWord = -1 ; признак слова немедленного исполнения
StdWord = 1 ; признак обычного слова
; вычисляем сколько места надо выделять под стеки
stack (dStack+aStack+rStack)*2, dStack+aStack+rStack
; ------------------------------------------------------------------------------
latest = 0
; описатель форт-строк
macro fstr [string]
{ common local .count, .body
.count scnt ?
.body db string,0
store $-.body-1 at .count
}
macro slit [str]
{ local labxx
call _box
addr labxx
fstr str
align
labxx: }
; формат заголовка имени (подробнее см. _sHeader)
macro def string,cfa,flg
{ dd latest
latest=$-CELL
addr cfa
db flg
common local .count, .body
.count scnt ?
.body db string,0
store $-.body-1 at .count
}
; перемещение указателей стеков
macro dheave val { lea tad , [tad+val] }
macro aheave val { lea taa , [taa+val] }
macro rheave val { lea tar , [tar+val] }
macro rpop reg
{ pop reg }
macro rpush reg
{ push reg }
macro dpush reg
{ dheave -CELL
mov [tad], tos
if reg eq tos
else
mov tos, reg
end if }
macro dpop reg
{ mov reg, [tad]
lea tad, [tad+CELL] }
macro apush reg
{ aheave -CELL
mov [taa], toa
if reg eq toa ; если dup, то не надо mov r,r
else
mov toa, reg
end if }
macro apop reg
{ mov reg, [taa]
lea taa, [taa+ADDR] }
macro dlit val
{ call _dlit
cell val }
macro alit val
{ call _alit
addr val }
macro rlit val { push val }
allot equ rb
; macro mIF ; как написать макро для компиляции перехода вперед?
macro align
{ repeat (($+CELL-1)and -CELL)-$
nop
end repeat }
macro VARIABLE deffname
{ label deffname
call _avariable
allot ADDR
align }
macro CREATE defname
{ label defname
call _create }
macro fcode [words]
{ call words }
macro exit
{ ret
align }
macro ERROR [msg]
{ slit msg
call _count
call _error }
macro MESSAGE [string]
{ slit string
call _print
call _cr }
; ------------------------------------------------------------------------------
section '.fvm' code executable readable writeable
;
_dup: ;( d: n --> d: n n )
dpush tos
;
_noop: ;( --> )
exit
;
_drop: ;( d: n --> )
dpop tos
exit
;
_swap: ;( d: a b --> d: b a )
mov temp, [tad]
mov [tad], tos
mov tos, temp
exit
;
_over: ;( d: a b --> d: a b a )
mov temp, [tad]
dpush temp
exit
;
_plus: ;( d: a b --> d: a+b )
add tos, [tad]
dheave CELL
exit
;
_minus: ;( d: a b --> d: a-b )
sub tos, [tad]
dheave CELL
exit
;
_mul: ;( d: a b --> d: a-b )
mul dword [tad]
dheave CELL
exit
;
_xor: ;( d: a b --> d: n )
xor tos, [tad]
dheave CELL
exit
;
_and: ;( d: a b --> d: n )
and tos, [tad]
dheave CELL
exit
;
_or: ;( d: a b --> d: n )
or tos, [tad]
dheave CELL
exit
;
_abs: ;( d: n --> d: u )
mov temp , tos
sar temp , 31
add tos , temp
xor tos , temp
exit
;
_moddiv: ;( d: n n --> d: n n )
mov cnt, tos
xor temp, temp
mov tos, [tad]
div cnt
mov [tad], EDX
exit
;
_dlit: ;( --> d: n )
pop temp
dpush [temp]
lea temp, [temp+CELL]
jmp temp
align
;
_adup: ;( a: addr --> addr addr )
apush toa
exit
;
_alit: ;( --> a: addr )
pop temp
apush toa
mov toa, [temp]
lea temp, [temp+CELL]
jmp temp
align
;
_rlit: ;( --> r: addr )
rpop temp
rpush dword [temp]
lea temp, [temp+ADDR]
jmp temp
align
;
_qnil: ;( a: addr --> a: addr d: flag )
dpush tos
mov tos, toa
sub tos, 1
sbb tos, tos
exit
;
_aadd: ;( a: addr d: u --> a: addr+u )
lea toa, [toa+tos]
dpop tos
exit
;
_create: ;( --> a: addr )
_avariable: ;( --> a: addr )
apush toa
pop toa
exit
;
_Astore: ;( a: addr addr --> )
apop temp
mov dword [toa], temp
apop toa
exit
;
_Afetch: ;( a: addr --> a: addr )
mov toa, dword [toa]
exit
;
_store: ;( a: addr d: n --> )
mov dword [toa], tos
dpop tos
apop toa
exit
;
_fetch: ;( a: addr --> d: n )
dpush tos
mov tos, dword [toa]
apop toa
exit
;
_execute: ;( a: xt --> )
mov temp, toa
apop toa
call temp
exit
;
_branch: ;( --> )
rpop temp
jmp dword [temp]
align
;
_0branch: ;( d: flag --> d: flag ) без удаления флагового значения
rpop temp
or tos,tos
jz lab00
lea temp, [temp+REF]
jmp temp
lab00: jmp dword [temp]
align
;
_d2r: ;( d: n --> r: n )
rpop temp
rpush tos
dpop tos
jmp temp
align
;
_RPfetch: ;( --> a: addr )
apush tar
exit
;
_APfetch: ;( --> a: addr )
apush taa
exit
;
_SPfetch: ;( --> a: addr )
apush tad
exit
;
_RPstore: ;( a: addr --> )
rpop temp
mov tar, toa
apop toa
jmp temp
;
_APstore: ;( a: addr --> )
mov taa, toa
apop toa
exit
;
_SPstore: ;( a: addr --> )
mov tad, toa
apop toa
exit
;
_a2r: ;( a: addr --> r: addr )
rpop temp
rpush toa
apop toa
jmp temp
align
;
_rdrop: ;( r: addr --> )
rpop temp
rheave -CELL
jmp temp
align
;
_off: ;( a: addr --> )
mov dword [toa], 0
apop toa
exit
;
_count: ;( a: addr --> a: addr d: # )
dpush tos
and tos, tos
mov AL, [toa]
lea toa, [toa+SCNT]
exit
;
_Aswap: ;( a: a1 a2 --> a2 a1 )
xchg toa, dword [taa]
exit
;
_r2a: ;( r: addr --> a: addr )
rpop temp
apush toa
rpop toa
jmp temp
;
_adrop: ;( a: addr --> )
apop toa
exit
; удалить адресную ссылку, находящуюся под вершиной стека адресов
_anip: ;( a: a1 a2 --> a: a2 )
aheave ADDR
exit
; извлечь байт данных из памяти по адресу,
; хранимому на вершине стека адресов, на вершину стека данных
_bfetch: ;( a: addr --> d: byte )
dpush tos
movzx tos, byte [toa]
apop toa
exit
; сохранить байт данных с вершины стека данных по адресу,
; хранимому на вершине стека адресов
_bstore: ;( a: addr d: byte --> )
mov byte [toa], AL ; tos
dpop tos
apop toa
exit
; переслылка указанного количества # минимально адресуемых единиц
; c адреса src в пространства начинающегося с адреса dst
_cmove: ;( d: # a: src dst --> )
mov cnt, tos
apop temp
jcxz lab31
lab30: mov AL, byte [temp]
mov byte [toa], AL
lea temp, [temp+1]
add toa, 1
loop lab30
lab31: apop toa
dpop tos
exit
; переменная last хранит адрес последнего слова в цепочке имен
_last: call _create
dd LATEST ; LATEST определен в конце списка имен
align
;
VARIABLE _latest
;
_MAIN: call _create
dd _abort ; главное слово системы
align
;
_DP: call _create
dd _there ; указатель на первый свободный байт системы
align
;
_NDP: call _create
dd NSADDR ; указатель на первый свободный байт в пространстве имен
align
VARIABLE _S0 ; переменная для хранения дна стека данных
VARIABLE _A0 ; адресов
VARIABLE _R0 ; возвратов
; входной буфер системы
CREATE _tib
allot TIB_size
align
; буфер для форматного преобразования строк
CREATE _pad
allot PAD_size
align
VARIABLE _STATE ; текущий режим работы системы: компиляция\интерпретация
VARIABLE _BASE ; текущая система счисления системы
VARIABLE _CURRENT ; хранит адрес хвоста списка добавляемых слов
VARIABLE _CONTEXT ; хранит адрес хвоста списка искомых слов
VARIABLE _TIBsize ; количество байт в tib
VARIABLE _IN ; текущая позиция трансляции текста
VARIABLE _STDIN ;
VARIABLE _STDOUT ;
VARIABLE _STDERR ;
VARIABLE _WARNING
VARIABLE _HLD
;
CREATE _NewLine
fstr 0x0d,0x0a
align
;-------------------------------------------------------------------------------
_cell: ;( --> d: cell# )
dpush CELL
exit
_addr: ;( --> d: addr# )
dpush ADDR
exit
_token: ;( --> d: token# )
dpush TOKEN
exit
_scnt: ;( --> d: scnt# )
dpush SCNT
exit
_ref: ;( --> d: ref# )
dpush REF
exit
;
_son: ;( --> )
mov dword [_STATE+TOKEN], -1
exit
;
_soff: ;( --> )
mov dword [_STATE+TOKEN], 0
exit
;
_here: ;( --> a: addr )
apush dword [_DP+TOKEN]
exit
;
_nhere: ;( --> a: addr )
apush dword [_NDP+TOKEN]
exit
; аналог ALLOT
_reserve: ;( d: u --> a: addr )
apush toa
MOV toa, dword [_DP+TOKEN]
LEA tos, [tos+toa]
MOV dword [_DP+TOKEN], tos
dpop tos
exit
;
_atod: ;( a: xt --> d: disp )
dpush tos
mov tos, dword [_DP+TOKEN]
sub tos, toa
apop toa
exit
;
_cbyte: ;( d: byte --> )
MOV temp, [_DP+TOKEN]
INC dword [_DP+TOKEN]
MOV byte [temp], AL ; tos
dpop tos
exit
;
_cref: ;( d: ref --> )
mov temp, [_DP+TOKEN]
add dword [_DP+TOKEN], REF
mov dword [temp], tos
dpop tos
exit
;
_dcomp: ;( d: n --> )
mov temp, [_DP+TOKEN]
add dword [_DP+TOKEN], CELL
mov dword [temp], tos
dpop tos
exit
;
_acomp: ;( a: addr --> )
MOV temp, dword [_DP+TOKEN]
ADD dword [_DP+TOKEN], ADDR
MOV dword [temp], toa
apop toa
exit
; NA,
_nacomp: ;( a: addr --> )
mov temp, dword [_NDP+TOKEN]
add dword [_NDP+TOKEN], ADDR
mov dword [temp], toa
apop toa
exit
; NB,
_nbcomp: ;( d: byte --> )
mov temp, dword [_NDP+TOKEN]
inc dword [_NDP+TOKEN]
mov byte [temp], AL
dpop tos
exit
;
_nccomp: ;( d: n --> )
mov temp, dword [_NDP+TOKEN]
add dword [_NDP+TOKEN], CELL
mov dword [temp], tos
dpop tos
exit
;
_ctoken: ;( a: xt --> )
dpush 0xE8
call _cbyte
call _atod
call _cref
exit
;
_cexit: ;( --> )
dpush 0xC3
call _cbyte
exit
; NS, компиляция строки в пространство имен
_cns: ;( a: asc d: # --> )
apush toa
mov toa, [_NDP+TOKEN]
add dword [_NDP+TOKEN], tos
call _cmove
exit
; компиляция строки со счетчиком в пространство имен
_cnstr: ;( a: addr d: # --> )
dpush tos
call _nbcomp
call _cns
dpush 0
call _nbcomp
exit
;
_cs: ;( a: asc d: # --> )
apush toa
mov toa, [_DP+TOKEN]
add dword [_DP+TOKEN], tos
call _cmove
exit
;
_cstr: ;( a: addr d: # --> )
dpush tos
call _cbyte
call _cs
dpush 0
call _cbyte
exit
;-------------------------------------------------------------------------------
; <#
_lbdiez: ;( --> )
lea temp, [_pad+TOKEN+TIB_size-1]
mov dword [_HLD+TOKEN], temp
mov byte [temp], 0
exit
; #>
_diezrb: ;( d: x --> a: addr d: # )
apush toa
mov toa, [_HLD+TOKEN]
lea tos, [_pad+TOKEN+TIB_size-1]
sub tos, toa
exit
;
_hold: ;( d: char --> )
dec dword [_HLD+TOKEN]
mov temp, [_HLD+TOKEN]
mov [temp], AL
dpop tos
exit
;
_sign: ;( --> )
dpush 0x2D
call _hold
exit
; >DIGIT
_digit: ;( d: u --> d: char )
cmp tos, 0x0A
js lab15
lea tos, [tos+7]
lab15: lea tos, [tos+0x30]
exit
; в отличие от стандартного форта, числа одинарной длины
_diez: ;( d: u --> d: u )
xor edx,edx
idiv dword [_BASE+TOKEN]
dpush temp
call _digit
call _hold
exit
; #S в отличие от стандартного форта число одинарной длины
_sdiez: ;( d: u --> d: 0 )
lab16: or tos, tos
jz lab17
call _diez
jmp lab16
lab17: exit
;
_unum: ;( d: u --> a: addr d: # )
call _lbdiez
call _sdiez
call _diezrb
exit
;
_snumt: ;( d: u --> )
call _unum
call _type
exit
;-------------------------------------------------------------------------------
;
_2cipher: ;( d: char --> d: u )
cmp tos, 0x3A
js lab20
cmp tos, 0x5B
js lab21
lea tos, [tos-87]
exit
lab21: lea tos, [tos-55]
exit
lab20: lea tos, [tos-48]
exit
;
_val: ;( a: addr d: # --> d: ?? )
mov cnt, tos
xor tos, tos
jcxz lab23
cmp byte [toa], 0x2D ; ? -
pushf
jnz lab22 ; число положительное
lea toa, [toa+1]
sub cnt, 1
jnz lab22
lab23: ERROR 'Must be number!'
align
lab22: imul dword [_BASE+TOKEN]
rpush tos
movzx tos, byte [toa]
call _2cipher
cmp tos, dword [_BASE+TOKEN]
jns lab23
add tos, dword [tar]
lea tar, [tar+CELL]
inc toa
loop lab22
apop toa
popf
jnz lab24
neg tos
lab24: exit
;-------------------------------------------------------------------------------
;
_clit: ;( d: n --> )
apush _dlit
call _ctoken
call _dcomp
exit
;
_calit: ;( a: addr --> )
apush _alit
call _ctoken
call _acomp
exit
;
_literal: ;( d: n --> | n )
cmp dword [_STATE+TOKEN], 0
jz lab25
call _clit
lab25: exit
;
_dnum: ;( / decimal --> d: n )
call _NextToken
call _val
call _literal
exit
;
_aliteral: ;( a: addr --> a: addr | )
cmp dword [_STATE+TOKEN], 0
jz lab26
call _calit
lab26: exit
;
_anum: ;( / hex --> a: addr )
call _NextToken
rpush dword [_BASE+TOKEN]
mov dword [_BASE+TOKEN], 0x10
call _val
apush toa
mov toa, tos
dpop tos
rpop dword [_BASE+TOKEN]
call _aliteral
exit
;-------------------------------------------------------------------------------
; завершить последнее определение
_ecreate: ;( --> )
mov cnt, dword [_latest+TOKEN] ;
jcxz lab40
mov temp, dword [_last+TOKEN]
mov dword [cnt], temp
mov dword [_last+TOKEN], cnt ; сохранить LATEST в LAST
mov dword [_latest+TOKEN], 0
lab40: exit
;
_round: ;( a: addr d: # --> )
XOR EDX, EDX
mov cnt, tos
lea tos, [toa+tos-1]
idiv cnt
imul cnt
mov toa, tos
dpop tos
exit
;
_align: ;( --> )
call _here
call _cell
call _round
mov dword [_DP+TOKEN], toa
apop toa
exit
;
_nalign: ;( --> )
call _nhere
call _cell
call _round
mov dword [_NDP+TOKEN], toa
apop toa
exit
; формат заголовка:
; addr[] off_back
; addr[] off_code
; byte[] off_attr
; scnt[] off_name#
; ... тут само имя
; byte[] off_zerobyte \ завершающий нулевой байт
; создать новый заголовок слова
_sHeader: ;( a: addr d: # --> )
call _ecreate ; завершить предыдущее определение
call _nalign
mov temp, dword [_NDP+TOKEN]
mov dword [_latest+TOKEN], temp
apush 0 ; тут в последствии будет ссылка на предыдущее определение
call _nacomp ; а в начале хранится нуль
call _align
apush dword [_DP+TOKEN]
call _nacomp ; ссылка на код
dpush 0
call _nbcomp ; тут будет лежать флаг
call _cnstr
exit
; создание нового определения
_new: ;( / name --> )
call _NextToken ; NextToken
call _sHeader ; SHEADER
call _son ; ]
exit
; завершение создания определения ';'
_fin: ;( --> )
call _qcomp ; ?COMP
call _cexit ; COMPILE EXIT
call _soff ; [
exit
;
_created: ;( asc # --> )
call _ecreate ; ;CREATE
call _sHeader ; SHEADER
dpush _create ; ['] (CREATE)
call _ctoken ; TOKEN,
exit
;
_create_: ;( / name --> )
call _NextToken ; NextToken
call _created ; CREATED
exit
;
_variable: ;( / name --> )
call _create_ ; CREATE
apush 0 ; a: 0
call _acomp ; A,
exit
;-------------------------------------------------------------------------------
;
_query: ;( --> )
pushad
rlit 0
rpush _TIBsize+TOKEN
rlit TIB_size
rpush _tib+TOKEN
rpush dword [_STDIN+TOKEN]
call [ReadFile]
popad
mov dword [_IN+TOKEN], 0
exit
;
_type: ;( d: addr d: # --> # )
pushad
lea temp, [tad+CELL]
mov ebp, esp ; чтобы вызываемая ф-ция могла убрать параметры
rlit 0 ; overlap
rpush temp
rpush tos
rpush toa
rpush dword [_STDOUT+TOKEN]
call [WriteFile]
popad
apop toa ; удаляются ненужные параметры со стека адресов
dpop tos ; и данных
exit
;
_box: ;( --> a: addr ) ...][call][addr][data][align]addr:[...
apush toa
rpop temp
lea toa, [temp+ADDR]
mov temp, [temp]
jmp temp
align
;
_print: ;( a: addr --> )
fcode _count, _type
exit
;
_cr: ;( --> )
call _NewLine
call _print
exit
;
_prompt: ;( --> )
cmp dword [_STATE+TOKEN], -1
jz lab10
slit '>'
call _print
exit
lab10: slit ']'
call _print
exit
;
_ok: ;( --> )
cmp dword [_STATE+TOKEN], -1
jz lab11
slit ' Ok'
call _print
call _cr
lab11: exit
;
_qStack: ;( --> )
cmp dword [_S0+TOKEN], tad
jb lab04
cmp dword [_A0+TOKEN], taa
jb lab05
exit
lab04: ERROR 'Data stack underflow'
lab05: ERROR 'Address stack underflow'
align
;
_ViewPoint: ;( --> a: addr )
apush toa
mov toa, dword[_IN]
lea toa, [toa+_tib+TOKEN]
exit
;
_SkipDelim: ;( --> a: addr )
mov temp, dword [_IN+TOKEN]
cmp temp, dword [_TIBsize+TOKEN]
jns lab02 ; если достигнут последний байт в tib
movzx temp , byte [temp+_tib+TOKEN]
cmp temp, 0x21
jns lab02 ; если встречен первый непробельный символ
inc dword [_IN+TOKEN]
jmp _SkipDelim ; повторять, пока пробельные символы
lab02: apush toa
mov toa, [_IN+TOKEN]
lea toa, [toa+_tib+TOKEN]
exit
;
_SkipUpTo: ;( d: char --> a: addr )
mov temp, dword [_IN+TOKEN]
cmp temp, dword [_TIBsize+TOKEN]
jns lab03 ; если достигнут последний байт в tib
movzx temp, byte [temp+_tib+TOKEN]
cmp temp, tos
jle lab03 ; если встречен первый непробельный символ
inc dword [_IN+TOKEN]
jmp _SkipUpTo ; повторять, пока пробельные символы
lab03: dpop tos
apush toa
mov toa, [_IN+TOKEN]
lea toa, [toa+_tib+TOKEN]
exit
;
_range: ;( a: a1 a2 --> d: # )
dpush tos
mov tos, dword [taa]
sub tos, toa
neg tos
apop toa
apop toa
exit
;
_NextToken: ;( --> a: addr d: # )
call _SkipDelim
call _adup
dlit 0x20
call _SkipUpTo
call _range
exit
;
_char: ;( a: addr d: # --> d: char )
call _NextToken
movzx tos, byte [toa]
apop toa
exit
;
_error: ;( a: asc d: # --> )
call _type
call _cr
jmp _abort
;
;-------------------------------------------------------------------------------
;
_quest: ;( a: addr d: # --> a: lfa | nil )
rpush taa
mov taa, dword [_last+TOKEN]
lab0A: or taa, taa
jz lab09 ; если в списке не осталось слов
; toa = sample tos = # taa = exsample
cmp AL, byte [taa+ADDR+CELL+SCNT]
jnz lab0B ; если длины не равны
mov cnt, tos
lab0C: ; cmp byte [temp+cnt+ADDR+CELL+1],
mov DL, byte [taa+cnt+ADDR+CELL+SCNT]
cmp DL, byte [toa+cnt-1]
jnz lab0B
dec cnt
jnz lab0C ; проверка до последнего символа
lab09: mov toa, taa
rpop taa
dpop tos
exit
lab0B: mov taa, [taa] ; на предыдущее слово
jmp lab0A
align
;
_tick: ;( / name --> a: xt )
call _NextToken
call _quest
or toa, toa
jnz lab12
ERROR 'Cannot find name!'
lab12: mov toa, [toa+ADDR]
exit
;
_qcomp: ;( --> )
MOV cnt, [_STATE+TOKEN]
JCXZ lab13
exit
lab13: ERROR 'For compile mode only!'
align
;
_unique: ;( a: addr d: # --> )
apush toa
dpush tos
call _quest
or toa, toa
jnz lab14
apop toa
exit
lab14: MESSAGE 'Name not unique!'
align
;
_regular: ;( a: xt --> )
cmp dword [_STATE+TOKEN], 0
jz lab08
call _ctoken
exit
lab08: call _execute
exit
;
_xtimm: ;( a: lfa --> a: xt d: flag )
dpush tos
movsx tos, byte [toa+ADDR+ADDR]
mov toa, [toa+ADDR]
exit
;
_EvalToken: ;( a: asc d: # --> )
call _quest ; a: lfa
or toa, toa ; если не найдено, в toa хранится nil
jnz lab06
ERROR 'Name not found!'
lab06:
call _xtimm ;( a: lfa --> a: lfa d: flag )
or tos, tos ;
jz lab07
dpop tos
call _execute
exit
lab07: dpop tos
call _regular
exit
;
_interpret: ;( --> )
call _NextToken ; a: a d: #
or tos, tos
jz lab01
call _EvalToken
call _qStack
jmp _interpret
lab01:
apop toa
dpop tos
exit
;
_title: ;( --> )
MESSAGE 'tri-stack forth engine.'
MESSAGE 'Copyright 2010 mOleg'
MESSAGE 'mail to mOlegg@ya.ru'
exit
;
_abort: ; переход на abort выполняется в случае ошибки
mov tar, dword [_R0+TOKEN]
mov taa, dword [_A0+TOKEN]
mov tad, dword [_S0+TOKEN]
mov dword [_STATE+TOKEN], 0
mov dword [_BASE+TOKEN], 0x0A ; десятичная система счисления
mov dword [_IN+TOKEN], 0
mov dword [_WARNING+TOKEN], -1 ; включить режим предупреждений
mov dword [_latest+TOKEN], 0 ; чтобы небыло рецидивов с ;CREATE
_quit: ; основной цикл системы
fcode _prompt, _query, _interpret, _ok
jmp _quit
align
;
_initmem: ; выделение места под стеки
rpop temp
lea taa, [tar-aStack]
lea tad, [tar-aStack-dStack]
lea tar, [tar-aStack-dStack-rStack]
rpush temp
; сохранение указателей на дно каждого из стеков
fcode _SPfetch, _S0, _Astore,\
_RPfetch, _R0, _Astore,\
_APfetch, _A0, _Astore
exit
;
_ioinit: ;( --> )
rlit -10 ; параметры функций сразу выкладываем на стек возвратов
dpush tos ; значение возвращается в EAX, который tos
call [GetStdHandle] ; GetStdHandle адресная метка, по которой хранится адрес перехода
call _STDIN
call _store
rlit -11
dpush tos
call [GetStdHandle]
call _STDOUT
call _store
rlit -12
dpush tos
call [GetStdHandle]
call _STDERR
call _store
exit
; инициализация системы
_cold:
fcode _initmem, _ioinit, _title, _MAIN, _Afetch, _execute
_bye: ;( --> )
rlit 0 ; без ошибки
_halt: ;( err --> )
call [ExitProcess]
align
_int: int3
exit
;
_limit: ; последнее слово форт-системы
call _create
_there:
allot CodeSpace-($-$$)
; ------------------------------------------------------------------------------
section '.names' data readable writeable
; Имя Метка Флаг
def 'NOOP', _noop, 0
def 'DUP', _dup, 0
def 'DROP', _drop, 0
def 'SWAP', _swap, 0
def 'OVER', _over, 0
def '+', _plus, 0
def '-', _minus, 0
def '*', _mul, 0
def 'MOD/', _moddiv, 0
def 'XOR', _xor, 0
def 'AND', _and, 0
def 'OR', _or, 0
def 'ABS', _abs, 0
def '(DLIT)', _dlit, 0
def 'ADUP', _adup, 0
def '(ALIT)', _alit, 0
def '(RLIT)', _rlit, 0
def '?NIL', _qnil, 0
def 'A+', _aadd, 0
def '(CREATE)', _create, 0
def 'A!', _Astore, 0
def 'A@', _Afetch, 0
def '!', _store, 0
def '@', _fetch, 0
def 'EXECUTE', _execute, 0
def 'BRANCH', _branch, 0
def '?BRANCH', _0branch, 0
def 'D>R', _d2r, 0
def 'RP@', _RPfetch, 0
def 'SP@', _SPfetch, 0
def 'AP@', _APfetch, 0
def 'RP!', _RPstore, 0
def 'AP!', _APstore, 0
def 'SP!', _SPstore, 0
def 'A>R', _a2r, 0
def 'RDROP', _rdrop, 0
def 'OFF', _off, 0
def 'COUNT', _count, 0
def 'ASWAP', _Aswap, 0
def 'R>A', _r2a, 0
def 'ADROP', _adrop, 0
def 'ANIP', _anip, 0
def 'B@', _bfetch, 0
def 'B!', _bstore, 0
def 'CMOVE', _cmove, 0
def 'LAST', _last, 0
def 'MAIN', _MAIN, 0
def 'HERE', _DP, 0
def 'NHERE', _NDP, 0
def 'S0', _S0, 0
def 'A0', _A0, 0
def 'R0', _R0, 0
def 'TIB', _tib, 0
def 'PAD', _pad, 0
def 'STATE', _STATE, 0
def 'BASE', _BASE, 0
def 'CURRENT', _CURRENT, 0
def 'CONTEXT', _CONTEXT, 0
def 'TIB#', _TIBsize, 0
def 'IN', _IN, 0
def 'STDIN', _STDIN, 0
def 'STDOUT', _STDOUT, 0
def 'STDERR', _STDERR, 0
def 'NewLine', _NewLine, 0
def 'QUERY', _query, 0
def 'TYPE', _type, 0
def '(BOX)', _box, 0
def 'PRINT', _print, 0
def 'CR', _cr, 0
def 'PROMPT', _prompt, 0
def 'OK', _ok, 0
def '?STACK', _qStack, 0
def 'ViewPoint', _ViewPoint, 0
def 'SkipDelim', _SkipDelim, 0
def 'SkipUpTo', _SkipUpTo, 0
def 'RANGE', _range, 0
def 'NextToken', _NextToken, 0
def 'ERROR', _error, 0
def 'QUEST', _quest, 0
def 'REGULAR', _regular, 0
def 'XTIMM', _xtimm, 0
def 'EvalToken', _EvalToken, 0
def 'INTERPRET', _interpret, 0
def 'TITLE', _title, 0
def 'ABORT', _abort, 0
def 'QUIT', _quit, 0
def 'BYE', _bye, 0
def 'HALT', _halt, 0
def 'RESERVE', _reserve, 0
def 'CELL', _cell, 0
def 'ADDR', _addr, 0
def 'TOKEN', _token, 0
def 'RET,', _cexit, 0
def 'SCNT', _scnt, 0
def 'REF', _ref, 0
def 'HERE', _here, 0
def 'NHERE', _nhere, 0
def 'ATOD', _atod, 0
def 'B,', _cbyte, 0
def 'REF,', _cref, 0
def ',', _dcomp, 0
def 'A,', _acomp, 0
def 'NA,', _nacomp, 0
def 'NB,', _nbcomp, 0
def 'N,', _nccomp, 0
def 'NS,', _cns, 0
def 'NSTR,', _cnstr, 0
def 'S,', _cs, 0
def 'STR,', _cstr, 0
def 'ALIT,', _calit, 0
def '[', _soff, 1
def ']', _son, 0
def "'", _tick, 0
def '?COMP', _qcomp, 0
def 'WARNING', _WARNING, 0
def '?UNIQUE', _unique, 0
def 'TOKEN,', _ctoken, 0
def '<#', _lbdiez, 0
def '#>', _diezrb, 0
def 'HOLD', _hold, 0
def '>DIGIT', _digit, 0
def '#', _diez, 0
def 'S#', _sdiez, 0
def '(U)', _unum, 0
def 'U.', _snumt, 0
def 'SIGN', _sign, 0
def 'CHAR', _char, 0
def '>CIPHER', _2cipher, 0
def 'sval', _val, 0
def 'd:', _dnum, 1
def 'a:', _anum, 1
def ':', _new, 0
def ';', _fin, 1
def 'SHEADER', _sHeader, 0
def 'LATEST', _latest, 0
def 'LIT,', _clit, 0
def 'LITERAL', _literal, 0
def ';CREATE', _ecreate, 0
def 'CREATED', _created, 0
def 'CREATE', _create_, 0
def 'VARIABLE', _variable, 0
def 'ROUND', _round, 0
def 'ALIGN', _align, 0
def 'int', _int, 0
LATEST: ; чтобы получить хвост цепочки имен
def 'LIMIT',_limit,0
NSADDR:
allot NamesSpace-($-$$) ;