К сожалению, язык ColorLessColorForth.
В принципе, можно сделать аналог и для обычного Форта, но некоторые решения не так красивы.
Слова немедленного исполнения расположены в словаре macro
Словари переключаются интерпретаторами. Их два - интерпретации и компиляции.
Генерируется 16 разрядный код. Есть несколько некрасивых мест...
Это слова, используемые для компиляции компилятора
Код:
+w' fortho \
+w' fortho (
+w' fortho :
+w' fortho ]
+w' fortho ],
+w' fortho const \ внешняя ссылка, потом восстановить!
\ +w' fortho h0 \ var , д. совпадать с системой :(
\ +w' fortho list \ var , д. совпадать с системой :(
\ +w' fortho list1 \ var , д. совпадать с системой :(
\ +w' fortho >in \ var , д. совпадать с системой :(
\ +w' fortho |source \ var , д. совпадать с системой :(
\ +w' fortho /source \ var , д. совпадать с системой :(
\ +w' fortho context1 \ var , д. совпадать с системой :(
\ +w' fortho current \ var , д. совпадать с системой :(
+w' macroo \
+w' macroo (
+w' macroo :
+w' macroo ;
+w' macroo [
+w' macroo ',
\ для отладки
+w' macroo ."
\ /для отладки
\ явно выделяем нужные макросы
+w' macroo h0 \ var , д. совпадать с системой :(
+w' macroo list \ var , д. совпадать с системой :(
+w' macroo list1 \ var , д. совпадать с системой :(
+w' macroo +!
+w' macroo @
+w' macroo c!
+w' macroo !
+w' macroo over
+w' macroo c@
+w' macroo dup
+w' macroo +
\ ^хватает для компиляции компилятора
\ h0 list list1 должны соответствовать интерпретаторам :(
+w' macroo >in \ var , д. совпадать с системой :(
+w' macroo |source \ var , д. совпадать с системой :(
+w' macroo /source \ var , д. совпадать с системой :(
+w' macroo context1 \ var , д. совпадать с системой :(
+w' macroo current \ var , д. совпадать с системой :(
А это бОльшая часть компилятора...
Код:
\ подготовка компилятора
\ 0CCFE const h0 \ надо, чтобы h0 соответствовало системе
\ 04800 h0 !
: ! ! ; \ нужно для инициализации var0
: allot ( n -- ) \ выделить память в куче
h0 +! ;
: here h0 @ ;
: 1, here 1 allot c! ; \ обобщать на cell нет смысла...
: 2, here 2 allot ! ;
: dup, \ скомпилить dup
748D 2, 0FE 1, 0489 2, ;
[
macro .curvocs \ добавляем в новый macro
: if 74 2, here ; \ jz je, продолжаем по T , <>0
: neg D8F7 2, ; \ neg ax
: - ', neg ', + ;
: swap 0487 2, ;
: test C085 2, ; \ test ax,ax
[ forth
: - - ;
\ var var0 \ адрес в пуле переменных
\ растет вниз, переделать
\ : var 2
\ : vars \ ( n "name" -- )
\ var0 dup @ const +! ;
\ : dvar 4 vars ;
[ \ это инициализация кучи и пула переменных
0CCFC const var0
var0 var0 !
: var 2
: vars ( n "name" -- )
var0 @ swap - dup var0 ! const ;
[ here const refconst \ ссылка для восстановления
: dvar 4 vars ;
[ macro
: drop here list ! AD 1, ; \ lodsw
: then \ без swap !!
\ пока без проверок правильной вложенности и дальности перехода
\ here over - $FF -
0 list ! \ запретить оптимизацию до here
here over - over 1 - c! drop ;
\ ?dup компилит dup , если пред. команда не drop
: ?dup
here 1 - list @ - drop if dup, ; then \ пред команда>1б
list @ c@ 0AD - drop if dup, ; then \ не drop
1 neg allot ;
[
forth
\ ?lit проверяет $B8 у последней команды и засовывает ее
\ слово в стек, удаляет ее саму и, м.б., предыд. dup
\ и передвигает указатель последней команды
\ ZF если ничего не добавилось на стек
\ д.б. в forth
: ?lit
list @ here 3 - - drop if 0 test drop ; then
\ не 3 байта назад !!
list @ c@ B8 - drop if
0 test drop ; then \ было не B8, выход
list @ 1 + @ 3 neg allot \ отмотали mov ax,x
list1 @ @ 748D - drop if ; then
list1 @ 2 + @ 89FE - drop if ; then
5 neg allot ; \ отмотали dup
\ [ macron d@ dump .sar ]
[
forth .curvocs
s" теперь начинаем компилятор" type .sar
\ а теперь начинаем компилятор
macro
\ : swap 0487 2, ;
: nop 90 1, ;
: 0 ', ?dup C031 2, ; \ или C033
\ : if 74 2, here ; \ jz je, продолжаем по T , <>0
: -if 79 2, here ;
: nip 748D 2, 02 1, ; \ переделать на 3, # lea si,[si+2]
: dup 748D 2, FE 1, 0489 2, ;
: over ', ?dup 448B 2, 02 1, ;
: + ?lit if 05 1, 2, ; then 0403 2, ', nip ;
: xor 0433
: binary ?lit if swap 2 + 1, 2, ; then 2, ', nip ;
: and 0423 ', binary ;
: or 040B ', binary ;
: a ', ?dup C38B 2, ;
: a! ?lit if BB 1, 2, ; then D88B 2, ', drop ; \ mov bx,ax
: 2* E0D1 2, ;
: @ ?lit if ', ?dup A1 1, 2, ; then 53 1, D88B 2, 078B 2, 5B 1, ;
\ mov ax,[x] ; push bp mov bx,ax mov ax,[bx] pop bp
\ : @ ?lit if ', ?dup 58B 2, ', a, ; then 85048B 3, 0 , ; \ !!
\ mov eax,[x] ; mov eax,[eax*4+0]
: ! ?lit if ?lit if 06C7 2, 2, 2, ; then
A3 1, 2, ', drop ; then \ mov [x],ax
', a! 0789 2, ', drop ; \ mov [bx],ax
\ : ! ?lit if ?lit if 5C7 2, swap ', a, , ; then
\ 589 2, ', a, ', drop ; then
\ ', a! 950489 3, 0 , ', drop ;
: push 50 1, ', drop ;
: pop ', ?dup 58 1, ;
: over ', ?dup 448B 2, 02 1, ;
: u+ 4401 2, 02 1, ', drop ;
: inv D0F7 2, ; \ not ax
: align here inv 3 and drop if ', nop ', align ; then ;
: * 2CF7 2, ', nip ;
: */ C88B 2, ', drop 2CF7 2, F9F7 2, ', nip ; \ новое!
: 2/ F8D1 2, ;
: /mod ', swap 99 1, 3CF7 2, 1489 2, ;
: / ', /mod ', nip ;
: mod ', /mod ', drop ;
: +! ?lit if ?lit if 0681 2, swap 2, 2, ; then
0601 2, 2, ', drop ; then
', a! 0701 2, ', drop ;
: c@ ', a! ', 0 078A 2, ;
: c! ', a! 0788 2, ', drop ; \ mov [bx],al
: emit C288 2, 02B4 2, 21CD 2, ', drop ;
: key ', ?dup 08B4 2, 21CD 2, E430 2, C084 2, 0675 2,
08B4 2, 21CD 2, 01B4 2, ;
\ : neg D8F7 2, ; \ neg ax
: (fopen) \ mode DS:buffer -- Handle/Error CF=Err
D08B 2, ', drop 3DB4 2, \ mov dx,ax ... mov ah,3D
21CD 2, ; \ int 21
: (fclose) \ Handle -- Error CF=Err
D88B 2, \ mov bx,ax
3EB4 2, 21CD 2, ; \ mov ah,3D; int 21
: (fread) \ c-addr u1 fileid -- u2/Err CF=Err
D88B 2, ', drop \ mov bx,ax
C88B 2, ', drop \ mov cx,ax
D08B 2, 3FB4 2, \ mov dx,ax; mov ah,3F
21CD 2, ; \ int 21
: ifc 73 2, here ;
: ifz 75 2, here ; \ jnz jne, продолжаем по F , ==0
: (fwrite) \ c-addr u1 fileid -- u2/Err CF=Err
D88B 2, ', drop \ mov bx,ax
C88B 2, ', drop \ mov cx,ax
D08B 2, 40B4 2, \ mov dx,ax; mov ah,40
21CD 2, ; \ int 21
: cold
C48B 2, \ mov ax,sp
05 1, 2 2, \ add ax,2
0174 2, \ jz $+1
C3 1, \ retn
BC 1, F000 2, BE 1, E000 2, \ mov sp,x; mov si,x
C033 2, 50 1, \ xor ax,ax; push ax
;
\ : - ', neg ', + ;
: (fcreate) \ mode DS:buffer -- Handle/Error CF=Err
D08B 2, ', drop \ mov dx,ax
C88B 2, \ mov cx,ax
3CB4 2, \ mov ah,3C
21CD 2, ; \ int 21
: (fseek) \ dir lo hi h -- lo hi CF=Err
D88B 2, ', drop \ mov bx,ax
C88B 2, ', drop \ mov cx,ax
D08B 2, ', drop 42B4 2, \ mov dx,ax ... mov ah,42
21CD 2, \ int 21
', dup C28B 2, ; \ mov ax,dx
\ : test C085 2, ; \ test ax,ax
: ifz 75 2, here ; \ jnz jne, продолжаем по F , ==0
: c@+ ', ?dup C033 2, 078A 2, 43 1, ;
\ xor ax,ax; mov al,[bx], inc bx
: c!+ 0788 2, 43 1, ; \ mov [bx],al; inc bx; без drop !!
: cr@+
', ?dup C033 2, 5D 1, 468A 2, 0 1, 45 1, 55 1, ;
\ xor ax,ax; pop bp; mov al,[bp+0]; inc bp; push bp;
: less 0439 2, 0278 2, ED33 2, ;
\ cmp [si],ax; js+2; xor bp,bp
: um*
89 1, C1 1, AD 1, F7 1, E1 1, 8D 1, 74 1, FE 1, 89 1, 04 1, 89 1, D0 1, ;
: um/mod
89 1, C1 1, AD 1, 8B 1, 14 1, 87 1, C2 1, F7 1, F1 1, 89 1,
14 1, ;
\ UM/MOD портит a(dx) c(cx)!!
[ forth
var (begin)
macro
: begin here (begin) ! ;
: again E9 1, (begin) @ here - 2 - 2, ;
[ forth .curvocs ]
дальше пошла раскрутка Форт-системы...
В нем нет одной важной части - пока не может откомпилить себя...
Это можно решить настройками параметров - адресов областей словарей и кода.
Когда доделаю, покажу все целиком!