Forth и другие саморасширяющиеся системы программирования Locations of visitors to this page
Текущее время: Сб июл 30, 2016 09:18

...
Google Search
Forth-FAQ Spy Grafic

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




Ответить
Имя пользователя:
Заголовок:
Текст сообщения:
Введите текст вашего сообщения. Длина сообщения в символах не более: 60000

Размер шрифта:
Цвет шрифта
Настройки:
BBCode ВКЛЮЧЕН
[img] ВЫКЛЮЧЕН
[flash] ВЫКЛЮЧЕН
[url] ВКЛЮЧЕН
Смайлики ВЫКЛЮЧЕНЫ
Отключить в этом сообщении BBCode
Не преобразовывать адреса URL в ссылки
Вопрос
Теперь гостю придется вводить здесь пароль. Не от своей учетной записи, а ПАРОЛЬ ДЛЯ ГОСТЯ, получить который можно после регистрации на форуме через ЛС.:
Этот вопрос предназначен для выявления и предотвращения автоматических регистраций.
   

Обзор темы - 3-х стековая виртуальная машина. размышления.
Автор Сообщение
  Заголовок сообщения:  Re: 3-х стековая виртуальная машина. размышления.  Ответить с цитатой
урря, нашлось:
Код:
; 14.01.2010 mOleg
; набросок трехстековой Форт Виртуальной Машины (ФВМ)
; стеки: данных, возвратов, адресов

; подпрограммный шитый код без оптимизаций
; в двух секциях: код отдельно от пространства имен

; без VALUE и VECT переменных
; без многопоточности и локальных областей данных
; без словарей (один список слов)
; без опроса клавиш (через readfile)
; без поддержки механизма исключений
; без ускорения поиска имен в списке слов
; без отдельного распознавания чисел (спец префиксы перед числами)

format PE console ; под винду

entry _cold ; стартовый адрес

include 'include\win32a.inc'
include 'include\macro\struct.inc'

; ------------------------------------------------------------------------------

section '.import' import data readable writeable
                               ;
  library kernel,'KERNEL32.DLL'

  import kernel,\
         LoadLibrary, 'LoadLibrary',\
         GetProcAddress, 'GetProcAddress',\
         ExitProcess, 'ExitProcess',\
         GetStdHandle, 'GetStdHandle',\
         WriteFile, 'WriteFile',\
         ReadFile, 'ReadFile'
; ------------------------------------------------------------------------------

; использование регистров

  tos equ EAX ; кеш вершины стека данных
  toa equ EBX ; кеш вершины стека возвратов

temp equ EDX ; временный регистра
cnt  equ ECX

  tad equ EBP ; указатель на вершину стека данных
  tar equ ESP ; указатель на вершину стека возвратов
  taa equ ESI ; указатель на вершину стека адресов

; типы данных

struct cell
        body dd ? ;
    ends

struct addr
        body dd ? ;
    ends

struct token
        call db 0xE8
        ref  dd ?
     ends

struct scnt
        body db ?
     ends

struct ref
        body dd ?
     ends

; ------------------------------------------------------------------------------
; объявление констант

ADDR  = sizeof.addr  ; размер адресной ссылки
CELL  = sizeof.cell  ; размер ячейки данных
REF   = sizeof.ref   ; размер ссылки
TOKEN = sizeof.token ; размер токена
SCNT  = sizeof.scnt  ; размер счетчика длины


dStack equ 0x1000 ; размер стека данных
aStack equ 0x1000 ; размер стека адресов
rStack equ 0x1000 ; размер стека возвратов

TIB_size = 0x50
PAD_size = 0x50

NamesSpace = 0x10000
CodeSpace  = 0x10000

ImmWord = -1 ; признак слова немедленного исполнения
StdWord =  1 ; признак обычного слова

; вычисляем сколько места надо выделять под стеки
stack (dStack+aStack+rStack)*2, dStack+aStack+rStack

; ------------------------------------------------------------------------------

latest = 0

; описатель форт-строк
macro fstr [string]
       { common local .count, .body
        .count scnt ?
        .body  db string,0
        store $-.body-1 at .count
        }

macro slit [str]
      { local labxx
        call _box
        addr labxx
         fstr str
        align
        labxx: }

; формат заголовка имени (подробнее см. _sHeader)
macro def string,cfa,flg
       { dd latest
         latest=$-CELL
         addr cfa
         db flg
         common local .count, .body
         .count scnt ?
         .body db string,0
        store $-.body-1 at .count
        }

; перемещение указателей стеков
macro dheave val { lea tad , [tad+val] }
macro aheave val { lea taa , [taa+val] }
macro rheave val { lea tar , [tar+val] }

macro rpop reg
       { pop reg }
macro rpush reg
       { push reg }

macro dpush reg
       { dheave -CELL
         mov [tad], tos
         if reg eq tos
          else
            mov tos, reg
         end if }

macro dpop reg
       { mov reg, [tad]
         lea tad, [tad+CELL] }

macro apush reg
       { aheave -CELL
         mov [taa], toa
         if reg eq toa   ; если dup, то не надо mov r,r
          else
            mov toa, reg
         end if }

macro apop reg
       { mov reg, [taa]
         lea taa, [taa+ADDR] }

macro dlit val
       { call _dlit
         cell val }
macro alit val
       { call _alit
         addr val }
