Forth и другие саморасширяющиеся системы программирования Locations of visitors to this page
Текущее время: Вт мар 19, 2024 13:31

...
Google Search
Forth-FAQ Spy Grafic

Часовой пояс: UTC + 3 часа [ Летнее время ]




Начать новую тему Ответить на тему  [ Сообщений: 10 ] 
Автор Сообщение
 Заголовок сообщения: Форт-транслятор в Ассемблер _ вариант 2
СообщениеДобавлено: Вс дек 28, 2014 19:21 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 5062
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 23 раз.
Поблагодарили: 63 раз.
Продолжение оригинальной темы в дополнению к идее реализации и первому наброску продолжение развития реализации будет тут, т.к. в оригинальной теме толку не видно, и, посему, флуд и оффтопик в данной теме будет вычищаться.

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Форт-транслятор в Ассемблер _ вариант 2
СообщениеДобавлено: Вс дек 28, 2014 19:25 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 5062
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 23 раз.
Поблагодарили: 63 раз.
Итак, следующий транслируемый текст:

Код:
\ пример транслируемого текста
TRANSLATE: zzz
LABEL: START

\ первое определение
: NOOP ( --> ) ;

\ удалить элемент под вершиной стека
: NIP ( a b --> b ) NIP ;

\ удалить значение с вершины стека данных
: DROP ( n --> ) DROP ;

\ дублировать значение n на вершине стека данных
: DUP ( n --> n n ) DUP ;

\ обменять значения двух ячеек на вершине стека данных
: SWAP ( a b --> b a ) SWAP ;

\ положить на вершину стека данных копию значения второго элемента
: OVER ( a b --> a b a ) OVER ;

\ извлечь значение с указанного адреса
: @ ( addr --> n ) FETCH ;

\ сохранить значение n по указанному адресу
: ! ( n addr --> ) STORE SKP ;

\ сложить два числа на вершине стека данных, результат оставить на вершине
: + ( n1 n2 --> n ) PLUS NIP ;

\ переместить указатель вершины стека данных на указанный адрес
\ в TOS остается значение
: SP! ( addr --> )  TOSP ;

\ переместить указатель вершины стека возвратов на указанный адрес
: RP! ( addr --> )  TORP JUMP ;-

\ выложить на вершину стека данных значение,
\ скомпилированное в коде за вызовом (LIT)
: (LIT) ( --> n ) DUP RVAR GETLIT ;-

\ выложить на вершину стека данных значение,
\ скомпилированное в коде за вызовом (LIT)
: (DLIT) ( --> n ) DUP DUP RVAR GETLIT ;-

