ну и получающийся asm файл
Код:
format PE console
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'
; типы данных
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 ; размер стека данных
rStack equ 0x1000 ; размер стека возвратов
NamesSpace = 0x10000
CodeSpace = 0x10000
; вычисляем сколько места надо выделять под стеки
stack (dStack+rStack)*2, dStack+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
}
allot equ rb
macro align
{ repeat (($+CELL-1)and -CELL)-$
nop
end repeat }
macro trialign
{ repeat (($+CELL-1)and -CELL)-$+3
nop
end repeat }
section '.fvm' code executable readable writeable
; первое определение
align
_NOOP: ; ( --> )
RET
; удалить элемент под вершиной стека
align
_NIP: ; ( a b --> b )
LEA EBP, [EBP+CELL]
RET
; удалить значение с вершины стека данных
align
_DROP: ; ( n --> )
MOV EAX, [EBP]
LEA EBP, [EBP+CELL]
RET
; удалить d с вершины стека данных
align
_DDROP: ; ( d --> )
MOV EAX, [EBP+CELL]
LEA EBP, [EBP+CELL*2]
RET
; дублировать значение n на вершине стека данных
align
_DUP: ; ( n --> n n )
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
RET
; дублировать значение d на вершине стека данных
align
_DDUP: ; ( d --> d d )
MOV EDX, [EBP]
MOV [EBP-CELL], EAX
MOV [EBP-CELL*2], EDX
LEA EBP, [EBP-CELL*2]
RET
; обменять значения двух ячеек на вершине стека данных
align
_SWAP: ; ( a b --> b a )
MOV EDX, EAX
MOV EAX, [EBP]
MOV dword [EBP], EDX
RET
; положить на вершину стека данных копию значения второго элемента
align
_OVER: ; ( a b --> a b a )
MOV EDX, [EBP]
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
MOV EAX, EDX
RET
; Прокрутить три верхних элемента стека.
align
_ROT: ; ( a b c --> b c a )
MOV EDX, [EBP]
MOV [EBP], EAX
MOV EAX, [EBP+CELL]
MOV dword [EBP+CELL], EDX
RET
; извлечь значение с указанного адреса
align
_Fetch: ; ( addr --> n )
MOV EAX, [EAX]
RET
; сохранить значение n по указанному адресу
align
_Store: ; ( n addr --> )
MOV EDX, [EBP]
MOV dword [EAX], EDX
MOV EAX, [EBP+CELL]
LEA EBP, [EBP+8]
RET
; извлечь значение байта b по указанному адресу addr
align
_BFetch: ; ( addr --> b )
MOVZX EAX, byte [EAX]
RET
; сохранить значение байта b по указанному адресу addr
align
_BStore: ; ( b addr --> )
MOV EDX, [EBP]
MOV byte [EAX], DL
MOV EAX, [EBP+CELL]
LEA EBP, [EBP+8]
RET
; сложить два числа на вершине стека данных, результат оставить на вершине
align
_Plus: ; ( n1 n2 --> n )
ADD EAX, [EBP]
LEA EBP, [EBP+CELL]
RET
; сложить два числа на вершине стека данных, результат оставить на вершине
align
_Minus: ; ( n1 n2 --> n )
MOV EDX, [EBP]
SUB EDX, EAX
MOV EAX, EDX
LEA EBP, [EBP+CELL]
RET
; знаковое деление чисел одинарной длины
align
_Slash: ; ( na nb --> n )
MOV ECX, EAX
MOV EAX, [EBP]
CDQ
IDIV ECX
LEA EBP, [EBP+CELL]
RET
; логическое или над двумя операндами на вершине стека даных
align
_OR: ; ( na nb --> n )
OR EAX, [EBP]
LEA EBP, [EBP+CELL]
RET
; поделить беззнаковое число двойной точности
; на беззнаковое число одинарной точности
; результат - частное и остаток от деления
align
_UMSlashMOD: ; ( ud u1 --> div mod )
MOV ECX, EAX
MOV EDX, [EBP]
MOV EAX, [EBP+CELL]
DIV ECX
LEA EBP, [EBP+CELL]
MOV dword [EBP], EDX
RET
; Преобразовать число n в двойное число d с тем же числовым значением.
align
_SToD: ; ( n --> d )
CDQ
LEA EBP, [EBP-CELL]
MOV [EBP], EAX
MOV EAX, EDX
RET
; найти абсолютное значение числа
align
_ABS: ; ( n --> u )
MOV EDX, EAX
SAR EDX, 31
ADD EAX, EDX
XOR EAX, EDX
RET
; оставить минимальное n из двух чисел na, nb на вершине стека данных
align
_MIN: ; ( na nb --> n )
CMP EAX, [EBP]
JL _2st
MOV EAX, [EBP]
_2st: LEA EBP, [EBP+CELL]
RET
; увеличить значение, хранящееся по addr на n,
; результат сохранить по addr и оставить на вершине стека данных
align
_PlusStoreFetch: ; ( n addr --> x+n )
MOV EDX, [EAX]
ADD EDX, [EBP]
MOV dword [EAX], EDX
MOV EAX, EDX
LEA EBP, [EBP+CELL]
RET
; переместить указатель вершины стека данных на указанный адрес
; в TOS остается значение
align
_SPStore: ; ( addr --> )
MOV EBP, EAX
RET
; вернуть адрес вершины стека данных
align
_SPFetch: ; ( --> addr )
MOV EDX, EAX
MOV EAX, EBP
LEA EBP, [EBP-CELL]
MOV dword [EBP], EDX
RET
; переместить указатель вершины стека возвратов на указанный адрес
align
_RPStore: ; ( addr --> )
POP EDX
MOV ESP, EAX
MOV EAX, [EBP]
LEA EBP, [EBP+CELL]
JMP EDX
; вернуть адрес вершины стека возвратов
align
_RPFetch: ; ( --> addr )
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
MOV EAX, ESP
RET
; перенести значение с вершины стека данных на вершину стека возвратов
align
_ToR: ; ( addr --> r: addr )
POP EDX
PUSH EAX
MOV EAX, [EBP]
LEA EBP, [EBP+CELL]
JMP EDX
RET
; перенести значение с вершины стека возвратов на вершину стека данных
align
_RTo: ; ( r: addr --> addr )
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
POP EDX
POP EAX
JMP EDX
RET
; выложить на вершину стека данных значение,
; скомпилированное в коде за вызовом (LIT)
align
_lParLITrPar: ; ( --> n )
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
POP EAX
LEA EDX, [EAX+CELL]
MOV EAX, [EAX]
JMP EDX
; выложить на вершину стека данных значение,
; скомпилированное в коде за вызовом (LIT)
align
_lParDLITrPar: ; ( --> n )
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
POP EAX
LEA EDX, [EAX+CELL]
MOV EAX, [EAX]
JMP EDX
; вернуть адрес слова, вызов которого скомпилирован в коде вслед за (')
align
_lParTickrPar: ; ( --> addr )
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
POP EAX
LEA EDX, [EAX+TOKEN]
MOV EAX, [EAX+1]
JMP EDX
; вернуть адрес начала строки asc, размещенной в коде за (SLIT), и ее длину #
align
_lParSLITrPar: ; ( --> asc # )
LEA EBP, [EBP-8]
MOV dword [EBP+CELL], EAX
POP EBX
LEA EDX, [EBX+CELL]
MOV dword [EBP], EDX
MOV EAX, [EBX]
LEA EDX, [EBX+EAX+TOKEN]
JMP EDX
; положить на вершину стека адрес переменной
align
_lParCREATErPar: ; ( --> addr )
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
POP EAX
RET
; положить на вершину стека значение
align
_lParCONSTANTrPar: ; ( --> n )
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
POP EAX
MOV EAX, [EAX]
RET
; проверка числа на 0
align
_0Equal: ; ( n --> flag )
SUB EAX, 1
SBB EAX, EAX
RET
; сравнить числа na и nb
align
_To: ; ( na nb --> flag )
CMP EAX, [EBP]
SETGE AL
AND EAX, 1
DEC EAX
LEA EBP, [EBP+CELL]
RET
align
_UTo: ; ( ua ub --> flag )
CMP EAX, [EBP]
SBB EAX, EAX
LEA EBP, [EBP+CELL]
RET
; сравнить числа na и nb
align
_Less: ; ( na nb --> flag )
CMP EAX, [EBP]
SETLE AL
AND EAX, 1
DEC EAX
LEA EBP, [EBP+CELL]
RET
; выйти из текущего определения
align
_EXIT: ; ( --> )
LEA ESP, [ESP+CELL]
RET
; безусловное ветвление
align
_BRANCH: ; ( --> )
POP EDX
JMP dword [EDX]
; условное ветвление
align
_QuestionBRANCH: ; ( n --> n )
OR EAX, EAX
MOV EAX, [EBP]
LEA EBP, [EBP+CELL]
JZ _BRANCH
POP EDX
LEA EDX, [EDX+CELL]
JMP EDX
; условное ветвление
align
_NQuestionBRANCH: ; ( n --> n )
OR EAX, EAX
MOV EAX, [EBP]
LEA EBP, [EBP+CELL]
JNZ _BRANCH
POP EDX
LEA EDX, [EDX+CELL]
JMP EDX
; размер буферов TIB и PAD в байтах
trialign
_TIBSize: CALL _lParCONSTANTrPar
dd 0x100
; ( --> # )
trialign
_PADSize: CALL _lParCONSTANTrPar
dd 0x100
; ( --> #)
; terminal input buffer
trialign
_TIB: CALL _lParCREATErPar
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
; указатель на первый неразобранный символ во входном буфере
trialign
_ToIN: CALL _lParCREATErPar
dd 0
; указатель на последний введенный символ
trialign
_SizeTIB: CALL _lParCREATErPar
dd 0
; Дно стека данных
trialign
_S0: CALL _lParCREATErPar
dd 0
; ( --> addr )
; Дно стека возвратов
trialign
_R0: CALL _lParCREATErPar
dd 0
; ( --> addr )
; размеры стеков
trialign
_DataStackSize: CALL _lParCONSTANTrPar
dd 0x1000
trialign
_ReturnStackSize: CALL _lParCONSTANTrPar
dd 0x1000
; Хранит адрес первой свободной ячейки памяти в пространстве кода и данных
trialign
_DP: CALL _lParCREATErPar
dd 0
; ( --> addr )
; Хранит адрес первой свободной ячейки памяти в пространстве имен
trialign
_HDP: CALL _lParCREATErPar
dd 0
; ( --> addr )
; стандартные потоки В\В
trialign
_STDIN: CALL _lParCREATErPar
dd 0
; входной
trialign
_STDOUT: CALL _lParCREATErPar
dd 0
; выходной
trialign
_STDERR: CALL _lParCREATErPar
dd 0
; выходной для ошибок
; флаг необходимости извещения о повторном использовании уже существующего имени определения
trialign
_WARNING: CALL _lParCREATErPar
dd 0
; текущее состоянии системы (интерпретация\компиляция)
trialign
_STATE: CALL _lParCREATErPar
dd 0
; переключение состояния системы
align
_lStap: ; ( --> )
CALL _lParLITrPar
dd 0x0
CALL _STATE
CALL _Store
RET
align
_rStap: ; ( --> )
CALL _lParLITrPar
dd 0xFFFFFFFF
CALL _STATE
CALL _Store
RET
trialign
_CELL: CALL _lParCONSTANTrPar
dd 0x4
; размер ячейки, байт
trialign
_ADDR: CALL _lParCONSTANTrPar
dd 0x4
; размер адресной ссылки, байт
; преобразовать значение количетсва ячеек в количество минимально адресуемых единиц (байт)
align
_CELLS: ; ( u --> # )
SAR EAX, 2
RET
; вернуть адрес первой свободной ячейки памят в пространстве кода и данных
align
_HERE: ; ( --> addr )
CALL _DP
MOV EAX, [EAX]
RET
; вернуть адрес первой свободной ячейки памят в пространстве имен
align
_HHERE: ; ( haddr --> addr )
CALL _HDP
MOV EAX, [EAX]
RET
; добавить в конец файла fid содержимое строки Asc #
align
_WRITEMinusFILE: ; ( asc # fid --> # )
CALL _ToR
CALL _ToR
CALL _ToR
CALL _lParLITrPar
dd 0x0
MOV EDX, EAX
MOV EAX, EBP
LEA EBP, [EBP-CELL]
MOV dword [EBP], EDX
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
CALL _RTo
CALL _RTo
MOV EDX, EAX
MOV EAX, [EBP]
MOV dword [EBP], EDX
CALL _RTo
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
MOV EAX, dword [WriteFile]
MOV dword [fs:0x14], ESP
MOV ESP, EBP
CALL EAX
MOV EBP, ESP
MOV ESP, dword [fs:0x14]
LEA EBP, [EBP+CELL]
MOV EAX, [EBP]
LEA EBP, [EBP+CELL]
RET
; читать в буфер asc строку длиной не более # символов содержимое файла fid
align
_READMinusFILE: ; ( asc # fid --> # )
CALL _ToR
CALL _ToR
CALL _ToR
CALL _lParLITrPar
dd 0x0
MOV EDX, EAX
MOV EAX, EBP
LEA EBP, [EBP-CELL]
MOV dword [EBP], EDX
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
CALL _RTo
CALL _RTo
MOV EDX, EAX
MOV EAX, [EBP]
MOV dword [EBP], EDX
CALL _RTo
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
MOV EAX, dword [ReadFile]
MOV dword [fs:0x14], ESP
MOV ESP, EBP
CALL EAX
MOV EBP, ESP
MOV ESP, dword [fs:0x14]
LEA EBP, [EBP+CELL]
MOV EAX, [EBP]
LEA EBP, [EBP+CELL]
RET
; вывести в текущий STDOUT поток указанную строку
align
_TYPE: ; ( asc # --> )
CALL _STDOUT
MOV EAX, [EAX]
CALL _WRITEMinusFILE
MOV EAX, [EBP]
LEA EBP, [EBP+CELL]
RET
; вывести символ в текущий поток В\В
align
_EMIT: ; ( char --> )
MOV EDX, EAX
MOV EAX, EBP
LEA EBP, [EBP-CELL]
MOV dword [EBP], EDX
CALL _lParLITrPar
dd 0x1
CALL _TYPE
MOV EAX, [EBP]
LEA EBP, [EBP+CELL]
RET
; текущая система счисления
trialign
_BASE: CALL _lParCREATErPar
dd 0
; переключения системы счисления
align
_DECIMAL: ; ( --> )
CALL _lParLITrPar
dd 0xA
CALL _BASE
CALL _Store
RET
align
_HEX: ; ( --> )
CALL _lParLITrPar
dd 0x10
CALL _BASE
CALL _Store
RET
; буфер для форматного преобразования чисел и строк
trialign
_PAD: CALL _lParCREATErPar
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
; буфер обычно заполняется с конца, поэтому необходим адрес конца буфера
PadTop: ; указатель на последний символ в PAD
trialign
_HLD: CALL _lParCREATErPar
dd 0
; начать форматное преобразование строки
align
_LessSize: ; ( --> )
CALL _lParLITrPar
dd PadTop
CALL _HLD
CALL _Store
RET
; задать текущую систему счисления и начать форматное преобразование строки
align
_lBrSize: ; ( base --> )
CALL _BASE
CALL _Store
CALL _LessSize
RET
; завершить форматное преобразование строки, вернуть адрес asc и длину # полученной строки
align
_SizerBr: ; ( --> asc # )
CALL _HLD
MOV EAX, [EAX]
CALL _PAD
CALL _PADSize
CALL _Plus
MOV EDX, [EBP]
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
MOV EAX, EDX
CALL _Minus
RET
; то же, что и #}, только предварительно удаляет число двойной длины с вершины стека данных
align
_SizeTo: ; ( d --> asc # )
LEA EBP, [EBP+CELL]
MOV EAX, [EBP]
LEA EBP, [EBP+CELL]
CALL _SizerBr
RET
; добавляет символ char в позицию HLD, сам HLD уменьшает на размер одного символа
align
_HOLD: ; ( char --> )
CALL _lParLITrPar
dd 0xFFFFFFFF
CALL _HLD
CALL _PlusStoreFetch
CALL _BStore
RET
; -1 HLD @ + PAD UMAX DUP HLD ! B!
; преобразовать число в символ
; число не должно превышать значение находящееся в BASE
align
_ToDIGIT: ; ( u --> char )
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
CALL _lParLITrPar
dd 0x9
CALL _To
CALL _QuestionBRANCH
dd lab_0001
CALL _lParLITrPar
dd 0x7
CALL _Plus
lab_0001:
CALL _lParLITrPar
dd 0x30
CALL _Plus
RET
; добавить в буфер PAD остаток от деления двойного числа на содержимое BASE
align
_Size: ; ( ud1 --> ud2 )
CALL _lParLITrPar
dd 0x0
CALL _BASE
MOV EAX, [EAX]
MOV ECX, EAX
MOV EDX, [EBP]
MOV EAX, [EBP+CELL]
DIV ECX
LEA EBP, [EBP+CELL]
MOV dword [EBP], EDX
CALL _ToR
CALL _BASE
MOV EAX, [EAX]
MOV ECX, EAX
MOV EDX, [EBP]
MOV EAX, [EBP+CELL]
DIV ECX
LEA EBP, [EBP+CELL]
MOV dword [EBP], EDX
CALL _RTo
MOV EDX, [EBP]
MOV [EBP], EAX
MOV EAX, [EBP+CELL]
MOV dword [EBP+CELL], EDX
CALL _ToDIGIT
CALL _HOLD
RET
; Если n отрицательно, добавить в PAD символ '-'
align
_SIGN: ; ( n --> )
CALL _lParLITrPar
dd 0x0
CALL _Less
CALL _QuestionBRANCH
dd lab_0002
CALL _lParLITrPar
dd 0x2D
CALL _HOLD
lab_0002:
RET
; преобразовать число двойной длинны в строку
align
_SizeS: ; ( ud --> 0 0 )
lab_0003: ; метка для перехода назад
CALL _Size
MOV EDX, [EBP]
MOV [EBP-CELL], EAX
MOV [EBP-CELL*2], EDX
LEA EBP, [EBP-CELL*2]
OR EAX, [EBP]
LEA EBP, [EBP+CELL]
CALL _QuestionBRANCH
dd lab_0004
JMP lab_0003 ; переход назад
lab_0004:
RET
; константы значения спецсимволов
trialign
_Bl_: CALL _lParCONSTANTrPar
dd 0x20
trialign
_Cr_: CALL _lParCONSTANTrPar
dd 0xA
trialign
_Lf_: CALL _lParCONSTANTrPar
dd 0xD
; преобразовать число одинарной длинны в строку
; в десятичной системе независимо от значения BASE
align
_lParPeroidrPar: ; ( n --> asc # )
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
CALL _ToR
MOV EDX, EAX
SAR EDX, 31
ADD EAX, EDX
XOR EAX, EDX
CDQ
LEA EBP, [EBP-CELL]
MOV [EBP], EAX
MOV EAX, EDX
CALL _LessSize
CALL _SizeS
CALL _RTo
CALL _SIGN
CALL _SizeTo
RET
; вывести число в текущей системе счисления в выходной поток
align
_Peroid: ; ( n --> )
CALL _lParPeroidrPar
CALL _TYPE
RET
; перевод строки
align
_CR: ; ( --> )
CALL _lParSLITrPar
dd 0x2
db 0xD,0xA,0x00
CALL _TYPE
RET
; текущая глубина стека данных
align
_DEPTH: ; ( --> n )
MOV EDX, EAX
MOV EAX, EBP
LEA EBP, [EBP-CELL]
MOV dword [EBP], EDX
CALL _S0
MOV EAX, [EAX]
MOV EDX, EAX
MOV EAX, [EBP]
MOV dword [EBP], EDX
CALL _Minus
CALL _CELL
MOV ECX, EAX
MOV EAX, [EBP]
CDQ
IDIV ECX
LEA EBP, [EBP+CELL]
RET
; приглашение
align
_PROMPT: ; ( --> )
CALL _DEPTH
CALL _Peroid
CALL _STATE
MOV EAX, [EAX]
CALL _QuestionBRANCH
dd lab_0005
CALL _lParSLITrPar
dd 0x1
db 0x5D,0x00
CALL _BRANCH
dd lab_0006
lab_0005:
CALL _lParSLITrPar
dd 0x1
db 0x5B,0x00
lab_0006:
CALL _TYPE
RET
; получить очередную строку из STDIN в буфер TIB
align
_QUERY: ; ( --> )
CALL _TIB
CALL _TIBSize
CALL _STDIN
MOV EAX, [EAX]
CALL _READMinusFILE
CALL _SizeTIB
CALL _Store
CALL _lParLITrPar
dd 0x0
CALL _ToIN
CALL _Store
RET
; -- парсер --------------------------------------------------------------------
; является ли символ char пробельным
align
_nQuestionsep: ; ( char --> flag )
CALL _Bl_
CALL _To
RET
; адрес первого неразобранного символа
align
_CharAddr: ; ( --> addr )
CALL _TIB
CALL _ToIN
MOV EAX, [EAX]
CALL _Plus
RET
; прочесть символ из текущего значения >IN
align
_PeekChar: ; ( --> char )
CALL _CharAddr
MOVZX EAX, byte [EAX]
RET
; пропустить один символ во входном потоке
align
_SkipChar: ; ( --> )
CALL _ToIN
MOV EAX, [EAX]
CALL _lParLITrPar
dd 0x1
CALL _Plus
CALL _SizeTIB
MOV EAX, [EAX]
CALL _MIN
CALL _ToIN
CALL _Store
RET
; вернуть TRUE если весь текст уже разобран
align
_QuestionCOMPLETE: ; ( --> flag )
CALL _SizeTIB
MOV EAX, [EAX]
CALL _ToIN
MOV EAX, [EAX]
CALL _Less
RET
; взять очередной символ из входного потока
; flag = TRUE если входной поток исчерпан
align
_NextChar: ; ( --> char flag )
CALL _PeekChar
CALL _QuestionCOMPLETE
CALL _SkipChar
RET
; пропустить все символы разделители до первого значащего символа,
; либо до конца разбираемой строки
align
_MissSeparators: ; ( --> )
INT3
lab_0007: ; метка для перехода назад
CALL _NextChar
CALL _NQuestionBRANCH
dd lab_0008
CALL _nQuestionsep
CALL _NQuestionBRANCH
dd lab_0009
JMP lab_0007 ; переход назад
lab_0009:
CALL _EXIT
lab_0008:
MOV EAX, [EBP]
LEA EBP, [EBP+CELL]
RET
; пропустить текст вплодь до разделителя
align
_MissLexeme: ; ( --> )
INT3
lab_000A: ; метка для перехода назад
CALL _NextChar
CALL _NQuestionBRANCH
dd lab_000B
CALL _nQuestionsep
CALL _QuestionBRANCH
dd lab_000C
JMP lab_000A ; переход назад
lab_000C:
CALL _EXIT
lab_000B:
MOV EAX, [EBP]
LEA EBP, [EBP+CELL]
RET
; выделить из буфера блок символов вплоть до разделителя
align
_PassLexeme: ; ( --> asc # )
CALL _CharAddr
CALL _MissLexeme
CALL _CharAddr
MOV EDX, [EBP]
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
MOV EAX, EDX
CALL _Minus
RET
; Получить адрес и длину очередной лексемы
align
_NextWord: ; ( --> asc # )
CALL _MissSeparators
CALL _PassLexeme
RET
trialign
_WORDLISTS: CALL _lParCONSTANTrPar
dd 0x10
; количество словарей в системе
; текущий словарь ( в который ведется добавление имен)
trialign
_CURRENT: CALL _lParCREATErPar
dd 0
; стек словарей для поиска
trialign
_CONTEXT: CALL _lParCREATErPar
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
CNSP: ; вершина списка словарей
; сделать верхний текущий словарь контекстным
align
_DEFINITIONS: ; ( --> )
CALL _CONTEXT
MOV EAX, [EAX]
CALL _CURRENT
CALL _Store
RET
; !!! написать нормально
; идентификатор словаря FORTH
align
_FORTHMinusWORDLIST: ; ( --> wid )
CALL _lParLITrPar
dd 0x1
RET
; !!! написать нормально
; инициализация контекста
align
_ONLY: ; ( --> )
CALL _FORTHMinusWORDLIST
CALL _CONTEXT
CALL _Store
RET
; !!! написать нормально
; выполнить действие над очередной лексемой
align
_EVALMinusTOKEN: ; ( asc # --> )
CALL _CR
CALL _TYPE
RET
; интерпретировать входной поток
; : INTERPRET ( --> ) BEGIN NextWord DUP WHILE EVAL-TOKEN REPEAT DDROP ;
align
_INTERPRET: ; ( --> )
CALL _TIB
CALL _SizeTIB
MOV EAX, [EAX]
CALL _TYPE
CALL _CR
RET
; проверка протекания стека данных
align
_QuestionSTACK: ; ( --> )
MOV EDX, EAX
MOV EAX, EBP
LEA EBP, [EBP-CELL]
MOV dword [EBP], EDX
CALL _S0
MOV EAX, [EAX]
CMP EAX, [EBP]
SBB EAX, EAX
LEA EBP, [EBP+CELL]
CALL _QuestionBRANCH
dd lab_000D
CALL _lParSLITrPar
dd 0x1A
db 0x88,0xE1,0xE7,0xA5,0xE0,0xAF,0xA0,0xAD,0xA8,0xA5,0x20
db 0xE1,0xE2,0xA5,0xAA,0xA0,0x20,0xA4,0xA0,0xAD,0xAD,0xEB,0xE5,0x21,0xD,0xA,0x00
CALL _TYPE
CALL _S0
MOV EAX, [EAX]
CALL _SPStore
lab_000D:
RET
; основной цикл системы
align
_QUIT: ; ( --> )
CALL _lStap
CALL _DECIMAL
CALL _CR
lab_000E: ; метка для перехода назад
CALL _PROMPT
CALL _QUERY
CALL _INTERPRET
CALL _QuestionSTACK
JMP lab_000E ; переход назад
RET
; инициализация системы после ошибки
align
_ABORT: ; ( --> )
CALL _S0
MOV EAX, [EAX]
CALL _SPStore
CALL _R0
MOV EAX, [EAX]
CALL _RPStore
CALL _ONLY
CALL _DEFINITIONS
CALL _QUIT
RET
; инициализация идентификаторов потоков В/В
align
_INITMinusIO: ; ( --> )
CALL _lParLITrPar
dd 0xFFFFFFF6
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
MOV EAX, dword [GetStdHandle]
MOV dword [fs:0x14], ESP
MOV ESP, EBP
CALL EAX
MOV EBP, ESP
MOV ESP, dword [fs:0x14]
LEA EBP, [EBP+CELL]
CALL _STDIN
CALL _Store
CALL _lParLITrPar
dd 0xFFFFFFF5
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
MOV EAX, dword [GetStdHandle]
MOV dword [fs:0x14], ESP
MOV ESP, EBP
CALL EAX
MOV EBP, ESP
MOV ESP, dword [fs:0x14]
LEA EBP, [EBP+CELL]
CALL _STDOUT
CALL _Store
CALL _lParLITrPar
dd 0xFFFFFFF4
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
MOV EAX, dword [GetStdHandle]
MOV dword [fs:0x14], ESP
MOV ESP, EBP
CALL EAX
MOV EBP, ESP
MOV ESP, dword [fs:0x14]
LEA EBP, [EBP+CELL]
CALL _STDERR
CALL _Store
RET
; приветствие после запуска системы
align
_TITLE: ; ( --> )
CALL _lParSLITrPar
dd 0xA
db 0xD,0xA,0x48,0x65,0x6C,0x6C,0x6F,0x21,0xD,0xA,0x00
CALL _TYPE
RET
; сделать вектором!
align
_MAIN: ; ( --> )
CALL _TITLE
RET
; холодный запуск системы
align
_COLD: ; ( --> )
LEA EBP, [EBP-256]
; для начала раздвигаются указатели стеков
CALL _RPFetch
LEA EBP, [EBP-CELL]
MOV dword [EBP], EAX
CALL _R0
CALL _Store
; стек возвратов под стеком данных используется для хранения
; только внутренних вызовов, т.к. АПИ очень сильно жрет стек
CALL _ReturnStackSize
CALL _Minus
CALL _S0
CALL _Store
CALL _INITMinusIO
CALL _DECIMAL
CALL _MAIN
CALL _ABORT
RET
; последнее определение системы
trialign
_FENCE: CALL _lParCREATErPar
; ( --> )
entry _COLD ; точка входа
section '.names' data readable writeable
; makevoc FORTH
; Имя, Метка, Флаг immediate
def 'FENCE', _FENCE, 1
def 'COLD', _COLD, 1
def 'MAIN', _MAIN, 1
def 'TITLE', _TITLE, 1
def 'INIT-IO', _INITMinusIO, 1
def 'ABORT', _ABORT, 1
def 'QUIT', _QUIT, 1
def '?STACK', _QuestionSTACK, 1
def 'INTERPRET', _INTERPRET, 1
def 'EVAL-TOKEN', _EVALMinusTOKEN, 1
def 'ONLY', _ONLY, 1
def 'FORTH-WORDLIST', _FORTHMinusWORDLIST, 1
def 'DEFINITIONS', _DEFINITIONS, 1
def 'CONTEXT', _CONTEXT, 1
def 'CURRENT', _CURRENT, 1
def 'WORDLISTS', _WORDLISTS, 1
def 'NextWord', _NextWord, 1
def 'PassLexeme', _PassLexeme, 1
def 'MissLexeme', _MissLexeme, 1
def 'MissSeparators', _MissSeparators, 1
def 'NextChar', _NextChar, 1
def '?COMPLETE', _QuestionCOMPLETE, 1
def 'SkipChar', _SkipChar, 1
def 'PeekChar', _PeekChar, 1
def 'CharAddr', _CharAddr, 1
def 'n?sep', _nQuestionsep, 1
def 'QUERY', _QUERY, 1
def 'PROMPT', _PROMPT, 1
def 'DEPTH', _DEPTH, 1
def 'CR', _CR, 1
def '.', _Peroid, 1
def '(.)', _lParPeroidrPar, 1
def 'Lf_', _Lf_, 1
def 'Cr_', _Cr_, 1
def 'Bl_', _Bl_, 1
def '#S', _SizeS, 1
def 'SIGN', _SIGN, 1
def '#', _Size, 1
def '>DIGIT', _ToDIGIT, 1
def 'HOLD', _HOLD, 1
def '#>', _SizeTo, 1
def '#}', _SizerBr, 1
def '{#', _lBrSize, 1
def '<#', _LessSize, 1
def 'HLD', _HLD, 1
def 'PAD', _PAD, 1
def 'HEX', _HEX, 1
def 'DECIMAL', _DECIMAL, 1
def 'BASE', _BASE, 1
def 'EMIT', _EMIT, 1
def 'TYPE', _TYPE, 1
def 'READ-FILE', _READMinusFILE, 1
def 'WRITE-FILE', _WRITEMinusFILE, 1
def 'HHERE', _HHERE, 1
def 'HERE', _HERE, 1
def 'CELLS', _CELLS, 1
def 'ADDR', _ADDR, 1
def 'CELL', _CELL, 1
def ']', _rStap, 1
def '[', _lStap, -1
def 'STATE', _STATE, 1
def 'WARNING', _WARNING, 1
def 'STDERR', _STDERR, 1
def 'STDOUT', _STDOUT, 1
def 'STDIN', _STDIN, 1
def 'HDP', _HDP, 1
def 'DP', _DP, 1
def 'ReturnStack#', _ReturnStackSize, 1
def 'DataStack#', _DataStackSize, 1
def 'R0', _R0, 1
def 'S0', _S0, 1
def '#TIB', _SizeTIB, 1
def '>IN', _ToIN, 1
def 'TIB', _TIB, 1
def 'PAD#', _PADSize, 1
def 'TIB#', _TIBSize, 1
def 'N?BRANCH', _NQuestionBRANCH, 1
def '?BRANCH', _QuestionBRANCH, 1
def 'BRANCH', _BRANCH, 1
def 'EXIT', _EXIT, 1
def '<', _Less, 1
def 'U>', _UTo, 1
def '>', _To, 1
def '0=', _0Equal, 1
def '(CONSTANT)', _lParCONSTANTrPar, 1
def '(CREATE)', _lParCREATErPar, 1
def '(SLIT)', _lParSLITrPar, 1
def '(`)', _lParTickrPar, 1
def '(DLIT)', _lParDLITrPar, 1
def '(LIT)', _lParLITrPar, 1
def 'R>', _RTo, 1
def '>R', _ToR, 1
def 'RP@', _RPFetch, 1
def 'RP!', _RPStore, 1
def 'SP@', _SPFetch, 1
def 'SP!', _SPStore, 1
def '+!@', _PlusStoreFetch, 1
def 'MIN', _MIN, 1
def 'ABS', _ABS, 1
def 'S>D', _SToD, 1
def 'UM/MOD', _UMSlashMOD, 1
def 'OR', _OR, 1
def '/', _Slash, 1
def '-', _Minus, 1
def '+', _Plus, 1
def 'B!', _BStore, 1
def 'B@', _BFetch, 1
def '!', _Store, 1
def '@', _Fetch, 1
def 'ROT', _ROT, 1
def 'OVER', _OVER, 1
def 'SWAP', _SWAP, 1
def 'DDUP', _DDUP, 1
def 'DUP', _DUP, 1
def 'DDROP', _DDROP, 1
def 'DROP', _DROP, 1
def 'NIP', _NIP, 1
def 'NOOP', _NOOP, 1
LATEST: ; чтобы получить хвост цепочки имен
NSADDR:
allot NamesSpace-($-$$) ;
section '.edata' export data readable
export 'FORTH',\
_FENCE,'FENCE',\
_COLD,'COLD',\
_MAIN,'MAIN',\
_TITLE,'TITLE',\
_INITMinusIO,'INIT-IO',\
_ABORT,'ABORT',\
_QUIT,'QUIT',\
_QuestionSTACK,'?STACK',\
_INTERPRET,'INTERPRET',\
_EVALMinusTOKEN,'EVAL-TOKEN',\
_ONLY,'ONLY',\
_FORTHMinusWORDLIST,'FORTH-WORDLIST',\
_DEFINITIONS,'DEFINITIONS',\
_CONTEXT,'CONTEXT',\
_CURRENT,'CURRENT',\
_WORDLISTS,'WORDLISTS',\
_NextWord,'NextWord',\
_PassLexeme,'PassLexeme',\
_MissLexeme,'MissLexeme',\
_MissSeparators,'MissSeparators',\
_NextChar,'NextChar',\
_QuestionCOMPLETE,'?COMPLETE',\
_SkipChar,'SkipChar',\
_PeekChar,'PeekChar',\
_CharAddr,'CharAddr',\
_nQuestionsep,'n?sep',\
_QUERY,'QUERY',\
_PROMPT,'PROMPT',\
_DEPTH,'DEPTH',\
_CR,'CR',\
_Peroid,'.',\
_lParPeroidrPar,'(.)',\
_Lf_,'Lf_',\
_Cr_,'Cr_',\
_Bl_,'Bl_',\
_SizeS,'#S',\
_SIGN,'SIGN',\
_Size,'#',\
_ToDIGIT,'>DIGIT',\
_HOLD,'HOLD',\
_SizeTo,'#>',\
_SizerBr,'#}',\
_lBrSize,'{#',\
_LessSize,'<#',\
_HLD,'HLD',\
_PAD,'PAD',\
_HEX,'HEX',\
_DECIMAL,'DECIMAL',\
_BASE,'BASE',\
_EMIT,'EMIT',\
_TYPE,'TYPE',\
_READMinusFILE,'READ-FILE',\
_WRITEMinusFILE,'WRITE-FILE',\
_HHERE,'HHERE',\
_HERE,'HERE',\
_CELLS,'CELLS',\
_ADDR,'ADDR',\
_CELL,'CELL',\
_rStap,']',\
_lStap,'[',\
_STATE,'STATE',\
_WARNING,'WARNING',\
_STDERR,'STDERR',\
_STDOUT,'STDOUT',\
_STDIN,'STDIN',\
_HDP,'HDP',\
_DP,'DP',\
_ReturnStackSize,'ReturnStack#',\
_DataStackSize,'DataStack#',\
_R0,'R0',\
_S0,'S0',\
_SizeTIB,'#TIB',\
_ToIN,'>IN',\
_TIB,'TIB',\
_PADSize,'PAD#',\
_TIBSize,'TIB#',\
_NQuestionBRANCH,'N?BRANCH',\
_QuestionBRANCH,'?BRANCH',\
_BRANCH,'BRANCH',\
_EXIT,'EXIT',\
_Less,'<',\
_UTo,'U>',\
_To,'>',\
_0Equal,'0=',\
_lParCONSTANTrPar,'(CONSTANT)',\
_lParCREATErPar,'(CREATE)',\
_lParSLITrPar,'(SLIT)',\
_lParTickrPar,'(`)',\
_lParDLITrPar,'(DLIT)',\
_lParLITrPar,'(LIT)',\
_RTo,'R>',\
_ToR,'>R',\
_RPFetch,'RP@',\
_RPStore,'RP!',\
_SPFetch,'SP@',\
_SPStore,'SP!',\
_PlusStoreFetch,'+!@',\
_MIN,'MIN',\
_ABS,'ABS',\
_SToD,'S>D',\
_UMSlashMOD,'UM/MOD',\
_OR,'OR',\
_Slash,'/',\
_Minus,'-',\
_Plus,'+',\
_BStore,'B!',\
_BFetch,'B@',\
_Store,'!',\
_Fetch,'@',\
_ROT,'ROT',\
_OVER,'OVER',\
_SWAP,'SWAP',\
_DDUP,'DDUP',\
_DUP,'DUP',\
_DDROP,'DDROP',\
_DROP,'DROP',\
_NIP,'NIP',\
_NOOP,'NOOP'
Пока что просто ожидает ввода строки, затем выводит ее на экран, собственно, для иллюстрации работы транслятора достаточно 8)