macro rlit val { push val }

allot equ rb

; macro mIF ; как написать макро для компиляции перехода вперед?

macro align
      { repeat (($+CELL-1)and -CELL)-$
          nop
        end repeat }

macro VARIABLE deffname
      { label deffname
        call _avariable
        allot ADDR
        align }

macro CREATE defname
      { label defname
        call _create }

macro fcode [words]
        { call words }

macro exit
      { ret
        align }

macro ERROR [msg]
      { slit msg
        call _count
        call _error }

macro MESSAGE [string]
      { slit string
        call _print
        call _cr }

; ------------------------------------------------------------------------------

section '.fvm' code executable readable writeable

;
_dup:   ;( d: n --> d: n n )
        dpush tos
;
_noop:  ;( --> )
        exit
;
_drop:  ;( d: n --> )
        dpop tos
        exit
;
_swap:  ;( d: a b --> d: b a )
        mov temp, [tad]
        mov [tad], tos
        mov tos, temp
        exit
;
_over:  ;( d: a b --> d: a b a )
        mov temp, [tad]
        dpush temp
        exit
;
_plus:  ;( d: a b --> d: a+b )
        add tos, [tad]
        dheave CELL
        exit
;
_minus: ;( d: a b --> d: a-b )
        sub tos, [tad]
        dheave CELL
        exit
;
_mul: ;( d: a b --> d: a-b )
        mul dword [tad]
        dheave CELL
        exit
;
_xor:   ;( d: a b --> d: n )
        xor tos, [tad]
        dheave CELL
        exit
;
_and:   ;( d: a b --> d: n )
        and tos, [tad]
        dheave CELL
        exit
;
_or:    ;( d: a b --> d: n )
        or tos, [tad]
        dheave CELL
        exit
;
_abs:   ;( d: n --> d: u )
        mov temp , tos
        sar temp , 31
        add tos , temp
        xor tos , temp
        exit
;
_moddiv: ;( d: n n --> d: n n )
        mov cnt, tos
        xor temp, temp
        mov tos, [tad]
        div cnt
        mov [tad], EDX
        exit
;
_dlit:  ;( --> d: n )
        pop temp
        dpush [temp]
        lea temp, [temp+CELL]
        jmp temp
        align
;
_adup:  ;( a: addr --> addr addr )
        apush toa
        exit
;
_alit:  ;( --> a: addr )
        pop temp
        apush toa
        mov toa, [temp]
        lea temp, [temp+CELL]
        jmp temp
        align
;
_rlit:  ;( --> r: addr )
        rpop temp
        rpush dword [temp]
        lea temp, [temp+ADDR]
        jmp temp
        align
;
_qnil:  ;( a: addr --> a: addr d: flag )
        dpush tos
        mov tos, toa
        sub tos, 1
        sbb tos, tos
        exit
;
_aadd: ;( a: addr d: u --> a: addr+u )
        lea toa, [toa+tos]
        dpop tos
        exit
;
_create: ;( --> a: addr )
_avariable: ;( --> a: addr )
        apush toa
        pop toa
        exit
;
_Astore: ;( a: addr addr --> )
        apop temp
        mov dword [toa], temp
        apop toa
        exit
;
_Afetch: ;( a: addr --> a: addr )
        mov toa, dword [toa]
        exit
;
_store: ;( a: addr d: n --> )
        mov dword [toa], tos
        dpop tos
        apop toa
        exit
;
_fetch: ;( a: addr --> d: n )
        dpush tos
        mov tos, dword [toa]
        apop toa
        exit
;
_execute: ;( a: xt --> )
        mov temp, toa
        apop toa
        call temp
        exit
;
_branch: ;( --> )
        rpop temp
        jmp dword [temp]
        align
;
_0branch: ;( d: flag --> d: flag ) без удаления флагового значения
        rpop temp
        or tos,tos
        jz lab00
        lea temp, [temp+REF]
        jmp temp
lab00: jmp dword [temp]
        align
;
_d2r:   ;( d: n --> r: n )
        rpop temp
        rpush tos
        dpop tos
        jmp temp
        align
;
_RPfetch: ;( --> a: addr )
        apush tar
        exit
;
_APfetch: ;( --> a: addr )
        apush taa
        exit
;
_SPfetch: ;( --> a: addr )
        apush tad
        exit
;
_RPstore: ;( a: addr --> )
        rpop temp
        mov tar, toa
        apop toa
        jmp temp
;
_APstore: ;( a: addr --> )
        mov taa, toa
        apop toa
        exit
;
_SPstore: ;( a: addr --> )
        mov tad, toa
        apop toa
        exit
;
_a2r: ;( a: addr --> r: addr )
        rpop temp
        rpush toa
        apop toa
        jmp temp
        align
;
_rdrop: ;( r: addr --> )
        rpop temp
        rheave -CELL
        jmp temp
        align
;
_off:   ;( a: addr --> )
        mov dword [toa], 0
        apop toa
        exit