\ вернуть адрес слова, вызов которого скомпилирован в коде вслед за (')
: (`) ( --> addr ) DUP RVAR GETALIT ;-

\ вернуть адрес начала строки asc, размещенной в коде за (SLIT), и ее длину #
: (SLIT) ( --> asc # ) (SLIT) ;-

\ положить на вершину стека адрес переменной
: (CREATE) ( --> addr ) DUP RVAR ;

\ положить на вершину стека значение
: (CONSTANT) ( --> n ) DUP RVAR FETCH ;

\ размер буферов TIB и PAD в байтах
    100 CONSTANT TIB# ( --> # )
    100 CONSTANT PAD# ( --> #)

\ terminal input buffer
CREATE TIB  TIB# ALLOT

\ буфер для форматного преобразования чисел и строк
CREATE PAD  PAD# ALLOT

\ указатель на последний символ в PAD
VARIABLE HLD

\ Дно стека данных
VARIABLE S0 ( --> addr )
\ Дно стека возвратов
VARIABLE R0 ( --> addr )

\ размеры стеков
0x1000 CONSTANT DataStack#
0x1000 CONSTANT ReturnStack#

\ Хранит адрес первой свободной ячейки памяти в пространстве кода и данных
VARIABLE DP ( --> addr )
\ Хранит адрес первой свободной ячейки памяти в пространстве имен
VARIABLE HDP ( --> addr )

\ стандартные потоки В\В
VARIABLE STDIN
VARIABLE STDOUT
VARIABLE STDERR

\ вернуть адрес первой свободной ячейки памят в пространстве кода и данных
: HERE ( --> addr ) DP FETCH ;

\ вернуть адрес первой свободной ячейки памят в пространстве имен
: HHERE ( haddr --> addr ) HDP FETCH ;

\ вывести в текущий STDOUT поток указанную строку
: TYPE ( asc # --> ) Type ;

\ холодный запуск системы
: COLD ( --> )

       S" sample string" TYPE

       0x12345678
       TIB#
       0x123456789ABCDEF

       S0 R0 BEGIN SWAP OVER NIP DROP AGAIN ;  IMMEDIATE

\ последнее определение системы
CREATE LIMIT ( --> )

;TRANSLATE



превращается в следующий:
Код:
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
START:   ; свободная метка
;  первое определение
align
_NOOP: ; ( --> )
          RET

;  удалить элемент под вершиной стека
align
_NIP: ; ( a b --> b )
                LEA EBP, [EBP+CELL]
          RET

;  удалить значение с вершины стека данных
align
_DROP: ; ( n --> )
                MOV EAX, [EBP]
                LEA EBP, [EBP+CELL]
          RET

;  дублировать значение n на вершине стека данных
align
_DUP: ; ( n --> n n )
                LEA EBP, [EBP-CELL]
                MOV dword [EBP], EAX
          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
_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

;  сложить два числа на вершине стека данных, результат оставить на вершине
align
_Plus: ; ( n1 n2 --> n )
                ADD EAX, [EBP]
                LEA EBP, [EBP+CELL]
          RET

;  переместить указатель вершины стека данных на указанный адрес
;  в TOS остается значение
align
_SPStore: ; ( addr --> )
                MOV EBP, EAX
          RET

;  переместить указатель вершины стека возвратов на указанный адрес
align
_RPStore: ; ( addr --> )
                POP EDX
                MOV ESP, EAX
                MOV EAX, EDX
                MOV EDX, EAX
                MOV EAX, [EBP]
                LEA EBP, [EBP+CELL]
        JMP EDX

;  выложить на вершину стека данных значение,
;  скомпилированное в коде за вызовом (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

;  размер буферов TIB и PAD в байтах
trialign
_TIBSize: CALL _lParCONSTANTrPar
         dd 0x64

; ( --> # )
trialign
_PADSize: CALL _lParCONSTANTrPar
         dd 0x64

; ( --> #)
;  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,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
_PAD: 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,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

;  указатель на последний символ в PAD
trialign
_HLD: 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

;  вернуть адрес первой свободной ячейки памят в пространстве кода и данных
align
_HERE: ; ( --> addr )
                CALL _DP
                MOV EAX, [EAX]
          RET

;  вернуть адрес первой свободной ячейки памят в пространстве имен
align
_HHERE: ; ( haddr --> addr )
                CALL _HDP
                MOV EAX, [EAX]
          RET

;  вывести в текущий STDOUT поток указанную строку
align
_TYPE: ; ( asc # --> )
                MOV EDX, [EBP]
                PUSH EAX
                PUSH EDX
                PUSH dword [_STDOUT+TOKEN]
                CALL [WriteFile]
                NOP
                NOP
                NOP
          RET

;  холодный запуск системы
align
_COLD: ; ( --> )
;       LIMIT DP !
                CALL _lParSLITrPar
                 dd 0xD
                 db 0x73,0x61,0x6D,0x70,0x6C,0x65,0x20,0x73,0x74,0x72,0x69,0x6E,0x67,0x00
                CALL _TYPE
                CALL _lParLITrPar
                 dd 0x12345678
                CALL _TIBSize
                CALL _lParDLITrPar
                 dq 0x123456789ABCDEF
                CALL _S0
                CALL _R0
lab_0001:       ; метка для перехода назад
                MOV EDX, EAX
                MOV EAX, [EBP]
                MOV dword [EBP], EDX
                MOV EDX, [EBP]
                LEA EBP, [EBP-CELL]
                MOV dword [EBP], EAX
                MOV EAX, EDX
                LEA EBP, [EBP+CELL]
                MOV EAX, [EBP]
                LEA EBP, [EBP+CELL]
        JMP lab_0001 ; переход назад
          RET

;  последнее определение системы
trialign
_LIMIT: CALL _lParCREATErPar
; ( --> )

entry _COLD ; точка входа


section '.names' data readable writeable
; makevoc FORTH

;   Имя, Метка, Флаг immediate
def 'LIMIT', _LIMIT, 1
def 'COLD', _COLD, -1
def 'TYPE', _TYPE, 1
def 'HHERE', _HHERE, 1
def 'HERE', _HERE, 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 'HLD', _HLD, 1
def 'PAD', _PAD, 1
def 'TIB', _TIB, 1
def 'PAD#', _PADSize, 1
def 'TIB#', _TIBSize, 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 'RP!', _RPStore, 1
def 'SP!', _SPStore, 1
def '+', _Plus, 1
def '!', _Store, 1
def '@', _Fetch, 1
def 'OVER', _OVER, 1
def 'SWAP', _SWAP, 1
def 'DUP', _DUP, 1
def 'DROP', _DROP, 1
def 'NIP', _NIP, 1
def 'NOOP', _NOOP, 1
LATEST: ; чтобы получить хвост цепочки имен
NSADDR:
allot NamesSpace-($-$$) ;


Понятно, код форт-системы пока в виде наброска, но Fasm компилит, и даже можно попробовать посмотреть на результат в дебагере (хотя TYPE пока не рабочий).

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Форт-транслятор в Ассемблер _ вариант 2
СообщениеДобавлено: Вс дек 28, 2014 19:33 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 5062
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 23 раз.
Поблагодарили: 63 раз.
А это код текущего варианта(как обычно для форка):

source file: f2a.fts
\ 2014.12.21 m0leg

\! сделать реверс списка имен (не обязательно)

ALSO ROOT DEFINITIONS : .S .S ; RECENT


memory/ buff.fts
branch/ case.fts
branch/ for-next.fts


\ -- буфер для склейки строк ---------------------------------------------------
USER-VALUE outbuf

\ создать буфер размером в 1 МБ (должно хватать)
: init-buf 0x100000 Buffer TO outbuf ;

\ освободить занятый буфер
: del-buf outbuf Retire ;

\ добавить в буфер строку текста
: +>buf ( asc # --> ) outbuf >Buffer DROP ;

\ добавить одиночный символ в буфер
: ch>buf ( char --> ) <| KEEP |> +>buf ;

\ вернуть содержимое буфера
: buf> ( --> asc # ) outbuf Buffer> ;

\ открыть буфер
: buf< ( --> ) outbuf Clean ;

\ -- форматирование текста -----------------------------------------------------

\ отступ от начала строки на два tab-а
: -| ( --> ) s" \t\t" +>buf ;
\ новая линия
: nl ( --> ) s" \n\r" +>buf ;
\ добавить строку с одним tab-ом в начале строки, завершить переводом строки
: +>> ( asc # --> ) s" \t" +>buf +>buf nl ;
\ добавить строку с двумя tab-ами в начале строки, завершить переводом строки
: +>l ( asc # --> ) -| +>buf nl ;

\ добавить строку в выходной буфер
: o" ( / asc" --> asc # | )
[CHAR] " CookLine
state IF SLIT, ['] +>buf COMPILE, THEN ; IMMEDIATE
\ /--/--/ с табуляцией в начале и переводом строки в конце
: o|" ( / asc" --> asc # | )
[CHAR] " CookLine
state IF SLIT, ['] +>> COMPILE, THEN ; IMMEDIATE
\ /--/--/ с двумя табуляциями в начале и переводом строки в конце
: o-|" ( / asc" --> asc # | )
[CHAR] " CookLine
state IF SLIT, ['] +>l COMPILE, THEN ; IMMEDIATE

\ добавить число
: dd+ ( n --> ) 0x10 {# Bl_ HOLD S>D #S s" dd 0x" HOLDS #> +>buf ;
: dq+ ( d --> ) 0x10 {# Bl_ HOLD #S s" dq 0x" HOLDS #> +>buf ;

\ -- сохранение содержимого в файл ---------------------------------------------

0 VALUE FId

\ создать файл с заданным именем
: file ( asc # --> fid ) W/O CREATE-FILE THROW TO FId ;

\ сохранить содержимое буфера в файл
: save ( fid --> )
>L buf> L@ WRITE-FILE THROW
L> CLOSE-FILE THROW ;

\ добавить содержимое указанного файла
: asmfile ( asc # --> )
FILE>HEAP IFNOT ERROR" не могу прочесть файл" THEN
OVER >L +>buf L> FREE THROW ;

\ -- создание новой метки ------------------------------------------------------

USER-VALUE LastLab

: l>name ( lab --> asc # ) S>D 0x10 {# # # # # s" lab_" HOLDS #> ;

\ создать новую метку, вернуть имя
: label ( --> lab asc # ) LastLab 1 + DUP TO LastLab DUP l>name ;

\ преобразовать специальный символ в строковое представление и добавить
\ результат в буфер PAD
: ?ADDCHAR ( ch --> )
CASE [CHAR] , OF s" Compile" ENDOF
[CHAR] ! OF s" Store" ENDOF
[CHAR] ? OF s" Question" ENDOF
[CHAR] @ OF s" Fetch" ENDOF
[CHAR] ' OF s" Deref" ENDOF
[CHAR] ; OF s" Semicolon" ENDOF
[CHAR] . OF s" Peroid" ENDOF
[CHAR] : OF s" Colon" ENDOF
[CHAR] > OF s" To" ENDOF
[CHAR] + OF s" Plus" ENDOF
[CHAR] - OF s" Minus" ENDOF
[CHAR] = OF s" Equal" ENDOF
[CHAR] # OF s" Size" ENDOF
[CHAR] " OF s" Quote" ENDOF
[CHAR] < OF s" Less" ENDOF
[CHAR] / OF s" Slash" ENDOF
[CHAR] \ OF s" Backslash" ENDOF
[CHAR] ? OF s" Question" ENDOF
[CHAR] [ OF s" lStap" ENDOF
[CHAR] ] OF s" rStap" ENDOF
[CHAR] ( OF s" lPar" ENDOF
[CHAR] ) OF s" rPar" ENDOF
[CHAR] { OF s" lBr" ENDOF
[CHAR] } OF s" rBr" ENDOF
[CHAR] ~ OF s" Show" ENDOF
[CHAR] | OF s" Wall" ENDOF
[CHAR] ` OF s" Tick" ENDOF
HOLD s" "
ENDCASE HOLDS ;

\ преобразовать Форт-имя в метку
: name>label ( asc # --> asc # )
OVER +
0x10 {#
BEGIN DDUP < WHILE
1 - DUP C@ ?ADDCHAR
REPEAT #> ;

\
: name' ( / name --> ) NextWord name>label SLIT, ; IMMEDIATE

\ -- создание рабочих словарей и слов для работы с ними ------------------------

\ ячейка для хранения последнего распознанного числа
USER-CREATE LastNumber 2 CELLS USER-ALLOT

\ обработка чисел одинарной длины
: (tLit) ( --> n )
LastNumber @
state IF o" \t\tCALL _" s" (LIT)" name>label +>buf nl
-| dd+ nl
THEN \! вместо dq должен быть код литерала
; IMMEDIATE
\ обработка чисел двойной длины
: (tdLit) ( --> d )
LastNumber D@
state IF o" \t\tCALL _" s" (DLIT)" name>label +>buf nl
-| dq+ nl
THEN \! вместо dq должен быть код литерала
; IMMEDIATE

\ попытаться распознать строку asc # , как число,
\ в случае успеха вернуть lfa слова, ассоциируемого с числом
: tNumLfa ( asc # vid --> lfa | 0 ) DROP \ vid словаря не нужен
[ ALSO HIDDEN ]
snNumber *IF 1 - IF LastNumber D! LFA (tdLit)
ELSE LastNumber ! LFA (tLit)
THEN
THEN
[ PREVIOUS ] ;

\ создание словаря, распознающего числа
init: VOCABULARY \ создаем стандартный словарь и правим поля
[ ALSO HIDDEN ]
VOC-LIST A@ >L \ wordlist
['] tNumLfa L@ off_quest A!
0 L@ off_vtable A! \ отсутствует vtable
0 L@ off_last A! \ слов в словаре нет
['] no-mount L@ off_mount A!
['] no-umount L@ off_umount A!
&vinit L> off_vflags B!
[ PREVIOUS ]
;stop TNUMBERS \ словарь для работы с числами

VOCABULARY MACRO \ словарь для хранения макросов
VOCABULARY TARGET \ словарь для хранения имен

\ показать список определений
\ чтобы можно было использовать отовюсду размещается в корневом словаре
ALSO ROOT DEFINITIONS
: ~LIST ORDER CR ALSO TARGET WORDS PREVIOUS CR ;
PREVIOUS DEFINITIONS

\ -- ---------------------------------------------------------------------------

0 VALUE LASTDEF \ хранит lfa последнего определения в TARGET

\ завершить создание макроса
: ;M ( --> ) [COMPILE] ; IMMEDIATE DEFINITIONS ; IMMEDIATE

\ начать создание макроса с указанным именем
: (:) ( asc # --> ) ALSO MACRO DEFINITIONS PREVIOUS S: ;

\ завершить создание теневого определения в TARGET
: ;C ( --> )
[COMPILE] ; IMMEDIATE
LATEST TO LASTDEF \ для того, чтобы удобно работать с флагами
DEFINITIONS ; IMMEDIATE

\ создать теневое определение в TARGET
: (C:) ( asc # --> ) ALSO TARGET DEFINITIONS PREVIOUS S: ;

\ начать создание макроса
: M: ( /name --> ) NextWord (:) ;

: LastDef ( --> id ) WHO TARGET LAST-NAME ;

\ вернуть имя последнего определения
: LastDef> ( --> asc # ) LastDef ID>ASC name>label ;

\ добавить имя в словарь TARGET, и соответствующую метку в листинг
: AddName ( /name --> )
NextWord DDUP (C:) name>label DDUP SLIT,
<: o" \t\tCALL _" +>buf nl ;> COMPILE,
[COMPILE] ;C
o" _" +>buf ;

\ секция импорта
: ImportSect ( --> )
nl o" section '.import' import data readable writeable" nl
nl o" library kernel,'KERNEL32.DLL'" nl
nl o" import kernel,\\" nl
o|" LoadLibrary, 'LoadLibrary',\\"
o|" GetProcAddress, 'GetProcAddress',\\"
o|" ExitProcess, 'ExitProcess',\\"
o|" GetStdHandle, 'GetStdHandle',\\"
o|" WriteFile, 'WriteFile',\\"
o|" ReadFile, 'ReadFile'"
;

\ преамбула
: Preambula ( --> )
o" format PE console" nl nl
o|" include 'include\\win32a.inc'"
o|" include 'include\\macro\\struct.inc'"
nl ImportSect ;

\ начать трансляцию текста
: TRANSLATE: ( /name --> )
NextWord <| KEEPS s" .asm" KEEPS 0 KEEP |> file
init-buf
ONLY PREVIOUS TNUMBERS ALSO TARGET DEFINITIONS ALSO MACRO
Preambula nl
s" f2a_m.asm" asmfile \ содержимое Preambula можно сразу внутрь f2a_m.asm

\ код и данные хранятся вместе в одном сегменте, а словарь размещается в отдельном
nl o" section '.fvm' code executable readable writeable" nl ;

\ проверка, установлен ли признак немедленного исполнения
: ?IMM ( lfa --> asc # | 0 ) [ ALSO HIDDEN ] &ALS @ATTR [ PREVIOUS ] ;

\ создать список имен
: MakeVoc ( / name --> )
nl nl o" section '.names' data readable writeable"
nl o" ; makevoc " +>buf nl
nl o" ; Имя, Метка, Флаг immediate"
LastDef BEGIN *WHILE
nl o" def \'"
DUP ID>ASC DDUP +>buf o" ', _"
name>label +>buf o" , "
DUP ?IMM IF o" -1" ELSE o" 1" THEN
LINK>
REPEAT DROP
nl
o" LATEST: ; чтобы получить хвост цепочки имен" nl
o" NSADDR:" nl
o" allot NamesSpace-($-$$) ;" nl ;

\ сохранить содержимое буфера в файл
: aSave ( --> ) FId save del-buf ;

\ -- ---------------------------------------------------------------------------
\! Все определения, заканчивающиеся ;M являются IMMEDIATE

\ коментарий в скобках копируем в коментарий
M: ( ( /comment string --> )
o" ; ( "
BEGIN NEXT-WORD DDUP +>buf o" " *WHILE
+ <C C@ [CHAR] )
<> WHILE
REPEAT nl
;THEN DDROP \ если закрывающая скобка не встретилась до конца файла
;M

\ завершить трансляцию текста
M: ;TRANSLATE ( --> )
\ точкой входа считаем последнее определение в тексте
nl o" entry _COLD ; точка входа" nl
s" FORTH" MakeVoc
aSave ONLY DEFINITIONS ;M

\ создать безымянную метку для перехода назад
M: BEGIN ( --> lab p )
label +>buf o" :\t; метка для перехода назад" nl
NOTICE" Не обнаружена метка для перехода назад!" ;M

\ создать безусловный переход назад на метку lab
M: AGAIN ( lab p --> )
?PAIRS" Не обнаружена метка для перехода назад!"
o" \tJMP " l>name +>buf o" ; переход назад" nl ;M

\ создать метку с именем name в тексте
M: LABEL: ( /name --> ) NextWord +>buf o" :\t ; свободная метка" nl ;M

\ начать целевое определение
M: : ( / name --> ) o" align" nl
NextWord DDUP (C:) name>label DDUP SLIT,
<: o" \t\tCALL _" +>buf nl ;> COMPILE,
o" _" +>buf o" : "
;M

\ завершить определение
M: ; ( --> ) [COMPILE] ;C o" \t RET " nl nl ;M
\ завершить определение
M: ;- ( --> ) [COMPILE] ;C nl ;M

\ коментарий в тексте
M: \ ( --> )
-1 >IN +!
o" ; " Cr_ PARSE +>buf nl
;M

\ создать имя, возвращающее адрес собственного поля параметров
M: CREATE ( /name --> ) o" trialign" nl
AddName o" : CALL _"
s" (CREATE)" name>label +>buf nl ;M

\ создать именованную переменную
M: VARIABLE ( /name --> ) o" trialign" nl
AddName o" : CALL _"
s" (CREATE)" name>label +>buf nl o" \tdd 0" nl nl ;M

\ создать именованную константу
M: CONSTANT ( n /name --> ) o" trialign" nl
DUP >L
NextWord DDUP (C:) L> LIT, name>label DDUP SLIT,
<: state IF o" \t\tCALL _" +>buf nl
ELSE DROP
THEN DROP
;> COMPILE,
[COMPILE] ;C
o" _" +>buf o" : CALL _"
s" (CONSTANT)" name>label +>buf nl o" \t" dd+ nl nl ;M

\ резервировать указанное количество минимально адресуемых ячеек памяти
\ в пространстве кода и данных
M: ALLOT ( u --> ) 1 OVER > ABORT" должно быть быть больше 0"
o" \tdb 0"
1 -
*IF FOR R@ 34 MOD
IFNOT o" \n\r\tdb 0" ELSE o" ,0" THEN
TILL
ELSE DROP
THEN nl nl ;M

\ отметить последнее определение признаком немедленного исполнения
M: IMMEDIATE ( --> )
TRUE LASTDEF
[ ALSO HIDDEN ] &ALS SET-ATTR \ т.к. IMMEDIATE уже занят используется &ALS
[ PREVIOUS ] THROW ;M

\
M: S" ( / ascii" --> | asc # )
[CHAR] " CookLine
state IF o" \t\tCALL _" s" (SLIT)" name>label +>buf nl
DUP o" \t\t" dd+ nl
*IF o" \t\t db "
FOR DUP C@ 0x10 {# S>D #S s" 0x" HOLDS #> +>buf
R@ 16 MOD IFNOT nl o" \t\t db "
ELSE o" ,"
THEN
1 +
TILL DROP
ELSE DDROP
THEN
THEN o" 0x00" nl ;M

\ -- определение примитивов ----------------------------------------------------

M: NIP o-|" LEA EBP, [EBP+CELL]" ;M

M: CPY o-|" MOV EAX, [EBP]" ;M \ копировать значение второго элеметна стека данных в TOS

M: SKP o-|" MOV EAX, [EBP+CELL]"
o-|" LEA EBP, [EBP+8]" ;M

M: ROOM o-|" LEA EBP, [EBP-CELL]" ;M

M: DROP o-|" MOV EAX, [EBP]"
o-|" LEA EBP, [EBP+CELL]" ;M

M: SWAP o-|" MOV EDX, EAX"
o-|" MOV EAX, [EBP]"
o-|" MOV dword [EBP], EDX" ;M

M: DUP o-|" LEA EBP, [EBP-CELL]"
o-|" MOV dword [EBP], EAX" ;M

M: OVER o-|" MOV EDX, [EBP]"
o-|" LEA EBP, [EBP-CELL]"
o-|" MOV dword [EBP], EAX"
o-|" MOV EAX, EDX" ;M

M: RVAR o-|" POP EAX" ;M \ вернуть адрес следующей ячейки на вершину стека данных

M: FETCH o-|" MOV EAX, [EAX]" ;M

M: STORE o-|" MOV EDX, [EBP]"
o-|" MOV dword [EAX], EDX" ;M

M: GETLIT o-|" LEA EDX, [EAX+CELL]"
o-|" MOV EAX, [EAX]" \ оставить на вершине стека данных литерал
o|" JMP EDX" ;M \ обойти в коде литеральное значение

M: GETDLIT o-|" LEA EDX, [EAX+CELL*2]"
o-|" MOV EBX, [EAX]"
o-|" MOV EAX, [EAX+CELL]"
o-|" MOV dword [EBP], EBX"
o|" JMP EDX" ;M

M: GETALIT o-|" LEA EDX, [EAX+TOKEN]"
o-|" MOV EAX, [EAX+1]"
o|" JMP EDX" ;M

M: PLUS o-|" ADD EAX, [EBP]" ;M

M: (SLIT) o-|" LEA EBP, [EBP-8]"
o-|" MOV dword [EBP+CELL], EAX"
o-|" POP EBX"
o-|" LEA EDX, [EBX+CELL]"
o-|" MOV dword [EBP], EDX"
o-|" MOV EAX, [EBX]"
o-|" LEA EDX, [EBX+EAX+TOKEN]"
o|" JMP EDX" ;M

M: TOSP o-|" MOV EBP, EAX" ;M

M: TORP o-|" POP EDX"
o-|" MOV ESP, EAX"
o-|" MOV EAX, EDX" ;M

M: JUMP o-|" MOV EDX, EAX"
o-|" MOV EAX, [EBP]"
o-|" LEA EBP, [EBP+CELL]"
o|" JMP EDX" ;M

M: Type
o-|" MOV EDX, [EBP]"
o-|" PUSH EAX"
o-|" PUSH EDX"
o-|" PUSH dword [_STDOUT+TOKEN]"
o-|" CALL [WriteFile]"
o-|" NOP"
o-|" NOP"
o-|" NOP"
;M

\ -- ---------------------------------------------------------------------------

\ пример транслируемого текста
TRANSLATE: zzz
LABEL: START

\ первое определение
: NOOP ( --> ) ;

\ удалить элемент под вершиной стека
: NIP ( a b --> b ) NIP ;

\ удалить значение с вершины стека данных
: DROP ( n --> ) DROP ;

\ дублировать значение n на вершине стека данных
: DUP ( n --> n n ) DUP ;

\ обменять значения двух ячеек на вершине стека данных
: SWAP ( a b --> b a ) SWAP ;

\ положить на вершину стека данных копию значения второго элемента
: OVER ( a b --> a b a ) OVER ;

\ извлечь значение с указанного адреса
: @ ( addr --> n ) FETCH ;

\ сохранить значение n по указанному адресу
: ! ( n addr --> ) STORE SKP ;

\ сложить два числа на вершине стека данных, результат оставить на вершине
: + ( n1 n2 --> n ) PLUS NIP ;

\ переместить указатель вершины стека данных на указанный адрес
\ в TOS остается значение
: SP! ( addr --> ) TOSP ;

\ переместить указатель вершины стека возвратов на указанный адрес
: RP! ( addr --> ) TORP JUMP ;-

\ выложить на вершину стека данных значение,
\ скомпилированное в коде за вызовом (LIT)
: (LIT) ( --> n ) DUP RVAR GETLIT ;-

\ выложить на вершину стека данных значение,
\ скомпилированное в коде за вызовом (LIT)
: (DLIT) ( --> n ) DUP DUP RVAR GETLIT ;-

\ вернуть адрес слова, вызов которого скомпилирован в коде вслед за (')
: (`) ( --> addr ) DUP RVAR GETALIT ;-

\ вернуть адрес начала строки asc, размещенной в коде за (SLIT), и ее длину #
: (SLIT) ( --> asc # ) (SLIT) ;-

\ положить на вершину стека адрес переменной
: (CREATE) ( --> addr ) DUP RVAR ;

\ положить на вершину стека значение
: (CONSTANT) ( --> n ) DUP RVAR FETCH ;

\ размер буферов TIB и PAD в байтах
100 CONSTANT TIB# ( --> # )
100 CONSTANT PAD# ( --> #)

\ terminal input buffer
CREATE TIB TIB# ALLOT

\ буфер для форматного преобразования чисел и строк
CREATE PAD PAD# ALLOT

\ указатель на последний символ в PAD
VARIABLE HLD

\ Дно стека данных
VARIABLE S0 ( --> addr )
\ Дно стека возвратов
VARIABLE R0 ( --> addr )

\ размеры стеков
0x1000 CONSTANT DataStack#
0x1000 CONSTANT ReturnStack#

\ Хранит адрес первой свободной ячейки памяти в пространстве кода и данных
VARIABLE DP ( --> addr )
\ Хранит адрес первой свободной ячейки памяти в пространстве имен
VARIABLE HDP ( --> addr )

\ стандартные потоки В\В
VARIABLE STDIN
VARIABLE STDOUT
VARIABLE STDERR

\ вернуть адрес первой свободной ячейки памят в пространстве кода и данных
: HERE ( --> addr ) DP FETCH ;

\ вернуть адрес первой свободной ячейки памят в пространстве имен
: HHERE ( haddr --> addr ) HDP FETCH ;

\ вывести в текущий STDOUT поток указанную строку
: TYPE ( asc # --> ) Type ;

\ холодный запуск системы
: COLD ( --> )
\ LIMIT DP !

S" sample string" TYPE

0x12345678
TIB#
0x123456789ABCDEF

S0 R0 BEGIN SWAP OVER NIP DROP AGAIN ; IMMEDIATE

\ последнее определение системы
CREATE LIMIT ( --> )

;TRANSLATE


~LIST

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Форт-транслятор в Ассемблер _ вариант 2
СообщениеДобавлено: Вс дек 28, 2014 19:36 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 5062
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 23 раз.
Поблагодарили: 63 раз.
да, файл f2a_m.asm содержит следующее:
Код:
; типы данных

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 }


_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Форт-транслятор в Ассемблер _ вариант 2
СообщениеДобавлено: Ср дек 31, 2014 05:56 
Не в сети
Аватара пользователя

Зарегистрирован: Вт мар 20, 2007 23:39
Сообщения: 1261
Благодарил (а): 3 раз.
Поблагодарили: 19 раз.
Компиляция асм кода из первого поста в FASM проходит успешно, но при старте приложения оно вылетает. Win7 x64.

_________________
Cтоимость сопровождения программного обеспечения пропорциональна квадрату творческих способностей программиста.
Роберт Д. Блисc


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Форт-транслятор в Ассемблер _ вариант 2
СообщениеДобавлено: Ср дек 31, 2014 06:38 
Не в сети

Зарегистрирован: Пн янв 07, 2013 22:40
Сообщения: 2141
Благодарил (а): 8 раз.
Поблагодарили: 74 раз.
VoidVolker писал(а):
Компиляция асм кода из первого поста в FASM проходит успешно, но при старте приложения оно вылетает. Win7 x64.

Можно сравнить результаты запуска с вариантом форт системы на Fasм со встоенным SPF4 (Михаила)
У меня были тоже какие то проблемы с запуском его в Win7/64 в сравнении с XP, в частности это проявлялось
в неработоспособности (или некорректного поведения) консольного АPI по сравнению с XP.


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Форт-транслятор в Ассемблер _ вариант 2
СообщениеДобавлено: Ср дек 31, 2014 07:16 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 5062
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 23 раз.
Поблагодарили: 63 раз.
VoidVolker писал(а):
Компиляция асм кода из первого поста в FASM проходит успешно, но при старте приложения оно вылетает. Win7 x64.

Дык, оно ж не закончено пока, как система (можно было бы в код заглянуть, что сделано-то :shuffle; а что еще не сделано, вот ). В дебаге можно посмотреть что делатется, пока не более того. Сейчас WriteFile не совсем корректно вызывается (не правильно параметры скармливаются), при желании можно поправить или дописать 8)
(фиксация промежуточного результата, т.к. не знаю, будет ли еще время этим заниматься). А главное пока что в Иллюстрации подхода к реализации

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Форт-транслятор в Ассемблер _ вариант 2
СообщениеДобавлено: Вт янв 20, 2015 19:56 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 5062
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 23 раз.
Поблагодарили: 63 раз.
Еще один промежуточный вариант.
source file: f2a.fts
\ 2014.12.21 m0leg

\! сделать реверс списка имен (не обязательно)

ALSO ROOT DEFINITIONS : .S .S ; RECENT

memory/ buff.fts
branch/ case.fts
branch/ for-next.fts


\ -- буфер для склейки строк ---------------------------------------------------
USER-VALUE outbuf

\ создать буфер размером в 1 МБ (должно хватать)
: init-buf 0x100000 Buffer TO outbuf ;

\ освободить занятый буфер
: del-buf outbuf Retire ;

\ добавить в буфер строку текста
: +>buf ( asc # --> ) outbuf >Buffer DROP ;

\ добавить одиночный символ в буфер
: ch>buf ( char --> ) <| KEEP |> +>buf ;

\ вернуть содержимое буфера
: buf> ( --> asc # ) outbuf Buffer> ;

\ открыть буфер
: buf< ( --> ) outbuf Clean ;

\ -- форматирование текста -----------------------------------------------------

\ отступ от начала строки на два tab-а
: -| ( --> ) s" \t\t" +>buf ;
\ новая линия
: nl ( --> ) s" \n\r" +>buf ;
\ добавить строку с одним tab-ом в начале строки, завершить переводом строки
: +>> ( asc # --> ) s" \t" +>buf +>buf nl ;
\ добавить строку с двумя tab-ами в начале строки, завершить переводом строки
: +>l ( asc # --> ) -| +>buf nl ;

\ добавить строку в выходной буфер
: o" ( / asc" --> asc # | )
[CHAR] " CookLine
state IF SLIT, ['] +>buf COMPILE, THEN ; IMMEDIATE
\ /--/--/ с табуляцией в начале и переводом строки в конце
: o|" ( / asc" --> asc # | )
[CHAR] " CookLine
state IF SLIT, ['] +>> COMPILE, THEN ; IMMEDIATE
\ /--/--/ с двумя табуляциями в начале и переводом строки в конце
: a" ( / asc" --> asc # | )
[CHAR] " CookLine
state IF SLIT, ['] +>l COMPILE, THEN ; IMMEDIATE

\ добавить число
: dd+ ( n --> ) 0x10 {# Bl_ HOLD 0 #S s" dd 0x" HOLDS #> +>buf ;
: dq+ ( d --> ) 0x10 {# Bl_ HOLD #S s" dq 0x" HOLDS #> +>buf ;

\ -- сохранение содержимого в файл ---------------------------------------------

0 VALUE FId

\ создать файл с заданным именем
: file ( asc # --> fid ) W/O CREATE-FILE THROW TO FId ;

\ сохранить содержимое буфера в файл
: save ( fid --> )
>L buf> L@ WRITE-FILE THROW
L> CLOSE-FILE THROW ;

\ добавить содержимое указанного файла
: asmfile ( asc # --> )
FILE>HEAP IFNOT ERROR" не могу прочесть файл" THEN
OVER >L +>buf L> FREE THROW ;

\ -- создание новой метки ------------------------------------------------------

USER-VALUE LastLab

: l>name ( lab --> asc # ) S>D 0x10 {# # # # # s" lab_" HOLDS #> ;

\ создать новую метку, вернуть имя
: label ( --> lab asc # ) LastLab 1 + DUP TO LastLab DUP l>name ;

\ преобразовать специальный символ в строковое представление и добавить
\ результат в буфер PAD
: ?ADDCHAR ( ch --> )
CASE [CHAR] , OF s" Compile" ENDOF
[CHAR] ! OF s" Store" ENDOF
[CHAR] ? OF s" Question" ENDOF
[CHAR] @ OF s" Fetch" ENDOF
[CHAR] ' OF s" Deref" ENDOF
[CHAR] ; OF s" Semicolon" ENDOF
[CHAR] . OF s" Peroid" ENDOF
[CHAR] : OF s" Colon" ENDOF
[CHAR] > OF s" To" ENDOF
[CHAR] + OF s" Plus" ENDOF
[CHAR] - OF s" Minus" ENDOF
[CHAR] = OF s" Equal" ENDOF
[CHAR] # OF s" Size" ENDOF
[CHAR] " OF s" Quote" ENDOF
[CHAR] < OF s" Less" ENDOF
[CHAR] / OF s" Slash" ENDOF
[CHAR] \ OF s" Backslash" ENDOF
[CHAR] ? OF s" Question" ENDOF
[CHAR] [ OF s" lStap" ENDOF
[CHAR] ] OF s" rStap" ENDOF
[CHAR] ( OF s" lPar" ENDOF
[CHAR] ) OF s" rPar" ENDOF
[CHAR] { OF s" lBr" ENDOF
[CHAR] } OF s" rBr" ENDOF
[CHAR] ~ OF s" Show" ENDOF
[CHAR] | OF s" Wall" ENDOF
[CHAR] ` OF s" Tick" ENDOF
[CHAR] * OF s" Star" ENDOF
HOLD s" "
ENDCASE HOLDS ;

\ преобразовать Форт-имя в метку
: name>label ( asc # --> asc # )
OVER +
0x10 {#
BEGIN DDUP < WHILE
1 - DUP C@ ?ADDCHAR
REPEAT #> ;

\
: label, ( asc # --> asc # ) name>label DDUP SLIT, ;
\
: name' ( / name --> ) NextWord label, DROP ; IMMEDIATE

\ -- создание рабочих словарей и слов для работы с ними ------------------------

\ ячейка для хранения последнего распознанного числа
USER-CREATE LastNumber 2 CELLS USER-ALLOT

\ обработка чисел одинарной длины
: (tLit) ( --> n )
LastNumber @
state IF o" \t\tCALL _" s" (LIT)" name>label +>buf nl
-| dd+ nl
THEN \! вместо dq должен быть код литерала
; IMMEDIATE
\ обработка чисел двойной длины
: (tdLit) ( --> d )
LastNumber D@
state IF o" \t\tCALL _" s" (DLIT)" name>label +>buf nl
-| dq+ nl
THEN \! вместо dq должен быть код литерала
; IMMEDIATE

\ попытаться распознать строку asc # , как число,
\ в случае успеха вернуть lfa слова, ассоциируемого с числом
: tNumLfa ( asc # vid --> lfa | 0 ) DROP \ vid словаря не нужен
[ ALSO HIDDEN ]
snNumber *IF 1 - IF LastNumber D! LFA (tdLit)
ELSE LastNumber ! LFA (tLit)
THEN
THEN
[ PREVIOUS ] ;

\ создание словаря, распознающего числа
init: VOCABULARY \ создаем стандартный словарь и правим поля
[ ALSO HIDDEN ]
VOC-LIST A@ >L \ wordlist
['] tNumLfa L@ off_quest A!
0 L@ off_vtable A! \ отсутствует vtable
0 L@ off_last A! \ слов в словаре нет
['] no-mount L@ off_mount A!
['] no-umount L@ off_umount A!
&vinit L> off_vflags B!
[ PREVIOUS ]
;stop TNUMBERS \ словарь для работы с числами

VOCABULARY MACRO \ словарь для хранения макросов
VOCABULARY TARGET \ словарь для хранения имен

\ показать список определений
\ чтобы можно было использовать отовюсду размещается в корневом словаре
ALSO ROOT DEFINITIONS
: ~LIST ORDER CR ALSO TARGET WORDS PREVIOUS CR ;
PREVIOUS DEFINITIONS

\ -- ---------------------------------------------------------------------------

0 VALUE LASTDEF \ хранит lfa последнего определения в TARGET

\ проверка режима компиляции
: ?COMP ( --> ) state IF ;THEN ERROR" Только для режима компиляции!" ;

\ завершить создание макроса
: ;M ( --> ) [COMPILE] ; IMMEDIATE DEFINITIONS ; IMMEDIATE

\ начать создание макроса с указанным именем
: (:) ( asc # --> ) ALSO MACRO DEFINITIONS PREVIOUS S: ;

\ завершить создание теневого определения в TARGET
: ;C ( --> )
[COMPILE] ; IMMEDIATE
LATEST TO LASTDEF \ для того, чтобы удобно работать с флагами
DEFINITIONS ; IMMEDIATE

\ создать теневое определение в TARGET
: (C:) ( asc # --> ) ALSO TARGET DEFINITIONS PREVIOUS S: ;

\ начать создание макроса
: M: ( /name --> ) NextWord (:) ;

: LastDef ( --> id ) WHO TARGET LAST-NAME ;

\ вернуть имя последнего определения
: LastDef> ( --> asc # ) LastDef ID>ASC name>label ;

\
: name+>buf ( asc # --> ) o" _" name>label +>buf ;

\ добавить имя в словарь TARGET, и соответствующую метку в листинг
: AddName ( /name --> )
NextWord DDUP (C:) label,
<: o" \t\tCALL _" +>buf nl ;> COMPILE,
[COMPILE] ;C
o" _" +>buf ;

\ секция импорта
: ImportSect ( --> )
nl o" section '.import' import data readable writeable" nl
nl o" library kernel,'KERNEL32.DLL'" nl
nl o" import kernel,\\" nl
o|" LoadLibrary, 'LoadLibrary',\\"
o|" GetProcAddress, 'GetProcAddress',\\"
o|" ExitProcess, 'ExitProcess',\\"
o|" GetStdHandle, 'GetStdHandle',\\"
o|" WriteFile, 'WriteFile',\\"
o|" ReadFile, 'ReadFile'"
;

\ преамбула
: Preambula ( --> )
o" format PE console" nl nl
o|" include 'include\\win32a.inc'"
o|" include 'include\\macro\\struct.inc'"
nl ImportSect ;

\ начать трансляцию текста
: TRANSLATE: ( /name --> )
NextWord <| s" D:/ASM/FASM/" KEEPS KEEPS s" .asm" KEEPS 0 KEEP |> file
init-buf
ONLY PREVIOUS TNUMBERS ALSO TARGET DEFINITIONS ALSO MACRO
Preambula nl
s" f2a_m.asm" asmfile \ содержимое Preambula можно сразу внутрь f2a_m.asm
\ код и данные хранятся вместе в одном сегменте, а словарь размещается в отдельном
nl o" section '.fvm' code executable readable writeable" nl ;

\ проверка, установлен ли признак немедленного исполнения
: ?IMM ( lfa --> asc # | 0 ) [ ALSO HIDDEN ] &ALS @ATTR [ PREVIOUS ] ;

\ создать список имен
: MakeVoc ( asc # --> )
nl nl o" section '.names' data readable writeable"
nl o" ; makevoc " +>buf nl
nl o" ; Имя, Метка, Флаг immediate"

LastDef BEGIN *WHILE
nl o" def \'"
DUP ID>ASC DDUP +>buf o" ', _"
name>label +>buf o" , "
DUP ?IMM IF o" -1" ELSE o" 1" THEN
LINK>
REPEAT DROP
nl
o" LATEST: ; чтобы получить хвост цепочки имен" nl
o" NSADDR:" nl
o" allot NamesSpace-($-$$) ;" nl ;

\ создать список имен в секции импорта, таким образом в отладчике будет видно
\ имя каждого определения
: MakeExp ( asc # --> )
nl nl o" section '.edata' export data readable"
nl o" export '" +>buf o" '"

LastDef BEGIN *WHILE o" ,\\\n\r"
DUP o" _" ID>ASC DDUP name>label +>buf
o" ,'" +>buf o" '"
LINK>
REPEAT DROP

nl nl ;

\ сохранить содержимое буфера в файл
: aSave ( --> ) FId save del-buf ;

\ -- ---------------------------------------------------------------------------
\! Все определения, заканчивающиеся ;M являются словами немедленного исполнения

\ коментарий в скобках копируем в коментарий целевого asm
M: ( ( /comment string --> )
o" ; ( "
BEGIN NEXT-WORD DDUP +>buf o" " *WHILE
+ <C C@ [CHAR] )
<> WHILE
REPEAT nl
;THEN DDROP \ если закрывающая скобка не встретилась до конца файла
;M

\ завершить трансляцию текста
M: ;TRANSLATE ( --> )
\ точкой входа считаем последнее определение в тексте
nl o" entry _COLD ; точка входа" nl
s" FORTH" DDUP MakeVoc \ создание словаря
MakeExp \ чтобы создать список имен в секции экспорта
aSave ONLY DEFINITIONS ;M

\ создать метку с именем name в тексте
M: LABEL: ( /name --> )
NextWord DDUP +>buf s" : " +>buf
DDUP (:) SLIT, <: nl o" \t\tCALL _" s" (LIT)" name>label +>buf nl
o" \t\t dd " [COMPILE] +>buf nl
;> COMPILE, [COMPILE] ;M ;M

\ завершить определение без добавления RET В конец определения
M: ;- ( --> ) [COMPILE] ;C nl ;M

\ компилировать условный переход вперед на парный THEN или ELSE
M: IF ( --> label ) ?COMP
o" \t\tCALL " s" ?BRANCH" name+>buf nl
o" \t\tdd " label +>buf nl
NOTICE" Непарная конструкция!" ;M

\ завершение ветвления
M: THEN ( label par --> ) ?COMP
?PAIRS" Непарная конструкция!"
l>name +>buf o" :" nl ;M

\ компилировать безусловный переход на парный THEN
M: ELSE ( label_a --> label_b ) ?COMP
?PAIRS" Непарная конструкция!"
o" \tCALL " s" BRANCH" name+>buf nl
o" \t\tdd " label +>buf nl
SWAP l>name +>buf o" :" nl
NOTICE" Непарная конструкция!" ;M

\ создать безымянную метку для перехода назад
M: BEGIN ( --> lab p ) ?COMP
label +>buf o" :\t; метка для перехода назад" nl
NOTICE" Не обнаружена метка для перехода назад!" ;M

\ компилировать выход из тела цикла
M: WHILE ( lab p --> lab p lab1 p ) ?COMP
DUP ?PAIRS" Не обнаружена метка для перехода назад!"
o" \t\tCALL " s" ?BRANCH" name+>buf nl
o" \t\tdd " label +>buf nl
NOTICE" Непарная конструкция!" DSWAP ;M

\ компилировать выход из тела цикла
M: WHILENOT ( lab p --> lab p lab1 p ) ?COMP
DUP ?PAIRS" Не обнаружена метка для перехода назад!"
o" \t\tCALL " s" N?BRANCH" name+>buf nl
o" \t\tdd " label +>buf nl
NOTICE" Непарная конструкция!" DSWAP ;M

\ Компилировать переход назад на BEGIN
M: REPEAT ( lab p lab1 p --> ) ?COMP
?PAIRS" Не обнаружена метка для перехода назад!"
o" \tJMP " l>name +>buf o" ; переход назад" nl
?PAIRS" Непарная конструкция!"
l>name +>buf o" :" nl ;M

\ создать безусловный переход назад на метку lab
M: AGAIN ( lab p --> ) ?COMP
?PAIRS" Не обнаружена метка для перехода назад!"
o" \tJMP " l>name +>buf o" ; переход назад" nl ;M

\ начать целевое определение
M: : ( / name --> ) o" align" nl
NextWord DDUP (C:) label,
<: o" \t\tCALL _" +>buf nl ;> COMPILE,
o" _" +>buf o" : " ;M

\ завершить определение с добавлением RET В конец определения
M: ; ( --> ) [COMPILE] ;C o" \t RET " nl nl ;M

\ коментарий до конца строки копируется в целевой asm файл
M: \ ( --> )
-1 >IN +!
o" ; " Cr_ PARSE +>buf nl
;M

\ создать имя, возвращающее адрес собственного поля параметров
M: CREATE ( /name --> ) o" trialign" nl
AddName o" : CALL _"
s" (CREATE)" name>label +>buf nl ;M

\ создать именованную переменную
M: VARIABLE ( /name --> ) o" trialign" nl
AddName o" : CALL _"
s" (CREATE)" name>label +>buf nl o" \tdd 0" nl nl ;M

\ создать именованную константу
M: CONSTANT ( n /name --> ) o" trialign" nl
DUP >L
NextWord DDUP (C:) L> LIT, label,
<: state IF o" \t\tCALL _" +>buf nl
ELSE DROP
THEN DROP
;> COMPILE,
[COMPILE] ;C
o" _" +>buf o" : CALL _"
s" (CONSTANT)" name>label +>buf nl o" \t" dd+ nl nl ;M

\ резервировать указанное количество минимально адресуемых ячеек памяти
\ в пространстве кода и данных
M: ALLOT ( u --> ) 1 OVER > ABORT" должно быть быть больше 0"
o" \tdb 0"
1 -
*IF FOR R@ 34 MOD
IFNOT o" \n\r\tdb 0" ELSE o" ,0" THEN \ заполняется нулями
TILL
ELSE DROP
THEN nl nl ;M

\ отметить последнее определение признаком немедленного исполнения
M: IMMEDIATE ( --> )
TRUE LASTDEF
[ ALSO HIDDEN ] &ALS SET-ATTR \ т.к. IMMEDIATE уже занят используется &ALS
[ PREVIOUS ] THROW ;M

\ добавить литеральное значение символа в текущее определение
M: [CHAR] ( / ch --> )
NextWord DROP C@
o" \t\tCALL _" s" (LIT)" name>label +>buf nl
-| dd+ nl ;M

\ компилировать в текущее определение указанное имя
M: [COMPILE] ( /name --> )
o" \t\tCALL _" NextWord name>label +>buf nl ;M

\ добавить текстовую строку в текущее определение,
\ при выполнении участка кода возвращается адрес asc и длина #
M: S" ( / ascii" --> | asc # )
[CHAR] " CookLine
state IF o" \t\tCALL _" s" (SLIT)" name>label +>buf nl
DUP o" \t\t" dd+ nl
*IF o" \t\t db "
FOR DUP C@ 0x10 {# S>D #S s" 0x" HOLDS #> +>buf
R@ 16 MOD IFNOT nl o" \t\t db "
ELSE o" ,"
THEN
1 +
TILL DROP
ELSE DDROP
THEN
THEN o" 0x00" nl ;M

\ преобразовать количество ячеек в количество байт
M: CELLS ( u --> u*cell )
state IF a" SAR EAX, 2"
ELSE CELL *
THEN ;M


\ -- определение примитивов ----------------------------------------------------

\ прерывание INT 3 - для отладки
M: INT3 a" INT3" ;M

\ вызов экспортируемых функций. Все параметры должны лежать на стеке данных
M: CallAPI a" MOV dword [fs:0x14], ESP"
a" MOV ESP, EBP"
a" CALL EAX"
a" MOV EBP, ESP"
a" MOV ESP, dword [fs:0x14]"
a" LEA EBP, [EBP+CELL]" ;M

\ получение адреса функций АПИ
M: 'GetStdHandle a" MOV EAX, dword [GetStdHandle]" ;M
M: 'WriteFile a" MOV EAX, dword [WriteFile]" ;M
M: 'ReadFile a" MOV EAX, dword [ReadFile]" ;M

\ макросы для работы со стеком
M: CPY a" MOV EAX, [EBP]" ;M \ копировать значение второго элеметна стека данных в TOS
M: SKP a" MOV EAX, [EBP+CELL]"
a" LEA EBP, [EBP+8]" ;M
M: ROOM a" LEA EBP, [EBP-CELL]" ;M
\ определение стековых манипуляций
M: NIP a" LEA EBP, [EBP+CELL]" ;M
M: DROP a" MOV EAX, [EBP]"
a" LEA EBP, [EBP+CELL]" ;M
M: DDROP a" MOV EAX, [EBP+CELL]"
a" LEA EBP, [EBP+CELL*2]" ;M
M: SWAP a" MOV EDX, EAX"
a" MOV EAX, [EBP]"
a" MOV dword [EBP], EDX" ;M
M: DUP a" LEA EBP, [EBP-CELL]"
a" MOV dword [EBP], EAX" ;M
M: DDUP a" MOV EDX, [EBP]"
a" MOV [EBP-CELL], EAX"
a" MOV [EBP-CELL*2], EDX"
a" LEA EBP, [EBP-CELL*2]" ;M
M: OVER a" MOV EDX, [EBP]"
a" LEA EBP, [EBP-CELL]"
a" MOV dword [EBP], EAX"
a" MOV EAX, EDX" ;M
M: ROT a" MOV EDX, [EBP]"
a" MOV [EBP], EAX"
a" MOV EAX, [EBP+CELL]"
a" MOV dword [EBP+CELL], EDX" ;M
\ работа с памятью
M: @ a" MOV EAX, [EAX]" ;M
M: STORE a" MOV EDX, [EBP]"
a" MOV dword [EAX], EDX" ;M
M: B@ a" MOVZX EAX, byte [EAX]" ;M
M: STOREB a" MOV EDX, [EBP]"
a" MOV byte [EAX], DL" ;M
\ литеральные значения
M: GETLIT a" LEA EDX, [EAX+CELL]"
a" MOV EAX, [EAX]" \ оставить на вершине стека данных литерал
o|" JMP EDX" ;M \ обойти в коде литеральное значение
M: GETDLIT a" LEA EDX, [EAX+CELL*2]"
a" MOV EBX, [EAX]"
a" MOV EAX, [EAX+CELL]"
a" MOV dword [EBP], EBX"
o|" JMP EDX" ;M
M: GETALIT a" LEA EDX, [EAX+TOKEN]"
a" MOV EAX, [EAX+1]"
o|" JMP EDX" ;M
M: (SLIT) a" LEA EBP, [EBP-8]"
a" MOV dword [EBP+CELL], EAX"
a" POP EBX"
a" LEA EDX, [EBX+CELL]"
a" MOV dword [EBP], EDX"
a" MOV EAX, [EBX]"
a" LEA EDX, [EBX+EAX+TOKEN]"
o|" JMP EDX" ;M
\ математика и логика
M: PLUS a" ADD EAX, [EBP]" ;M
M: MINUS a" MOV EDX, [EBP]"
a" SUB EDX, EAX"
a" MOV EAX, EDX" ;M
M: OR a" OR EAX, [EBP]"
a" LEA EBP, [EBP+CELL]" ;M
M: 0= a" SUB EAX, 1"
a" SBB EAX, EAX" ;M
M: more a" CMP EAX, [EBP]"
a" SETGE AL"
a" AND EAX, 1"
a" DEC EAX" ;M
M: less a" CMP EAX, [EBP]"
a" SETLE AL"
a" AND EAX, 1"
a" DEC EAX" ;M
M: U> a" CMP EAX, [EBP]"
a" SBB EAX, EAX"
a" LEA EBP, [EBP+CELL]" ;M
M: UM/MOD a" MOV ECX, EAX"
a" MOV EDX, [EBP]"
a" MOV EAX, [EBP+CELL]"
a" DIV ECX"
a" LEA EBP, [EBP+CELL]"
a" MOV dword [EBP], EDX" ;M
M: / a" MOV ECX, EAX"
a" MOV EAX, [EBP]"
a" CDQ"
a" IDIV ECX"
a" LEA EBP, [EBP+CELL]" ;M
M: S>D a" CDQ"
a" LEA EBP, [EBP-CELL]"
a" MOV [EBP], EAX"
a" MOV EAX, EDX" ;M
M: ABS a" MOV EDX, EAX"
a" SAR EDX, 31"
a" ADD EAX, EDX"
a" XOR EAX, EDX" ;M
M: MIN_ a" CMP EAX, [EBP]"
o|" JL _2st"
a" MOV EAX, [EBP]"
a" _2st: LEA EBP, [EBP+CELL]" ;M

\ перемещение между стеками
M: TOSP a" MOV EBP, EAX" ;M
M: SP@ a" MOV EDX, EAX"
a" MOV EAX, EBP"
a" LEA EBP, [EBP-CELL]"
a" MOV dword [EBP], EDX" ;M
M: TORP a" POP EDX"
a" MOV ESP, EAX"
a" MOV EAX, [EBP]"
a" LEA EBP, [EBP+CELL]"
o|" JMP EDX" ;M
M: ATRP a" MOV EAX, ESP" ;M
M: TOR a" POP EDX"
a" PUSH EAX"
a" MOV EAX, [EBP]"
a" LEA EBP, [EBP+CELL]"
o|" JMP EDX" ;M
M: FROMR a" POP EDX"
a" POP EAX"
o|" JMP EDX" ;M
M: RVAR a" POP EAX" ;M \ вернуть адрес следующей ячейки на вершину стека данных
M: PSFA a" MOV EDX, [EAX]" \ увеличит значение ячейки на указанную величину,
a" ADD EDX, [EBP]"
a" MOV dword [EAX], EDX" \ оставить на вершине стека данных полученное значение
a" MOV EAX, EDX" ;M
\ ветвления
M: BR a" POP EDX"
o|" JMP dword [EDX]" ;M
M: ?BR a" OR EAX, EAX"
a" MOV EAX, [EBP]"
a" LEA EBP, [EBP+CELL]"
o" \tJZ " s" BRANCH" name+>buf nl
a" POP EDX"
a" LEA EDX, [EDX+CELL]"
o|" JMP EDX" ;M
M: N?BR a" OR EAX, EAX"
a" MOV EAX, [EBP]"
a" LEA EBP, [EBP+CELL]"
o" \tJNZ " s" BRANCH" name+>buf nl
a" POP EDX"
a" LEA EDX, [EDX+CELL]"
o|" JMP EDX" ;M
M: EXIT_ a" LEA ESP, [ESP+CELL]" ;M

\ настройка системы перед запуском
M: STARTUP a" LEA EBP, [EBP-256]" \ раздвинуть стеки
;M

Содержимое файла f2am.asm не изменилось.
Результат можно собрать с помощью fasm и запустить, но функционально не закончено, т.к. нет времени катастрофически. Собственно, дальше только форт-систему надо развивать(текущий код в следующем посте), а сам транслятор практически завершен.

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Форт-транслятор в Ассемблер _ вариант 2
СообщениеДобавлено: Вт янв 20, 2015 19:57 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 5062
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 23 раз.
Поблагодарили: 63 раз.
\ пример транслируемого текста
TRANSLATE: zzz

\ первое определение
: NOOP ( --> ) ;

\ удалить элемент под вершиной стека
: NIP ( a b --> b ) NIP ;

\ удалить значение с вершины стека данных
: DROP ( n --> ) DROP ;

\ удалить d с вершины стека данных
: DDROP ( d --> ) DDROP ;

\ дублировать значение n на вершине стека данных
: DUP ( n --> n n ) DUP ;

\ дублировать значение d на вершине стека данных
: DDUP ( d --> d d ) DDUP ;

\ обменять значения двух ячеек на вершине стека данных
: SWAP ( a b --> b a ) SWAP ;

\ положить на вершину стека данных копию значения второго элемента
: OVER ( a b --> a b a ) OVER ;

\ Прокрутить три верхних элемента стека.
: ROT ( a b c --> b c a ) ROT ;

\ извлечь значение с указанного адреса
: @ ( addr --> n ) @ ;

\ сохранить значение n по указанному адресу
: ! ( n addr --> ) STORE SKP ;

\ извлечь значение байта b по указанному адресу addr
: B@ ( addr --> b ) B@ ;

\ сохранить значение байта b по указанному адресу addr
: B! ( b addr --> ) STOREB SKP ;

\ сложить два числа на вершине стека данных, результат оставить на вершине
: + ( n1 n2 --> n ) PLUS NIP ;

\ сложить два числа на вершине стека данных, результат оставить на вершине
: - ( n1 n2 --> n ) MINUS NIP ;

\ знаковое деление чисел одинарной длины
: / ( na nb --> n ) / ;

\ логическое или над двумя операндами на вершине стека даных
: OR ( na nb --> n ) OR ;

\ поделить беззнаковое число двойной точности
\ на беззнаковое число одинарной точности
\ результат - частное и остаток от деления
: UM/MOD ( ud u1 --> div mod ) UM/MOD ;

\ Преобразовать число n в двойное число d с тем же числовым значением.
: S>D ( n --> d ) S>D ;

\ найти абсолютное значение числа
: ABS ( n --> u ) ABS ;

\ оставить минимальное n из двух чисел na, nb на вершине стека данных
: MIN ( na nb --> n ) MIN_ ;

\ увеличить значение, хранящееся по addr на n,
\ результат сохранить по addr и оставить на вершине стека данных
: +!@ ( n addr --> x+n ) PSFA NIP ;

\ переместить указатель вершины стека данных на указанный адрес
\ в TOS остается значение
: SP! ( addr --> ) TOSP ;

\ вернуть адрес вершины стека данных
: SP@ ( --> addr ) SP@ ;

\ переместить указатель вершины стека возвратов на указанный адрес
: RP! ( addr --> ) TORP ;-

\ вернуть адрес вершины стека возвратов
: RP@ ( --> addr ) DUP ATRP ;

\ перенести значение с вершины стека данных на вершину стека возвратов
: >R ( addr --> r: addr ) TOR ;

\ перенести значение с вершины стека возвратов на вершину стека данных
: R> ( r: addr --> addr ) DUP FROMR ;

\ выложить на вершину стека данных значение,
\ скомпилированное в коде за вызовом (LIT)
: (LIT) ( --> n ) DUP RVAR GETLIT ;-

\ выложить на вершину стека данных значение,
\ скомпилированное в коде за вызовом (LIT)
: (DLIT) ( --> n ) DUP DUP RVAR GETLIT ;-

\ вернуть адрес слова, вызов которого скомпилирован в коде вслед за (')
: (`) ( --> addr ) DUP RVAR GETALIT ;-

\ вернуть адрес начала строки asc, размещенной в коде за (SLIT), и ее длину #
: (SLIT) ( --> asc # ) (SLIT) ;-

\ положить на вершину стека адрес переменной
: (CREATE) ( --> addr ) DUP RVAR ;

\ положить на вершину стека значение
: (CONSTANT) ( --> n ) DUP RVAR @ ;

\ проверка числа на 0
: 0= ( n --> flag ) 0= ;

\ сравнить числа na и nb
: > ( na nb --> flag ) more NIP ;
: U> ( ua ub --> flag ) U> ;

\ сравнить числа na и nb
: < ( na nb --> flag ) less NIP ;

\ выйти из текущего определения
: EXIT ( --> ) EXIT_ ;

\ безусловное ветвление
: BRANCH ( --> ) BR ;-

\ условное ветвление
: ?BRANCH ( n --> n ) ?BR ;-

\ условное ветвление
: N?BRANCH ( n --> n ) N?BR ;-

\ размер буферов TIB и PAD в байтах
0x100 CONSTANT TIB# ( --> # )
0x100 CONSTANT PAD# ( --> #)

\ terminal input buffer
CREATE TIB TIB# ALLOT

\ указатель на первый неразобранный символ во входном буфере
VARIABLE >IN

\ указатель на последний введенный символ
VARIABLE #TIB

\ Дно стека данных
VARIABLE S0 ( --> addr )

\ Дно стека возвратов
VARIABLE R0 ( --> addr )

\ размеры стеков
0x1000 CONSTANT DataStack#
0x1000 CONSTANT ReturnStack#

\ Хранит адрес первой свободной ячейки памяти в пространстве кода и данных
VARIABLE DP ( --> addr )

\ Хранит адрес первой свободной ячейки памяти в пространстве имен
VARIABLE HDP ( --> addr )

\ стандартные потоки В\В
VARIABLE STDIN \ входной
VARIABLE STDOUT \ выходной
VARIABLE STDERR \ выходной для ошибок

\ флаг необходимости извещения о повторном использовании уже существующего имени определения
VARIABLE WARNING

\ текущее состоянии системы (интерпретация\компиляция)
VARIABLE STATE

\ переключение состояния системы
: [ ( --> ) 0 STATE ! ; IMMEDIATE
: ] ( --> ) -1 STATE ! ;

4 CONSTANT CELL \ размер ячейки, байт
4 CONSTANT ADDR \ размер адресной ссылки, байт

\ преобразовать значение количетсва ячеек в количество минимально адресуемых единиц (байт)
: CELLS ( u --> # ) CELLS ;

\ вернуть адрес первой свободной ячейки памят в пространстве кода и данных
: HERE ( --> addr ) DP @ ;

\ вернуть адрес первой свободной ячейки памят в пространстве имен
: HHERE ( haddr --> addr ) HDP @ ;

\ добавить в конец файла fid содержимое строки Asc #
: WRITE-FILE ( asc # fid --> # )
>R >R >R 0 SP@ DUP R> R> SWAP R>
DUP 'WriteFile CallAPI DROP ;

\ читать в буфер asc строку длиной не более # символов содержимое файла fid
: READ-FILE ( asc # fid --> # )
>R >R >R 0 SP@ DUP R> R> SWAP R>
DUP 'ReadFile CallAPI DROP ;

\ вывести в текущий STDOUT поток указанную строку
: TYPE ( asc # --> ) STDOUT @ WRITE-FILE DROP ;

\ вывести символ в текущий поток В\В
: EMIT ( char --> ) SP@ 1 TYPE DROP ;

\ текущая система счисления
VARIABLE BASE

\ переключения системы счисления
: DECIMAL ( --> ) 0x0A BASE ! ;
: HEX ( --> ) 0x10 BASE ! ;

\ буфер для форматного преобразования чисел и строк
CREATE PAD PAD# ALLOT
\ буфер обычно заполняется с конца, поэтому необходим адрес конца буфера
LABEL: PadTop

\ указатель на последний символ в PAD
VARIABLE HLD

\ начать форматное преобразование строки
: <# ( --> ) PadTop HLD ! ;

\ задать текущую систему счисления и начать форматное преобразование строки
: {# ( base --> ) BASE ! <# ;

\ завершить форматное преобразование строки, вернуть адрес asc и длину # полученной строки
: #} ( --> asc # ) HLD @ PAD PAD# + OVER - ;

\ то же, что и #}, только предварительно удаляет число двойной длины с вершины стека данных
: #> ( d --> asc # ) NIP DROP #} ;

\ добавляет символ char в позицию HLD, сам HLD уменьшает на размер одного символа
: HOLD ( char --> ) -1 HLD +!@ B! ; \ -1 HLD @ + PAD UMAX DUP HLD ! B!

\ преобразовать число в символ
\ число не должно превышать значение находящееся в BASE
: >DIGIT ( u --> char ) DUP 9 > IF 7 + THEN 0x30 + ;

\ добавить в буфер PAD остаток от деления двойного числа на содержимое BASE
: # ( ud1 --> ud2 ) 0 BASE @ UM/MOD >R BASE @ UM/MOD R> ROT >DIGIT HOLD ;

\ Если n отрицательно, добавить в PAD символ '-'
: SIGN ( n --> ) 0 < IF [CHAR] - HOLD THEN ;

\ преобразовать число двойной длинны в строку
: #S ( ud --> 0 0 ) BEGIN # DDUP OR WHILE REPEAT ;

\ константы значения спецсимволов
0x20 CONSTANT Bl_
0x0A CONSTANT Cr_
0x0D CONSTANT Lf_

\ преобразовать число одинарной длинны в строку
\ в десятичной системе независимо от значения BASE
: (.) ( n --> asc # ) DUP >R ABS S>D <# #S R> SIGN #> ;

\ вывести число в текущей системе счисления в выходной поток
: . ( n --> ) (.) TYPE ;

\ перевод строки
: CR ( --> ) S" \n\r" TYPE ;

\ текущая глубина стека данных
: DEPTH ( --> n ) SP@ S0 @ SWAP - CELL / ;

\ приглашение
: PROMPT ( --> ) DEPTH . STATE @ IF S" ]" ELSE S" [" THEN TYPE ;

\ получить очередную строку из STDIN в буфер TIB
: QUERY ( --> ) TIB TIB# STDIN @ READ-FILE #TIB ! 0 >IN ! ;

\ -- парсер --------------------------------------------------------------------

\ является ли символ char пробельным
: n?sep ( char --> flag ) Bl_ > ;

\ адрес первого неразобранного символа
: CharAddr ( --> addr ) TIB >IN @ + ;

\ прочесть символ из текущего значения >IN
: PeekChar ( --> char ) CharAddr B@ ;

\ пропустить один символ во входном потоке
: SkipChar ( --> ) >IN @ 1 + #TIB @ MIN >IN ! ;

\ вернуть TRUE если весь текст уже разобран
: ?COMPLETE ( --> flag ) #TIB @ >IN @ < ;

\ взять очередной символ из входного потока
\ flag = TRUE если входной поток исчерпан
: NextChar ( --> char flag ) PeekChar ?COMPLETE SkipChar ;

\ пропустить все символы разделители до первого значащего символа,
\ либо до конца разбираемой строки
: MissSeparators ( --> ) INT3
BEGIN NextChar WHILENOT
n?sep WHILENOT
REPEAT EXIT
THEN DROP ;

\ пропустить текст вплодь до разделителя
: MissLexeme ( --> ) INT3
BEGIN NextChar WHILENOT
n?sep WHILE
REPEAT EXIT
THEN DROP ;

\ выделить из буфера блок символов вплоть до разделителя
: PassLexeme ( --> asc # ) CharAddr MissLexeme CharAddr OVER - ;

\ Получить адрес и длину очередной лексемы
: NextWord ( --> asc # ) MissSeparators PassLexeme ;


16 CONSTANT WORDLISTS \ количество словарей в системе

\ текущий словарь ( в который ведется добавление имен)
VARIABLE CURRENT
\ стек словарей для поиска
CREATE CONTEXT WORDLISTS CELLS ALLOT
LABEL: CNSP \ вершина списка словарей

\ сделать верхний текущий словарь контекстным
: DEFINITIONS ( --> ) CONTEXT @ CURRENT ! ; \ !!! написать нормально

\ идентификатор словаря FORTH
: FORTH-WORDLIST ( --> wid ) 1 ; \ !!! написать нормально

\ инициализация контекста
: ONLY ( --> ) FORTH-WORDLIST CONTEXT ! ; \ !!! написать нормально

\ выполнить действие над очередной лексемой
: EVAL-TOKEN ( asc # --> ) CR TYPE ;

\ интерпретировать входной поток
\ : INTERPRET ( --> ) BEGIN NextWord DUP WHILE EVAL-TOKEN REPEAT DDROP ;
: INTERPRET ( --> ) TIB #TIB @ TYPE CR ;

\ проверка протекания стека данных
: ?STACK ( --> )
SP@ S0 @ U> IF S" Исчерпание стека данных!\n\r" TYPE S0 @ SP! THEN ;

\ основной цикл системы
: QUIT ( --> )
[COMPILE] [
DECIMAL CR
BEGIN PROMPT
QUERY
INTERPRET
?STACK
AGAIN ;

\ инициализация системы после ошибки
: ABORT ( --> )
S0 @ SP!
R0 @ RP!
ONLY DEFINITIONS
QUIT ;

\ инициализация идентификаторов потоков В/В
: INIT-IO ( --> )
-10 DUP 'GetStdHandle CallAPI STDIN !
-11 DUP 'GetStdHandle CallAPI STDOUT !
-12 DUP 'GetStdHandle CallAPI STDERR ! ;

\ приветствие после запуска системы
: TITLE ( --> ) S" \n\rHello!\n\r" TYPE ;

\ сделать вектором!
: MAIN ( --> ) TITLE ;

\ холодный запуск системы
: COLD ( --> )
STARTUP \ для начала раздвигаются указатели стеков
RP@ DUP R0 ! \ стек возвратов под стеком данных используется для хранения
\ только внутренних вызовов, т.к. АПИ очень сильно жрет стек
ReturnStack# - S0 !
INIT-IO
DECIMAL
MAIN
ABORT ;

\ последнее определение системы
CREATE FENCE ( --> )

;TRANSLATE

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Форт-транслятор в Ассемблер _ вариант 2
СообщениеДобавлено: Вт янв 20, 2015 20:00 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 5062
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 23 раз.
Поблагодарили: 63 раз.
ну и получающийся 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)

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
Показать сообщения за:  Поле сортировки  
Начать новую тему Ответить на тему  [ Сообщений: 10 ] 

Часовой пояс: UTC + 3 часа [ Летнее время ]


Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 1


Вы не можете начинать темы
Вы можете отвечать на сообщения
Вы не можете редактировать свои сообщения
Вы не можете удалять свои сообщения
Вы не можете добавлять вложения

Powered by phpBB © 2000, 2002, 2005, 2007 phpBB Group
phpBB сборка от FladeX // Русская поддержка phpBB