К сожалению, язык 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 ]
дальше пошла раскрутка Форт-системы...
В нем нет одной важной части - пока не может откомпилить себя...
Это можно решить настройками параметров - адресов областей словарей и кода.
Когда доделаю, покажу все целиком!
К сожалению, язык ColorLessColorForth.
В принципе, можно сделать аналог и для обычного Форта, но некоторые решения не так красивы. :(
Слова немедленного исполнения расположены в словаре macro
Словари переключаются интерпретаторами. Их два - интерпретации и компиляции.
Генерируется 16 разрядный код. Есть несколько некрасивых мест... :(
Это слова, используемые для компиляции компилятора
[code]+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 , д. совпадать с системой :([/code]
А это бОльшая часть компилятора... ;) [code]\ подготовка компилятора \ 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 ][/code]
дальше пошла раскрутка Форт-системы...
В нем нет одной важной части - пока не может откомпилить себя... :(
Это можно решить настройками параметров - адресов областей словарей и кода.
Когда доделаю, покажу все целиком! :)
|