;
_count: ;( a: addr --> a: addr d: # )
        dpush tos
        and tos, tos
        mov AL, [toa]
        lea toa, [toa+SCNT]
        exit
;
_Aswap: ;( a: a1 a2 --> a2 a1 )
        xchg toa, dword [taa]
        exit
;
_r2a: ;( r: addr --> a: addr )
      rpop temp
      apush toa
      rpop toa
      jmp temp
;
_adrop: ;( a: addr --> )
      apop toa
      exit
; удалить адресную ссылку, находящуюся под вершиной стека адресов
_anip: ;( a: a1 a2 --> a: a2 )
      aheave ADDR
      exit
; извлечь байт данных из памяти по адресу,
; хранимому на вершине стека адресов, на вершину стека данных
_bfetch: ;( a: addr --> d: byte )
      dpush tos
      movzx tos, byte [toa]
      apop toa
      exit
; сохранить байт данных с вершины стека данных по адресу,
; хранимому на вершине стека адресов
_bstore: ;( a: addr d: byte --> )
      mov byte [toa], AL ; tos
      dpop tos
      apop toa
      exit
; переслылка указанного количества # минимально адресуемых единиц
; c адреса src в пространства начинающегося с адреса dst
_cmove: ;( d: # a: src dst --> )
       mov cnt, tos
       apop temp
       jcxz lab31
lab30: mov AL, byte [temp]
        mov byte [toa], AL
       lea temp, [temp+1]
       add toa, 1
       loop lab30
lab31: apop toa
       dpop tos
       exit

; переменная last хранит адрес последнего слова в цепочке имен
_last: call _create
       dd LATEST ; LATEST определен в конце списка имен
align
;
VARIABLE _latest
;
_MAIN: call _create
       dd _abort ; главное слово системы
align
;
_DP: call _create
       dd _there ; указатель на первый свободный байт системы
align
;
_NDP: call _create
       dd NSADDR ; указатель на первый свободный байт в пространстве имен
align

VARIABLE _S0 ; переменная для хранения дна стека данных
VARIABLE _A0 ;                                   адресов
VARIABLE _R0 ;                                   возвратов

; входной буфер системы
CREATE _tib
       allot TIB_size
       align
; буфер для форматного преобразования строк
CREATE _pad
       allot PAD_size
       align

VARIABLE _STATE ; текущий режим работы системы: компиляция\интерпретация
VARIABLE _BASE  ; текущая система счисления системы

VARIABLE _CURRENT ; хранит адрес хвоста списка добавляемых слов
VARIABLE _CONTEXT ; хранит адрес хвоста списка искомых слов

VARIABLE _TIBsize ; количество байт в tib
VARIABLE _IN      ; текущая позиция трансляции текста

VARIABLE _STDIN  ;
VARIABLE _STDOUT ;
VARIABLE _STDERR ;

VARIABLE _WARNING
VARIABLE _HLD

;
CREATE _NewLine
       fstr 0x0d,0x0a
       align

;-------------------------------------------------------------------------------
_cell: ;( --> d: cell# )
       dpush CELL
       exit
_addr: ;( --> d: addr# )
       dpush ADDR
       exit
_token: ;( --> d: token# )
       dpush TOKEN
       exit
_scnt: ;( --> d: scnt# )
       dpush SCNT
       exit
_ref: ;( --> d: ref# )
       dpush REF
       exit
;
_son: ;( --> )
      mov dword [_STATE+TOKEN], -1
      exit
;
_soff: ;( --> )
      mov dword [_STATE+TOKEN], 0
      exit
;
_here: ;( --> a: addr )
       apush dword [_DP+TOKEN]
       exit
;
_nhere: ;( --> a: addr )
       apush dword [_NDP+TOKEN]
       exit
; аналог ALLOT
_reserve: ;( d: u --> a: addr )
       apush toa
       MOV toa, dword [_DP+TOKEN]
       LEA tos, [tos+toa]
       MOV dword [_DP+TOKEN], tos
       dpop tos
       exit
;
_atod: ;( a: xt --> d: disp )
       dpush tos
       mov tos, dword [_DP+TOKEN]
       sub tos, toa
       apop toa
       exit
;
_cbyte: ;( d: byte --> )
       MOV temp, [_DP+TOKEN]
       INC dword [_DP+TOKEN]
       MOV byte [temp], AL ; tos
       dpop tos
       exit
;
_cref: ;( d: ref --> )
       mov temp, [_DP+TOKEN]
       add dword [_DP+TOKEN], REF
       mov dword [temp], tos
       dpop tos
       exit
;
_dcomp: ;( d: n --> )
       mov temp, [_DP+TOKEN]
       add dword [_DP+TOKEN], CELL
       mov dword [temp], tos
       dpop tos
       exit
;
_acomp: ;( a: addr --> )
       MOV temp, dword [_DP+TOKEN]
       ADD dword [_DP+TOKEN], ADDR
       MOV dword [temp], toa
       apop toa
       exit
; NA,
_nacomp: ;( a: addr --> )
       mov temp, dword [_NDP+TOKEN]
       add dword [_NDP+TOKEN], ADDR
       mov dword [temp], toa
       apop toa
       exit
; NB,
_nbcomp: ;( d: byte --> )
       mov temp, dword [_NDP+TOKEN]
       inc dword [_NDP+TOKEN]
       mov byte [temp], AL
       dpop tos
       exit
;
_nccomp: ;( d: n --> )
       mov temp, dword [_NDP+TOKEN]
       add dword [_NDP+TOKEN], CELL
       mov dword [temp], tos
       dpop tos
       exit
;
_ctoken: ;( a: xt --> )
       dpush 0xE8
       call _cbyte
       call _atod
       call _cref
       exit
;
_cexit: ;( --> )
       dpush 0xC3
       call _cbyte
       exit
; NS, компиляция строки в пространство имен
_cns: ;( a: asc d: # --> )
       apush toa
       mov toa, [_NDP+TOKEN]
       add dword [_NDP+TOKEN], tos
       call _cmove
       exit
; компиляция строки со счетчиком в пространство имен
_cnstr: ;( a: addr d: # --> )
       dpush tos
       call _nbcomp
       call _cns
       dpush 0
       call _nbcomp
       exit
;
_cs: ;( a: asc d: # --> )
       apush toa
       mov toa, [_DP+TOKEN]
       add dword [_DP+TOKEN], tos
       call _cmove
       exit
;
_cstr: ;( a: addr d: # --> )
       dpush tos
       call _cbyte
       call _cs
       dpush 0
       call _cbyte
       exit
;-------------------------------------------------------------------------------
; <#
_lbdiez: ;( --> )
       lea temp, [_pad+TOKEN+TIB_size-1]
       mov dword [_HLD+TOKEN], temp
       mov byte [temp], 0
       exit
; #>
_diezrb: ;( d: x --> a: addr d: # )
       apush toa
       mov toa, [_HLD+TOKEN]
       lea tos, [_pad+TOKEN+TIB_size-1]
       sub tos, toa
       exit
;
_hold: ;( d: char --> )
       dec dword [_HLD+TOKEN]
       mov temp, [_HLD+TOKEN]
       mov [temp], AL
       dpop tos
       exit
;
_sign: ;( --> )
       dpush 0x2D
       call _hold
       exit
; >DIGIT
_digit: ;( d: u --> d: char )
       cmp tos, 0x0A
       js lab15
       lea tos, [tos+7]
lab15: lea tos, [tos+0x30]
       exit
; в отличие от стандартного форта, числа одинарной длины
_diez: ;( d: u --> d: u )
       xor edx,edx
       idiv dword [_BASE+TOKEN]
       dpush temp
       call _digit
       call _hold
       exit
; #S в отличие от стандартного форта число одинарной длины
_sdiez: ;( d: u --> d: 0 )
lab16: or tos, tos
       jz lab17
       call _diez
       jmp lab16
lab17: exit
;
_unum: ;( d: u --> a: addr d: # )
       call _lbdiez
       call _sdiez
       call _diezrb
       exit
;
_snumt: ;( d: u --> )
       call _unum
       call _type
       exit
;-------------------------------------------------------------------------------
;
_2cipher: ;( d: char --> d: u )
       cmp tos, 0x3A
       js lab20
       cmp tos, 0x5B
       js lab21
       lea tos, [tos-87]
       exit
lab21: lea tos, [tos-55]
       exit
lab20: lea tos, [tos-48]
       exit
;
_val: ;( a: addr d: # --> d: ?? )
       mov cnt, tos
       xor tos, tos
       jcxz lab23
       cmp byte [toa], 0x2D ; ? -
       pushf
       jnz lab22 ; число положительное
       lea toa, [toa+1]
       sub cnt, 1
       jnz lab22
lab23: ERROR 'Must be number!'
       align
lab22: imul dword [_BASE+TOKEN]
       rpush tos
       movzx tos, byte [toa]
       call _2cipher
       cmp tos, dword [_BASE+TOKEN]
       jns lab23
       add tos, dword [tar]
       lea tar, [tar+CELL]
       inc toa
       loop lab22
       apop toa
       popf
       jnz lab24
       neg tos
lab24: exit
;-------------------------------------------------------------------------------
;
_clit: ;( d: n --> )
       apush _dlit
       call _ctoken
       call _dcomp
       exit
;
_calit: ;( a: addr --> )
       apush _alit
       call _ctoken
       call _acomp
       exit
;
_literal: ;( d: n --> | n )
       cmp dword [_STATE+TOKEN], 0
       jz lab25
       call _clit
lab25: exit
;
_dnum:  ;( / decimal --> d: n )
       call _NextToken
       call _val
       call _literal
       exit
;
_aliteral: ;( a: addr --> a: addr | )
       cmp dword [_STATE+TOKEN], 0
       jz lab26
       call _calit
lab26: exit
;
_anum: ;( / hex --> a: addr )
       call _NextToken
       rpush dword [_BASE+TOKEN]
       mov dword [_BASE+TOKEN], 0x10
       call _val
       apush toa
       mov toa, tos
       dpop tos
       rpop dword [_BASE+TOKEN]
       call _aliteral
       exit
;-------------------------------------------------------------------------------
; завершить последнее определение
_ecreate: ;( --> )
       mov cnt, dword [_latest+TOKEN] ;
       jcxz lab40
       mov temp, dword [_last+TOKEN]
       mov dword [cnt], temp
       mov dword [_last+TOKEN], cnt   ; сохранить LATEST в LAST
       mov dword [_latest+TOKEN], 0
lab40: exit
;
_round: ;( a: addr d: # --> )
        XOR EDX, EDX
        mov cnt, tos
        lea tos, [toa+tos-1]
        idiv cnt
        imul cnt
        mov toa, tos
        dpop tos
        exit
;
_align: ;( --> )
       call _here
       call _cell
       call _round
       mov dword [_DP+TOKEN], toa
       apop toa
       exit
;
_nalign: ;( --> )
       call _nhere
       call _cell
       call _round
       mov dword [_NDP+TOKEN], toa
       apop toa
       exit

; формат заголовка:
; addr[] off_back
; addr[] off_code
; byte[] off_attr
; scnt[] off_name#
; ...    тут само имя
; byte[] off_zerobyte \ завершающий нулевой байт
; создать новый заголовок слова
_sHeader: ;( a: addr d: # --> )
       call _ecreate ; завершить предыдущее определение
       call _nalign
       mov temp, dword [_NDP+TOKEN]
       mov dword [_latest+TOKEN], temp
       apush 0       ; тут в последствии будет ссылка на предыдущее определение
       call _nacomp  ; а в начале хранится нуль
       call _align
       apush dword [_DP+TOKEN]
       call _nacomp ; ссылка на код
       dpush 0
       call _nbcomp ; тут будет лежать флаг
       call _cnstr
       exit
; создание нового определения
_new: ;( / name --> )
       call _NextToken ; NextToken
       call _sHeader   ; SHEADER
       call _son       ; ]
       exit
; завершение создания определения ';'
_fin: ;( --> )
       call _qcomp     ; ?COMP
       call _cexit     ; COMPILE EXIT
       call _soff      ; [
       exit
;
_created: ;( asc # --> )
       call _ecreate   ; ;CREATE
       call _sHeader   ; SHEADER
       dpush _create   ; ['] (CREATE)
       call _ctoken    ; TOKEN,
       exit
;
_create_: ;( / name --> )
       call _NextToken ; NextToken
       call _created   ; CREATED
       exit
;
_variable: ;( / name --> )
       call _create_   ; CREATE
       apush 0         ; a: 0
       call _acomp     ; A,
       exit
;-------------------------------------------------------------------------------
;
_query: ;( --> )
       pushad
       rlit 0
       rpush _TIBsize+TOKEN
       rlit TIB_size
       rpush _tib+TOKEN
       rpush dword [_STDIN+TOKEN]
       call [ReadFile]
       popad
       mov dword [_IN+TOKEN], 0
       exit
;
_type: ;( d: addr d: # --> # )
       pushad
       lea temp, [tad+CELL]
       mov ebp, esp ; чтобы вызываемая ф-ция могла убрать параметры
       rlit 0 ; overlap
       rpush temp
       rpush tos
       rpush toa
       rpush dword [_STDOUT+TOKEN]
       call [WriteFile]
       popad
       apop toa ; удаляются ненужные параметры со стека адресов
       dpop tos ; и данных
       exit
;
_box: ;( --> a: addr )  ...][call][addr][data][align]addr:[...
       apush toa
       rpop temp
       lea toa, [temp+ADDR]
       mov temp, [temp]
       jmp temp
       align
;
_print: ;( a: addr --> )
        fcode _count, _type
       exit
;
_cr: ;( --> )
      call _NewLine
      call _print
      exit
;
_prompt: ;( --> )
       cmp dword [_STATE+TOKEN], -1
       jz lab10
       slit '>'
       call _print
       exit
lab10: slit ']'
       call _print
       exit
;
_ok:   ;( --> )
       cmp dword [_STATE+TOKEN], -1
       jz lab11
       slit ' Ok'
       call _print
       call _cr
lab11: exit
;
_qStack: ;( --> )
       cmp dword [_S0+TOKEN], tad
       jb lab04
       cmp dword [_A0+TOKEN], taa
       jb lab05
       exit
lab04: ERROR 'Data stack underflow'
lab05: ERROR 'Address stack underflow'
       align
;
_ViewPoint: ;( --> a: addr )
       apush toa
       mov toa, dword[_IN]
       lea toa, [toa+_tib+TOKEN]
       exit
;
_SkipDelim: ;( --> a: addr )
       mov temp, dword [_IN+TOKEN]
       cmp temp, dword [_TIBsize+TOKEN]
       jns lab02 ; если достигнут последний байт в tib
       movzx temp , byte [temp+_tib+TOKEN]
       cmp temp, 0x21
       jns lab02 ; если встречен первый непробельный символ
       inc dword [_IN+TOKEN]
       jmp _SkipDelim ; повторять, пока пробельные символы
lab02: apush toa
       mov toa, [_IN+TOKEN]
       lea toa, [toa+_tib+TOKEN]
       exit
;
_SkipUpTo: ;( d: char --> a: addr )
       mov temp, dword [_IN+TOKEN]
       cmp temp, dword [_TIBsize+TOKEN]
       jns lab03 ; если достигнут последний байт в tib
       movzx temp, byte [temp+_tib+TOKEN]
       cmp temp, tos
       jle lab03 ; если встречен первый непробельный символ
       inc dword [_IN+TOKEN]
       jmp _SkipUpTo ; повторять, пока пробельные символы
lab03: dpop tos
       apush toa
       mov toa, [_IN+TOKEN]
       lea toa, [toa+_tib+TOKEN]
       exit
;
_range: ;( a: a1 a2 --> d: # )
       dpush tos
       mov tos, dword [taa]
       sub tos, toa
       neg tos
       apop toa
       apop toa
       exit
;
_NextToken: ;( --> a: addr d: # )
       call _SkipDelim
       call _adup
       dlit 0x20
       call _SkipUpTo
       call _range
       exit
;
_char: ;( a: addr d: # --> d: char )
       call _NextToken
       movzx tos, byte [toa]
       apop toa
       exit
;
_error: ;( a: asc d: # --> )
       call _type
       call _cr
       jmp _abort
;
;-------------------------------------------------------------------------------
;
_quest: ;( a: addr d: # --> a: lfa | nil )
       rpush taa
       mov taa, dword [_last+TOKEN]
lab0A: or taa, taa
       jz lab09 ; если в списке не осталось слов
       ; toa = sample  tos = #  taa = exsample
       cmp AL, byte [taa+ADDR+CELL+SCNT]
       jnz lab0B ; если длины не равны
       mov cnt, tos
lab0C: ; cmp byte [temp+cnt+ADDR+CELL+1],
       mov DL, byte [taa+cnt+ADDR+CELL+SCNT]
       cmp DL, byte [toa+cnt-1]
       jnz lab0B
       dec cnt
       jnz lab0C ; проверка до последнего символа
lab09: mov toa, taa
       rpop taa
       dpop tos
       exit
lab0B: mov taa, [taa] ; на предыдущее слово
       jmp lab0A
align
;
_tick: ;( / name --> a: xt )
       call _NextToken
       call _quest
       or toa, toa
       jnz lab12
       ERROR 'Cannot find name!'
lab12: mov toa, [toa+ADDR]
       exit
;
_qcomp: ;( --> )
       MOV cnt, [_STATE+TOKEN]
       JCXZ lab13
       exit
lab13: ERROR 'For compile mode only!'
align
;
_unique: ;( a: addr d: # --> )
       apush toa
       dpush tos
       call _quest
       or toa, toa
       jnz lab14
       apop toa
       exit
lab14: MESSAGE 'Name not unique!'
align
;
_regular: ;( a: xt --> )
       cmp dword [_STATE+TOKEN], 0
       jz lab08
       call _ctoken
       exit
lab08: call _execute
       exit
;
_xtimm: ;( a: lfa --> a: xt d: flag )
       dpush tos
       movsx tos, byte [toa+ADDR+ADDR]
       mov toa, [toa+ADDR]
       exit
;
_EvalToken: ;( a: asc d: # --> )
       call _quest  ; a: lfa
       or toa, toa  ; если не найдено, в toa хранится nil
       jnz lab06
       ERROR 'Name not found!'
lab06:
       call _xtimm ;( a: lfa --> a: lfa d: flag )
       or tos, tos ;
       jz lab07
       dpop tos
       call _execute
       exit
lab07: dpop tos
       call _regular
       exit
;
_interpret: ;( --> )
       call _NextToken ; a: a d: #
       or tos, tos
       jz lab01
       call _EvalToken
       call _qStack
       jmp _interpret
lab01:
       apop toa
       dpop tos
       exit
;
_title: ;( --> )
       MESSAGE 'tri-stack forth engine.'
       MESSAGE 'Copyright 2010 mOleg'
       MESSAGE 'mail to mOlegg@ya.ru'
       exit
;
_abort: ; переход на abort выполняется в случае ошибки
       mov tar, dword [_R0+TOKEN]
       mov taa, dword [_A0+TOKEN]
       mov tad, dword [_S0+TOKEN]
       mov dword [_STATE+TOKEN], 0
       mov dword [_BASE+TOKEN], 0x0A ; десятичная система счисления
       mov dword [_IN+TOKEN], 0
       mov dword [_WARNING+TOKEN], -1 ; включить режим предупреждений
       mov dword [_latest+TOKEN], 0  ; чтобы небыло рецидивов с ;CREATE
_quit:  ; основной цикл системы
       fcode _prompt, _query, _interpret, _ok
       jmp _quit
       align
;
_initmem: ; выделение места под стеки
        rpop temp
        lea taa, [tar-aStack]
        lea tad, [tar-aStack-dStack]
        lea tar, [tar-aStack-dStack-rStack]
        rpush temp
        ; сохранение указателей на дно каждого из стеков
        fcode _SPfetch, _S0, _Astore,\
              _RPfetch, _R0, _Astore,\
              _APfetch, _A0, _Astore
        exit
;
_ioinit: ;( --> )
         rlit -10            ; параметры функций сразу выкладываем на стек возвратов
         dpush tos           ; значение возвращается в EAX, который tos
         call [GetStdHandle] ; GetStdHandle адресная метка, по которой хранится адрес перехода
         call _STDIN
         call _store
         rlit -11
         dpush tos
         call [GetStdHandle]
         call _STDOUT
         call _store
         rlit -12
         dpush tos
         call [GetStdHandle]
         call _STDERR
         call _store
        exit
; инициализация системы
_cold:
   fcode _initmem, _ioinit, _title, _MAIN, _Afetch, _execute
_bye:  ;( --> )
        rlit 0     ; без ошибки
_halt: ;( err --> )
        call [ExitProcess]
        align

_int: int3
      exit
;
_limit: ; последнее слово форт-системы
        call _create
_there:
allot CodeSpace-($-$$)

; ------------------------------------------------------------------------------
section '.names' data readable writeable

;   Имя          Метка      Флаг
def 'NOOP',      _noop,      0
def 'DUP',       _dup,       0
def 'DROP',      _drop,      0
def 'SWAP',      _swap,      0
def 'OVER',      _over,      0
def '+',         _plus,      0
def '-',         _minus,     0
def '*',         _mul,       0
def 'MOD/',      _moddiv,    0
def 'XOR',       _xor,       0
def 'AND',       _and,       0
def 'OR',        _or,        0
def 'ABS',       _abs,       0
def '(DLIT)',    _dlit,      0
def 'ADUP',      _adup,      0
def '(ALIT)',    _alit,      0
def '(RLIT)',    _rlit,      0
def '?NIL',      _qnil,      0
def 'A+',        _aadd,      0
def '(CREATE)',  _create,    0
def 'A!',        _Astore,    0
def 'A@',        _Afetch,    0
def '!',         _store,     0
def '@',         _fetch,     0
def 'EXECUTE',   _execute,   0
def 'BRANCH',    _branch,    0
def '?BRANCH',   _0branch,   0
def 'D>R',       _d2r,       0
def 'RP@',       _RPfetch,   0
def 'SP@',       _SPfetch,   0
def 'AP@',       _APfetch,   0
def 'RP!',       _RPstore,   0
def 'AP!',       _APstore,   0
def 'SP!',       _SPstore,   0
def 'A>R',       _a2r,       0
def 'RDROP',     _rdrop,     0
def 'OFF',       _off,       0
def 'COUNT',     _count,     0
def 'ASWAP',     _Aswap,     0
def 'R>A',       _r2a,       0
def 'ADROP',     _adrop,     0
def 'ANIP',      _anip,      0
def 'B@',        _bfetch,    0
def 'B!',        _bstore,    0
def 'CMOVE',     _cmove,     0
def 'LAST',      _last,      0
def 'MAIN',      _MAIN,      0
def 'HERE',      _DP,        0
def 'NHERE',     _NDP,       0
def 'S0',        _S0,        0
def 'A0',        _A0,        0
def 'R0',        _R0,        0
def 'TIB',       _tib,       0
def 'PAD',       _pad,       0
def 'STATE',     _STATE,     0
def 'BASE',      _BASE,      0
def 'CURRENT',   _CURRENT,   0
def 'CONTEXT',   _CONTEXT,   0
def 'TIB#',      _TIBsize,   0
def 'IN',        _IN,        0
def 'STDIN',     _STDIN,     0
def 'STDOUT',    _STDOUT,    0
def 'STDERR',    _STDERR,    0
def 'NewLine',   _NewLine,   0
def 'QUERY',     _query,     0
def 'TYPE',      _type,      0
def '(BOX)',     _box,       0
def 'PRINT',     _print,     0
def 'CR',        _cr,        0
def 'PROMPT',    _prompt,    0
def 'OK',        _ok,        0
def '?STACK',    _qStack,    0
def 'ViewPoint', _ViewPoint, 0
def 'SkipDelim', _SkipDelim, 0
def 'SkipUpTo',  _SkipUpTo,  0
def 'RANGE',     _range,     0
def 'NextToken', _NextToken, 0
def 'ERROR',     _error,     0
def 'QUEST',     _quest,     0
def 'REGULAR',   _regular,   0
def 'XTIMM',     _xtimm,     0
def 'EvalToken', _EvalToken, 0
def 'INTERPRET', _interpret, 0
def 'TITLE',     _title,     0
def 'ABORT',     _abort,     0
def 'QUIT',      _quit,      0
def 'BYE',       _bye,       0
def 'HALT',      _halt,      0
def 'RESERVE',   _reserve,   0
def 'CELL',      _cell,      0
def 'ADDR',      _addr,      0
def 'TOKEN',     _token,     0
def 'RET,',      _cexit,     0
def 'SCNT',      _scnt,      0
def 'REF',       _ref,       0
def 'HERE',      _here,      0
def 'NHERE',     _nhere,     0
def 'ATOD',      _atod,      0
def 'B,',        _cbyte,     0
def 'REF,',      _cref,      0
def ',',         _dcomp,     0
def 'A,',        _acomp,     0
def 'NA,',       _nacomp,    0
def 'NB,',       _nbcomp,    0
def 'N,',        _nccomp,    0
def 'NS,',       _cns,       0
def 'NSTR,',     _cnstr,     0
def 'S,',        _cs,        0
def 'STR,',      _cstr,      0
def 'ALIT,',     _calit,     0
def '[',         _soff,      1
def ']',         _son,       0
def "'",         _tick,      0
def '?COMP',     _qcomp,     0
def 'WARNING',   _WARNING,   0
def '?UNIQUE',   _unique,    0
def 'TOKEN,',    _ctoken,    0
def '<#',        _lbdiez,    0
def '#>',        _diezrb,    0
def 'HOLD',      _hold,      0
def '>DIGIT',    _digit,     0
def '#',         _diez,      0
def 'S#',        _sdiez,     0
def '(U)',       _unum,      0
def 'U.',        _snumt,     0
def 'SIGN',      _sign,      0
def 'CHAR',      _char,      0
def '>CIPHER',   _2cipher,   0
def 'sval',      _val,       0
def 'd:',        _dnum,      1
def 'a:',        _anum,      1
def ':',         _new,       0
def ';',         _fin,       1
def 'SHEADER',   _sHeader,   0
def 'LATEST',    _latest,    0
def 'LIT,',      _clit,      0
def 'LITERAL',   _literal,   0
def ';CREATE',   _ecreate,   0
def 'CREATED',   _created,   0
def 'CREATE',    _create_,   0
def 'VARIABLE',  _variable,  0
def 'ROUND',     _round,     0
def 'ALIGN',     _align,     0

def 'int',       _int,       0

LATEST: ; чтобы получить хвост цепочки имен
def 'LIMIT',_limit,0
NSADDR:

allot NamesSpace-($-$$) ;

Сообщение Добавлено: Ср окт 31, 2012 18:05
  Заголовок сообщения:  Re: 3-х стековая виртуальная машина. размышления.  Ответить с цитатой
К сожалению 3stack.asm удален с forth.org.ru а у меня сдох винчестер.
Если у кого остался оригинал, пришлите мне, пожалуйста!
Сообщение Добавлено: Пн окт 29, 2012 18:41
  Заголовок сообщения:   Ответить с цитатой
OllyDebug v2.0 (beta 3).
Сообщение Добавлено: Ср мар 31, 2010 17:24
  Заголовок сообщения:   Ответить с цитатой
mOleg писал(а):
если бы у тя был дебагер,

А ты чем пользуешся?
Сообщение Добавлено: Ср мар 31, 2010 17:21
  Заголовок сообщения:   Ответить с цитатой
_Harry писал(а):
А с SHIDER-ом разобрался?

чуть дальше продвинулся. Кстати там просто int3 стоял, если бы у тя был дебагер, то вылета с ошибкой не было бы, а было бы попадение отладчик на этой самой int3.

_Harry писал(а):
Если да то выкладывай, если нет всеравно выкладывай

Тогда лови!
Сообщение Добавлено: Ср мар 31, 2010 17:16
  Заголовок сообщения:   Ответить с цитатой
mOleg
А с SHIDER-ом разобрался?
Если да то выкладывай, если нет всеравно выкладывай :))
Удалить то всегда можно.
Сообщение Добавлено: Ср мар 31, 2010 17:01
  Заголовок сообщения:   Ответить с цитатой
по теме, есть недоделанный транслятор на фасме, судя по всему времени и желания в ближайшее время у мя не будет, если кому интересно могу выложить "как есть". То есть, трансляция есть и есть 144 определения (причем не все отлажены).
Сообщение Добавлено: Ср мар 31, 2010 16:49
  Заголовок сообщения:   Ответить с цитатой
_Harry писал(а):
Ну а так как сейчас положить все в нужном порядке на стек данных не получится что ли?

получится (правда я хотел обойтись без A> >A)
просто это будет отдельный неудобный момент.
Кстати мысля пришла другая, выкладывать параметры на стек возвратов можно (ведь вызываемые АПИ с ним работают!).
Это позволит избежать переключения стеков, а так же не делать A> и >A
Сообщение Добавлено: Пт янв 22, 2010 14:14
  Заголовок сообщения:   Ответить с цитатой
Цитата:
То есть необходимо куда-то параметры складывать отдельно, а потом только вызывать функцию.

Ну а так как сейчас положить все в нужном порядке на стек данных не получится что ли?
Если будет слово A> ( a: addr -- d: addr) то вроде и проблем нет.
Кажется даже удобней должно быть меньше всяких ROT SWAP и т.п.
Сообщение Добавлено: Пт янв 22, 2010 11:10
  Заголовок сообщения:   Ответить с цитатой
_Harry писал(а):
Поясни подробнее в чем проблема?

ну, адреса хранятся отдельно от данных, так?
а при вызове АПИ параметры идут вперемешку.
То есть необходимо куда-то параметры складывать отдельно, а потом только вызывать функцию.
А это значит, что каждую ф-цию придется "оборачивать" отедельно.
Сообщение Добавлено: Чт янв 21, 2010 16:33
  Заголовок сообщения:   Ответить с цитатой
mOleg писал(а):
Вызов АПИ функций будет усложнен из-за необходимости все параметры перед вызовом куда-то складывать в правильном порядке.
Поясни подробнее в чем проблема?
Сообщение Добавлено: Чт янв 21, 2010 16:03
  Заголовок сообщения:   Ответить с цитатой
такс, выяснилась еще одна проблема.
Вызов АПИ функций будет усложнен из-за необходимости все параметры перед вызовом куда-то складывать в правильном порядке.
Сообщение Добавлено: Чт янв 21, 2010 09:21
  Заголовок сообщения:   Ответить с цитатой
Варнак писал(а):
Хищник писал(а):
На регистровых процессорах, которых подавляющее большинство, это реализуется сохранением контекста.

... в стеке контекстов.

В "просто стеке", командами PUSH с последующим восстановлением через POP.
Сообщение Добавлено: Вт янв 12, 2010 14:01
  Заголовок сообщения:   Ответить с цитатой
Хищник писал(а):
На регистровых процессорах, которых подавляющее большинство, это реализуется сохранением контекста.

... в стеке контекстов.
Сообщение Добавлено: Вт янв 12, 2010 11:02
  Заголовок сообщения:   Ответить с цитатой
Цитата:
Просто не прижилось.
(можно, но) - потому, что фортеру удобно мыслить в рамках традиционного построения
Сообщение Добавлено: Вт янв 12, 2010 08:51

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


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