Burer/kolibrios
1
0
Fork 0
forked from KolibriOS/kolibrios
Code Pull Requests Activity

KolSPForth12 uploaded to SVN

Browse Source 
git-svn-id: svn://kolibrios.org@4867 a494cfbc-eb01-0410-851d-a64ba20cac60
This commit is contained in:
Kirill Lipatov (Leency) 2014-04-21 19:22:58 +00:00
parent b3031965cc
commit 09488af869
91 changed files with 58885 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

264
programs/develop/SPForth/MACROS.INC Normal file
View File

@ -0,0 +1,264 @@
; new application structure
macro meos_app_start
{
use32
org 0x0
db 'MENUET01'
dd 0x01
dd __start
dd __end
dd __memory
dd __stack
if used __params & ~defined __params
dd __params
else
dd 0x0
end if
dd 0x0
}
MEOS_APP_START fix meos_app_start
macro code
{
__start:
}
CODE fix code
macro data
{
__data:
}
DATA fix data
macro udata
{
if used __params & ~defined __params
__params:
db 0
__end:
rb 255
else
__end:
end if
__udata:
}
UDATA fix udata
macro meos_app_end
{
align 32
rb 2048
__stack:
__memory:
}
MEOS_APP_END fix meos_app_end
; macro for defining multiline text data
struc mstr [sstring]
{
forward
local ssize
virtual at 0
db sstring
ssize = $
end virtual
dd ssize
db sstring
common
dd -1
}
; strings
macro sz name,[data] { ; from MFAR [mike.dld]
common
if used name
label name
end if
forward
if used name
db data
end if
common
if used name
.size = $-name
end if
}
macro lsz name,[lng,data] { ; from MFAR [mike.dld]
common
label name
forward
if lang eq lng
db data
end if
common
.size = $-name
}
; easy system call macro
macro mpack dest, hsrc, lsrc
{
if (hsrc eqtype 0) & (lsrc eqtype 0)
mov dest, (hsrc) shl 16 + lsrc
else
if (hsrc eqtype 0) & (~lsrc eqtype 0)
mov dest, (hsrc) shl 16
add dest, lsrc
else
mov dest, hsrc
shl dest, 16
add dest, lsrc
end if
end if
}
macro __mov reg,a,b { ; mike.dld
if (~a eq)&(~b eq)
mpack reg,a,b
else if (~a eq)&(b eq)
mov reg,a
end if
}
macro mcall a,b,c,d,e,f { ; mike.dld
__mov eax,a
__mov ebx,b
__mov ecx,c
__mov edx,d
__mov esi,e
__mov edi,f
int 0x40
}
; language for programs
;lang fix ru ; ru en fr ge fi
; optimize the code for size
__regs fix <eax,ebx,ecx,edx,esi,edi,ebp,esp>
macro add arg1,arg2
{
if (arg2 eqtype 0)
if (arg2) = 1
inc arg1
else
add arg1,arg2
end if
else
add arg1,arg2
end if
}
macro sub arg1,arg2
{
if (arg2 eqtype 0)
if (arg2) = 1
dec arg1
else
sub arg1,arg2
end if
else
sub arg1,arg2
end if
}
macro mov arg1,arg2
{
if (arg1 in __regs) & (arg2 eqtype 0)
if (arg2) = 0
xor arg1,arg1
else if (arg2) = 1
xor arg1,arg1
inc arg1
else if (arg2) = -1
or arg1,-1
else if (arg2) > -128 & (arg2) < 128
push arg2
pop arg1
else
mov arg1,arg2
end if
else
mov arg1,arg2
end if
}
macro struct name
{
virtual at 0
name name
sizeof.#name = $ - name
end virtual
}
; structures used in MeOS
struc process_information
{
.cpu_usage dd ? ; +0
.window_stack_position dw ? ; +4
.window_stack_value dw ? ; +6
.not_used1 dw ? ; +8
.process_name rb 12 ; +10
.memory_start dd ? ; +22
.used_memory dd ? ; +26
.PID dd ? ; +30
.x_start dd ? ; +34
.y_start dd ? ; +38
.x_size dd ? ; +42
.y_size dd ? ; +46
.slot_state dw ? ; +50
rb (1024-52)
}
struct process_information
struc system_colors
{
.frame dd ?
.grab dd ?
.grab_button dd ?
.grab_button_text dd ?
.grab_text dd ?
.work dd ?
.work_button dd ?
.work_button_text dd ?
.work_text dd ?
.work_graph dd ?
}
struct system_colors
; constants
; events
EV_IDLE = 0
EV_TIMER = 0
EV_REDRAW = 1
EV_KEY = 2
EV_BUTTON = 3
EV_EXIT = 4
EV_BACKGROUND = 5
EV_MOUSE = 6
EV_IPC = 7
EV_STACK = 8
; event mask bits for function 40
EVM_REDRAW = 1b
EVM_KEY = 10b
EVM_BUTTON = 100b
EVM_EXIT = 1000b
EVM_BACKGROUND = 10000b
EVM_MOUSE = 100000b
EVM_IPC = 1000000b
EVM_STACK = 10000000b

417
programs/develop/SPForth/amain.asm Normal file
View File

@ -0,0 +1,417 @@
reserve EQU Mreserve-main_task
amain:
MOV [ByeLevel],ESP
mov edi, main_task
call cfa_INIT
ret
TIB_SIZE EQU 1027
PAD_SIZE EQU 1027
include 'img.asm'
cfa_AHEADER 0,"BYE",_BYE
MOV ESP,[ByeLevel]
RET
cfa_AHEADER 0,"_SLITERAL-CODE",_SLITERALminusCODE
LEA EBP, [EBP-8]
MOV [EBP+4], EAX
POP EBX
MOVZX EAX, BYTE [EBX]
LEA EBX, [EBX+1]
MOV [EBP], EBX
LEA EBX, [EBX+EAX]
LEA EBX, [EBX+1]
JMP EBX
cfa_AHEADER 0,"_CONSTANT-CODE",_CONSTANTminusCODE
LEA EBP,[EBP-4]
MOV [EBP],EAX
POP EAX
MOV EAX,[EAX]
RET
cfa_AHEADER 0,"_CREATE-CODE",_CREATEminusCODE
DB 083H ,0EDH ,4
DB 089H ,045H ,0
DB 058H
DB 0C3H
cfa_AHEADER 0,"_TOVALUE-CODE",_TOVALUEminusCODE
DB 05BH
DB 08DH ,05BH ,0F7H
DB 089H ,03
DB 08BH ,045H ,00
DB 08DH ,06DH ,04
DB 0C3H
cfa_AHEADER 0,"TOVALUE-CODE",TOVALUEminusCODE
call cfa__CONSTANTminusCODE
DD cfa__TOVALUEminusCODE
call cfa__TOVALUEminusCODE
cfa_AHEADER 0,"VECT-CODE",VECTminusCODE
call cfa__CONSTANTminusCODE
DD cfa__VECTminusCODE
call cfa__TOVALUEminusCODE
cfa_AHEADER 0,"_VECT-CODE",_VECTminusCODE
DB 05BH
DB 0FFH ,023H
cfa_AHEADER 0,"_USER-VALUE-CODE", _USERminusVALUEminusCODE
LEA EBP,[EBP-4]
MOV [EBP],EAX
POP EAX
MOV EAX,[EAX]
LEA EAX,[EDI+EAX]
MOV EAX,[EAX]
RET
cfa_AHEADER 0,"USER-VALUE-CODE",USERminusVALUEminusCODE
call cfa__CONSTANTminusCODE
DD cfa__USERminusVALUEminusCODE
call cfa__TOVALUEminusCODE
cfa_AHEADER 0,"_TOUSER-VALUE-CODE",_TOUSERminusVALUEminusCODE
DB 05BH
DB 083H ,0EBH ,09
DB 08BH ,01BH
DB 03 ,0DFH
DB 089H ,03
DB 08BH ,045H ,00
DB 083H ,0C5H ,04
DB 0C3H
cfa_AHEADER 0,"TOUSER-VALUE-CODE",TOUSERminusVALUEminusCODE
call cfa__CONSTANTminusCODE
DD cfa__TOUSERminusVALUEminusCODE
call cfa__TOVALUEminusCODE
cfa_AHEADER 0,"_USER-CODE", _USERminusCODE
LEA EBP,[EBP-4]
MOV [EBP],EAX
POP EAX
MOV EAX,[EAX]
LEA EAX,[EDI+EAX]
RET
cfa_AHEADER 0,"DOES>A",DOESgreatA
call cfa__USERminusCODE
DD T_DOESgreatA-main_task
cfa_AHEADER 0,"USER-CODE",USERminusCODE
call cfa__CONSTANTminusCODE
DD cfa__USERminusCODE
call cfa__TOVALUEminusCODE
cfa_AHEADER 0,"CREATE-CODE",CREATEminusCODE
call cfa__CONSTANTminusCODE
DD cfa__CREATEminusCODE
call cfa__TOVALUEminusCODE
cfa_AHEADER 0,"CONSTANT-CODE",CONSTANTminusCODE
call cfa__CONSTANTminusCODE
DD cfa__CONSTANTminusCODE
call cfa__TOVALUEminusCODE
cfa_AHEADER 0,"_CLITERAL-CODE",_CLITERALminusCODE
DB 083H ,0EDH ,04
DB 089H ,045H ,00
DB 058H
DB 0FH ,0B6H ,018H
DB 08DH ,05CH ,03 ,02
DB 0FFH ,0E3H
cfa_AHEADER 0,"CLITERAL-CODE",CLITERALminusCODE
call cfa__CONSTANTminusCODE
DD cfa__CLITERALminusCODE
call cfa__TOVALUEminusCODE
cfa_AHEADER 0,'BASE',BASE
call cfa__USERminusCODE
DD T_BASE-main_task
cfa_AHEADER 0,'PAD',PAD
call cfa__USERminusCODE
DD T_PAD-main_task
cfa_AHEADER 0,'LAST',LAST
call cfa__CREATEminusCODE
DD LastNFA
cfa_AHEADER 0,'DP',DP
call cfa__CONSTANTminusCODE
DD CP_P ; DP_BUFF
cfa_AHEADER 0,'''DROP_V',ticDROP_V
call cfa__CONSTANTminusCODE+00H
DD cfa_DROP
call cfa__TOVALUEminusCODE+00H
cfa_AHEADER 0,'''DUP_V',ticDUP_V
call cfa__CONSTANTminusCODE
DD cfa_DUP
call cfa__TOVALUEminusCODE+00H
cfa_AHEADER 0,'CONTEXT',_CONTEXT
call cfa__USERminusVALUEminusCODE
DD T_CONTEXT-main_task
call cfa__TOUSERminusVALUEminusCODE
cfa_AHEADER 0,'>IN',greatIN
call cfa__USERminusCODE
DD T_greatIN-main_task
cfa_AHEADER 0,'>OUT',greatOUT
call cfa__CREATEminusCODE
TO_OUT dd 0
cfa_AHEADER 0,'CURFILE',CURFILE
call cfa__USERminusCODE
DD T_CURFILE-main_task
cfa_AHEADER 0,'S0',S0
call cfa__USERminusCODE
DD T_S0-main_task
cfa_AHEADER 0,'R0',R0
call cfa__USERminusCODE
DD T_R0-main_task
cfa_AHEADER 0,'SOURCE-ID',SOURCEminusID
call cfa__USERminusVALUEminusCODE
DD T_SOURCEminusID-main_task
call cfa__TOUSERminusVALUEminusCODE
cfa_AHEADER 0,'TIB',TIB
call cfa__USERminusVALUEminusCODE
DD T_TIB-main_task
call cfa__TOUSERminusVALUEminusCODE
cfa_AHEADER 0,'#TIN',nTIB
call cfa__USERminusCODE
DD T_nTIB-main_task
cfa_AHEADER 0,'CURSTR',CURSTR
call cfa__USERminusCODE
DD T_CURSTR-main_task
cfa_AHEADER 0,'SLITERAL-CODE',SLITERALminusCODE
call cfa__CONSTANTminusCODE
DD cfa__SLITERALminusCODE
call cfa__TOVALUEminusCODE
cfa_AHEADER 0,'USER-OFFS',USERminusOFFS
call cfa__CREATEminusCODE
DD reserve+MUSEROFFS
cfa_AHEADER 0,'HANDLER',HANDLER
call cfa__USERminusCODE
DD T_HANDLER-main_task
cfa_AHEADER 0,'STATE',STATE
call cfa__USERminusCODE
DD T_STATE-main_task
cfa_AHEADER 0,'CURRENT',CURRENT
call cfa__USERminusCODE
DD T_CURRENT-main_task
cfa_AHEADER 0,'W-CNT',WminusCNT
call cfa__USERminusCODE
DD T_WminusCNT-main_task
cfa_AHEADER 0,'S-O',SminusO
call cfa__USERminusCODE
DD T_SminusO-main_task
cfa_AHEADER 0,'ER-U',ERminusU
call cfa__USERminusCODE
DD T_ERminusU-main_task
cfa_AHEADER 0,'ER-A',ERminusA
call cfa__USERminusCODE
DD T_ERminusA-main_task
cfa_AHEADER 0,'FORTH-WORDLIST',FORTHminusWORDLIST
call cfa__CONSTANTminusCODE
DD T_FORTH+4
call cfa__TOVALUEminusCODE
cfa_AHEADER 0,'VOC-LIST',VOCminusLIST
call cfa__CREATEminusCODE
DD T_FORTH
cfa_AHEADER 0,'WARNING',WARNING
call cfa__USERminusCODE
DD T_WARNING-main_task
;cfa_AHEADER 0,'LAST_KEY',LAST_KEY
; call cfa__CREATEminusCODE
; DD last_key
cfa_AHEADER 0,"BLK",BLK
call cfa__USERminusCODE
DD T_BLK-main_task
;cfa_AHEADER 0,"UZERO",UZERO_M
; call cfa__CONSTANTminusCODE
; DD UZERO
cfa_AHEADER 0,"UPP",UPP_M
call cfa__CONSTANTminusCODE
DD UPP
cfa_AHEADER 0,"ULAST",ULAST_M
call cfa__CONSTANTminusCODE
DD ULAST
cfa_AHEADER 0,"SPP",SPP_M
call cfa__CONSTANTminusCODE
DD SPP
cfa_AHEADER 0,"TIBB",TIBB_M
call cfa__CONSTANTminusCODE
DD TIBB
cfa_AHEADER 0,"#TIB",NTIB_M
call cfa__CONSTANTminusCODE
DD NTIB_P
cfa_AHEADER 0,"sbuf",screen_buf_M
call cfa__CONSTANTminusCODE
DD screen_buf
cfa_AHEADER 0,"cursor",cursor_M
call cfa__CONSTANTminusCODE
DD cursor
cfa_AHEADER 0,"FINFO",FINFO
call cfa__CREATEminusCODE
DD FINFO
cfa_AHEADER 0,"ROWH",ROWH
call cfa__CONSTANTminusCODE
DD ROWH
call cfa__TOVALUEminusCODE
cfa_AHEADER 0,"ROWW",ROWW
call cfa__CONSTANTminusCODE
DD 6
call cfa__TOVALUEminusCODE
cfa_AHEADER 0,"MEMS",MEMS
call cfa__CONSTANTminusCODE
DD MEMS
cfa_AHEADER 0,"draw_window",draw_window
PUSH EDI
CALL draw_window
POP EDI
RET
; cfa_AHEADER 0,'MEBLK',MEBLK
; call cfa__USERminusCODE
; DD BLK_P-main_task
main_task:
T_R0:
DD 0
T_S0:
DD SPP ;STACK0
T_WARNING:
DD -1
T_STATE:
DD 0
T_BLK:
DD 0
T_CURFILE:
DD 0
T_HANDLER:
DD 0
T_HLD:
DD 5
T_BASE:
DD 0AH
DD PAD_SIZE DUP (0)
T_PAD:
DD PAD_SIZE DUP (0)
T_ERminusA:
DD 0
T_ERminusU:
DD 0
T_DOESgreatA:
DD 0
;T_ALIGNminusBYTES:
DD 0
T_nTIB:
DD 0
T_greatIN:
DD 5
T_TIB:
DD T_ATIB
T_ATIB:
DD TIB_SIZE DUP (0)
T_SOURCEminusID:
DD 0
T_CURSTR:
DD 0
T_WBWminusNFA:
DD 0
T_WBWminusOFFS:
DD 0
T_CURRENT:
DD T_FORTH+4
T_SminusO:
DD T_FORTH+4,T_FORTH+4
DD 16 DUP (0)
T_CONTEXT:
DD T_SminusO
T_greatOUT:
DD 0
T_WminusCNT:
DD 0
T_NNN:
DD 0
Mreserve:
DD MUSEROFFS DUP (0)
UPP:
BASE_P DD BASEE
TEMP_P DD 0
INN_P DD 0
NTIB_P DD 0
TIB_P DD TIBB
;TEVAL_P DD INTER
HLD_P DD 0
CNTXT_P DD 0
CP_P DD CTOP
;LAST_P DD LASTN ;LAST
EMIT_PROC_P DD -1 ; EMITPROC
reg_struc_P DD 0
; BLK_P DD FILE_B
; fi_struc_P DD FINFO
workarea_P DD os_work
DD 1000 DUP (0)
T_FORTH:
DD 0 ; ¤Ťď VOC-LIST
DD LastNFA ;  ¤ŕĽá ŻŽáŤĽ¤­ĽŁŽ ¨ŹĽ­¨ !!!!!!!!
DD 0 ; ŻŕĽ¤ŽŞ
DD 0 ; ŞŤ áá
ByeLevel DD 0

5
programs/develop/SPForth/build.bat Normal file
View File

@ -0,0 +1,5 @@
spf4.exe src/gspf.f S" img.asm" TSAVE CR BYE
call mbuild.bat
pause

137
programs/develop/SPForth/debug.inc Normal file
View File

@ -0,0 +1,137 @@
macro debug_print str
{
local ..string, ..label
jmp ..label
..string db str,0
..label:
pushf
pushad
mov edx,..string
call debug_outstr
popad
popf
}
dps fix debug_print
macro debug_print_dec arg
{
pushf
pushad
if ~arg eq eax
mov eax,arg
end if
call debug_outdec
popad
popf
}
dpd fix debug_print_dec
;---------------------------------
debug_outdec: ;(eax - num, edi-str)
push 10 ;2
pop ecx ;1
push -'0' ;2
.l0:
xor edx,edx ;2
div ecx ;2
push edx ;1
test eax,eax ;2
jnz .l0 ;2
.l1:
pop eax ;1
add al,'0' ;2
call debug_outchar ; stosb
jnz .l1 ;2
ret ;1
;---------------------------------
debug_outchar: ; al - char
pushf
pushad
mov cl,al
mov eax,63
mov ebx,1
int 0x40
popad
popf
ret
debug_outstr:
mov eax,63
mov ebx,1
@@:
mov cl,[edx]
test cl,cl
jz @f
int 40h
inc edx
jmp @b
@@:
ret
_debug_crlf db 13, 10, 0
macro newline
{
pushf
pushad
mov edx, _debug_crlf
call debug_outstr
popad
popf
}
macro print message
{
dps message
newline
}
macro pregs
{
dps "EAX: "
dpd eax
dps " EBX: "
dpd ebx
newline
dps "ECX: "
dpd ecx
dps " EDX: "
dpd edx
newline
}
macro debug_print_hex arg
{
pushf
pushad
if ~arg eq eax
mov eax, arg
end if
call debug_outhex
popad
popf
}
dph fix debug_print_hex
debug_outhex:
; eax - number
mov edx, 8
.new_char:
rol eax, 4
movzx ecx, al
and cl, 0x0f
mov cl, [__hexdigits + ecx]
pushad
mcall 63, 1
popad
dec edx
jnz .new_char
ret
__hexdigits:
db '0123456789ABCDEF'

193
programs/develop/SPForth/devel/~ac/lib/LOCALS.F Normal file
View File

@ -0,0 +1,193 @@
lib\ext\locals.f \EOF
( 28.Mar.2000 Andrey Cherezov Copyright [C] RU FIG
Использованы идеи следующих авторов:
Ruvim Pinka; Dmitry Yakimov; Oleg Shalyopa; Yuriy Zhilovets;
Konstantin Tarasov
!! Работает, только начиная с 30 билда SPF/3.75: VERSION . 375030 Ok
)
( Простое расширение СП-Форта локальными переменными.
Реализовано без использования LOCALS стандарта 94.
Объявление временных переменных, видимых только внутри
текущего слова и ограниченных временем вызова данного
слова выполняется с помощью слова "{". Внутри определения
слова используется конструкция, подобная стековой нотации Форта
{ список_инициализированных_локалов \ сп.неиниц.локалов -- что угодно }
Например:
{ a b c d \ e f -- i j }
Часть "\ сп.неиниц.локалов" может отсутствовать, например:
{ item1 item2 -- }
Это заставляет СП-Форт автоматически выделять место в
стеке возвратов для этих переменных в момент вызова слова
и автоматически освобождать место при выходе из него.
Обращение к таким локальным переменным - как к VALUE-переменным
по имени. Если нужен адрес переменной, то используется "^ имя".
Примеры:
: TEST { a b c d \ e f -- } a . b . c . b c + -> e e . f . ^ a @ . ;
Ok
1 2 3 4 TEST
1 2 3 5 0 1 Ok
: TEST { a b -- } a . b . CR 5 0 DO I . a . b . CR LOOP ;
Ok
12 34 TEST
12 34
0 12 34
1 12 34
2 12 34
3 12 34
4 12 34
Ok
: TEST { a b } a . b . ;
Ok
1 2 TEST
1 2 Ok
: TEST { a b \ c } a . b . c . ;
Ok
1 2 TEST
1 2 0 Ok
: TEST { a b -- } a . b . ;
Ok
1 2 TEST
1 2 Ok
: TEST { a b \ c -- d } a . b . c . ;
Ok
1 2 TEST
1 2 0 Ok
: TEST { \ a b } a . b . 1 -> a 2 -> b a . b . ;
Ok
TEST
0 0 1 2 Ok
Имена локальных переменных существуют в динамическом
временном словаре только в момент компиляции слова, а
после этого вычищаются и более недоступны.
Использовать конструкцию "{ ... }" внутри одного определения можно
только один раз.
Компиляция этой библиотеки добавляет в текущий словарь компиляции
Только два слова:
словарь "vocLocalsSupport" и "{"
Все остальные детали "спрятаны" в словаре, использовать их
не рекомендуется.
)
VOCABULARY vocLocalsSupport
GET-CURRENT ALSO vocLocalsSupport DEFINITIONS
USER widLocals
USER uLocalsCnt
USER uLocalsUCnt
USER uPrevCurrent
USER uAddDepth
: (Local^) ( N -- ADDR )
RP@ +
;
: LocalOffs ( n -- offs )
uLocalsCnt @ SWAP - CELLS CELL+ uAddDepth @ +
;
: CompileLocalsInit
uPrevCurrent @ SET-CURRENT
uLocalsCnt @ uLocalsUCnt @ - ?DUP IF CELLS LIT, POSTPONE DRMOVE THEN
uLocalsUCnt @ ?DUP IF LIT, POSTPONE (RALLOT) THEN
uLocalsCnt @ ?DUP
IF CELLS LIT, POSTPONE >R ['] (LocalsExit) LIT, POSTPONE >R THEN
;
: CompileLocal@ ( n -- )
LocalOffs LIT, POSTPONE RP+@
;
: LocalsStartup
TEMP-WORDLIST widLocals !
GET-CURRENT uPrevCurrent !
ALSO vocLocalsSupport
ALSO widLocals @ CONTEXT ! DEFINITIONS
uLocalsCnt 0!
uLocalsUCnt 0!
uAddDepth 0!
;
: LocalsCleanup
PREVIOUS PREVIOUS
widLocals @ FREE-WORDLIST
;
: LocalsDoes@
uLocalsCnt @ ,
uLocalsCnt 1+!
DOES> @ CompileLocal@
;
: ;; POSTPONE ; ; IMMEDIATE
: ^ ' >BODY @ LocalOffs LIT, POSTPONE RP+ ; IMMEDIATE
: -> ' >BODY @ LocalOffs LIT, POSTPONE RP+! ; IMMEDIATE
: в POSTPONE -> ; IMMEDIATE
WARNING @ WARNING 0!
\ ===
\ переопределение соответствующих слов для возможности использовать
\ временные переменные внутри цикла DO LOOP и независимо от изменения
\ содержимого стека возвратов словами >R R>
: DO POSTPONE DO [ 3 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: ?DO POSTPONE ?DO [ 3 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: LOOP POSTPONE LOOP [ -3 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: +LOOP POSTPONE +LOOP [ -3 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: >R POSTPONE >R [ 1 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: R> POSTPONE R> [ -1 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: RDROP POSTPONE RDROP [ -1 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
\ ===
: ; LocalsCleanup POSTPONE ; ; IMMEDIATE
WARNING !
\ =====================================================================
SET-CURRENT
: {
LocalsStartup
BEGIN
BL SKIP PeekChar DUP [CHAR] \ <>
OVER [CHAR] - <> AND
SWAP [CHAR] } <> AND
WHILE
CREATE LocalsDoes@ IMMEDIATE
REPEAT
PeekChar >IN 1+! DUP [CHAR] } <>
IF
[CHAR] \ =
IF
BEGIN
BL SKIP PeekChar DUP [CHAR] - <> SWAP [CHAR] } <> AND
WHILE
CREATE LocalsDoes@ IMMEDIATE
uLocalsUCnt 1+!
REPEAT
THEN
[CHAR] } PARSE 2DROP
ELSE DROP THEN
CompileLocalsInit
;; IMMEDIATE
PREVIOUS

9
programs/develop/SPForth/devel/~af/lib/comments.f Normal file
View File

@ -0,0 +1,9 @@
\ $Id: comments.f,v 1.2 2002/06/18 14:50:22 anfilat Exp $
\ ¥é¥ ®¤¨­ ¬­®£®áâà®ç­ë© ª®¬¥­â à¨© :-) (~ruvim)
: (* ( -- )
BEGIN
NextWord DUP 0=
IF NIP REFILL 0= IF DROP TRUE THEN
ELSE S" *)" COMPARE 0= THEN
UNTIL
; IMMEDIATE

25
programs/develop/SPForth/devel/~mak/CompIF.f Normal file
View File

@ -0,0 +1,25 @@
: [ELSE]
1
BEGIN
NextWord DUP
IF
2DUP S" [IF]" COMPARE 0= IF 2DROP 1+ ELSE
2DUP S" [ELSE]" COMPARE 0= IF 2DROP 1- DUP IF 1+ THEN ELSE
S" [THEN]" COMPARE 0= IF 1- THEN
THEN THEN
ELSE 2DROP REFILL AND \ SOURCE TYPE
THEN DUP 0=
UNTIL DROP ; IMMEDIATE
: [IF] 0= IF [COMPILE] [ELSE] THEN ; IMMEDIATE
: [THEN] ; IMMEDIATE
C" \S" FIND NIP 0=
[IF]
: \S \ comment to end of file
SOURCE-ID FILE-SIZE DROP
SOURCE-ID REPOSITION-FILE DROP
[COMPILE] \ ; IMMEDIATE
[THEN]

1559
programs/develop/SPForth/devel/~mak/DIS486.F Normal file
View File

File diff suppressed because it is too large Load Diff

24
programs/develop/SPForth/devel/~mak/acceptgo.f Normal file
View File

@ -0,0 +1,24 @@
REQUIRE ACCEPTHistory ~micro/lib/key/accept.f
: REFILL ( -- flag ) \ 94 FILE EXT
SOURCE-ID IF
REFILL
ELSE
H-STDIN [ H-STDIN ] LITERAL <> IF
REFILL
ELSE
TIB 79 ACCEPT #TIB ! >IN 0! <PRE> -1 EXIT
THEN
THEN
;
: MAIN2 ( -- )
BEGIN
REFILL
WHILE
INTERPRET OK
REPEAT BYE
;
' MAIN2 TO <MAIN>

1502
programs/develop/SPForth/devel/~mak/asm/ASM.FRT Normal file
View File

File diff suppressed because it is too large Load Diff

40
programs/develop/SPForth/devel/~mak/asm/ASM_SIF.F Normal file
View File

@ -0,0 +1,40 @@
REQUIRE [IF] ~MAK\CompIF.f
C" I'" FIND NIP
[IF]
: I' BL WORD FIND 0= IF -321 THROW THEN ( -? ) ;
[THEN]
0x75 CONSTANT 0= 0x74 CONSTANT 0<> 0x79 CONSTANT 0<
0x78 CONSTANT 0>= 0x7D CONSTANT < 0x7C CONSTANT >=
0x7F CONSTANT <= 0x7E CONSTANT > 0x73 CONSTANT U<
0x72 CONSTANT U>= 0x77 CONSTANT U<= 0x76 CONSTANT U>
0x71 CONSTANT OV 0x70 CONSTANT NOV 0xE1 CONSTANT <>C0=
0xE2 CONSTANT C0= 0xE0 CONSTANT ?C0= 0xE3 CONSTANT C0<>
: SIF ( - a) I' EXECUTE C, HERE ( origin) 0 C, ( blank) ;
: SWHILE ( a1 "opcode" - a2 a1) SIF SWAP ;
: STHEN ( a -) HERE OVER 1+ - SWAP C! ;
: SELSE ( a - a') 0xEB ( short jmp) C,
HERE OVER - SWAP C! HERE 0 C, ;
: SBEGIN ( - a) HERE ;
: SUNTIL_ ( a opc -) C, HERE 1+ - C, ;
: SUNTIL ( a -) I' EXECUTE SUNTIL_ ;
: SAGAIN ( a -) 0xEB SUNTIL_ ;
: SREPEAT ( a a1 -) SAGAIN STHEN ;
: SLOOP ( a -) 0xE2 SUNTIL_ ;
: SLOOPZ ( a -) 0xE1 SUNTIL_ ;
: SLOOPNZ ( a -) 0xE0 SUNTIL_ ;
: LIF ( opcode - a) I' EXECUTE 0xF10 + W, HERE ( origin) 0 , ( blank) ;
: LWHILE ( a1 opcode - a2 a1) LIF SWAP ;
: LTHEN ( a -) HERE OVER CELL+ - SWAP ! ;
: LELSE ( a - a') 0xE9 ( short jmp) C,
HERE OVER - SWAP ! HERE 0 , ;
: LUNTIL ( a opc -) I' EXECUTE 0xF10 + W, HERE CELL+ - , ;
: LAGAIN ( a -) 0xE9 C, HERE CELL+ - , ;
: LREPEAT ( a -) LAGAIN LTHEN ;
: II BL WORD FIND1 0= ;

237
programs/develop/SPForth/devel/~mak/asm/asmbase.f Normal file
View File

@ -0,0 +1,237 @@
~mak\utils.f
CREATE GetOp_STR 80 ALLOT
C" SkipDelimiters" FIND NIP 0=
[IF]
: 2+ 2 + ;
: 0! OFF ;
: 1+! incr ;
: 1-! DECR ;
: EndOfChunk ( -- flag )
>IN @ SOURCE NIP < 0= \ >IN ­¥ ¬¥­ìè¥, 祬 ¤«¨­  ç ­ª 
;
: CharAddr ( -- c-addr )
SOURCE DROP >IN @ +
;
: PeekChar ( -- char )
CharAddr C@ \ ᨬ¢®« ¨§ ⥪ã饣® §­ ç¥­¨ï >IN
;
: GetChar ( -- char flag )
EndOfChunk
IF 0 FALSE
ELSE PeekChar TRUE THEN
;
: IsDelimiter ( char -- flag )
BL 1+ < ;
: OnDelimiter ( -- flag )
GetChar SWAP IsDelimiter AND
;
: SkipDelimiters ( -- ) \ ¯à®¯ãáâ¨âì ¯à®¡¥«ì­ë¥ ᨬ¢®«ë
BEGIN
OnDelimiter
WHILE
>IN 1+!
REPEAT
;
: RDROP POSTPONE R>DROP ; IMMEDIATE
[THEN]
: OnNotDelimiter_ ( C -- flag )
DUP [CHAR] 0 U< IF DROP FALSE EXIT THEN
DUP [CHAR] : U< IF DROP TRUE EXIT THEN
DUP [CHAR] @ U< IF DROP FALSE EXIT THEN
DUP [CHAR] [ U< IF DROP TRUE EXIT THEN
DUP [CHAR] _ = IF DROP TRUE EXIT THEN
DUP [CHAR] a U< IF DROP FALSE EXIT THEN
DUP [CHAR] { U< IF DROP TRUE EXIT THEN
DROP FALSE
;
: SkipWord_ ( -- ) \ ¯à®¯ãáâ¨âì term ᨬ¢®«ë
BEGIN
GetChar IF OnNotDelimiter_ THEN
WHILE
>IN 1+!
REPEAT ;
: ParseWord_ ( -- c-addr u )
CharAddr >IN @
SkipWord_
>IN @ - NEGATE ;
C" UPPER" FIND NIP 0=
[IF]
BASE @ HEX
: UPC ( c -- c' )
DUP [CHAR] Z U>
IF DF AND
THEN ;
BASE !
: UPPER ( ADDR LEN -- )
0 ?DO COUNT UPC OVER 1- C! LOOP DROP ;
[THEN]
: IN>R POSTPONE >IN
POSTPONE @
POSTPONE >R ; IMMEDIATE
: R>IN POSTPONE R>
POSTPONE >IN
POSTPONE ! ; IMMEDIATE
: GetOp_BS ParseWord_ GetOp_STR PLACE GetOp_STR ;
: non-term 1 GetOp_STR C! PeekChar GetOp_STR 1+ C! >IN 1+! GetOp_STR ;
: TERM-STR CharAddr SkipWord_ CharAddr OVER -
GetOp_STR PLACE GetOp_STR DUP COUNT UPPER ;
\ types: 1 - non-term (comments, etc.)
\ 2 - number
\ 3 - name
\ 4 - "-bracketed string
\ 5 - '-bracketed string
CREATE XXX 0 ,
: (GetOp) ( --> string type )
SkipDelimiters
GetChar 0= IF DROP XXX FALSE EXIT THEN
DUP [CHAR] 0 <
IF DUP [CHAR] " =
IF [CHAR] " GetOp_BS 4 EXIT
THEN
[CHAR] ' =
IF [CHAR] ' GetOp_BS 5 EXIT
THEN non-term 1 EXIT
THEN
DUP [CHAR] : <
IF DROP TERM-STR 2 EXIT
THEN
OnNotDelimiter_
IF TERM-STR 3 EXIT
THEN non-term 1 ;
: IFNOT POSTPONE 0=
POSTPONE IF ; IMMEDIATE
1000 ALLOT
HERE CONSTANT LS0
VARIABLE LSP
LS0 LSP !
: ADDNUMOBJECT ( name addr type --> )
-11 LSP +!
LSP @ C!
11 LSP @ 1+ W!
LSP @ 3 + !
LSP @ 7 + ! ;
: AddStrObject ( name addr type --> )
ROT
DUP C@ 1+ NEGATE LSP +!
COUNT LSP @ PLACE \ addr type
-7 LSP +!
LSP @ C!
LSP @ 7 + C@ 8 +
LSP @ 1+ W!
LSP @ 3 + ! ;
0
1 FIELD L_TYPE
2 FIELD L_SIZE
4 FIELD L_ADDR
0 FIELD L_NAME
DROP
: FindStrObject ( name type --> addr true | false )
LSP @ >R
BEGIN R@ L_SIZE W@
WHILE
DUP R@ L_TYPE C@ =
IF OVER R@ L_SIZE W@ 7 -
R@ L_NAME R@ L_SIZE W@ 7 - COMPARE 0=
IF 2DROP R> L_ADDR @ TRUE EXIT
THEN
THEN R@ L_SIZE W@ R> + >R
REPEAT 2DROP RDROP FALSE ;
CREATE NullString 0 ,
: ConvertString ;
: S= ( c-addr1 c-addr2 --> true | c-addr1 false )
OVER COUNT ROT COUNT
COMPARE
IF FALSE
ELSE DROP TRUE
THEN ;
: ?S= ( flag n R: >IN --> R: >IN | -->> n true )
SWAP
IF 2R> 2DROP TRUE EXIT
THEN DROP
;
ALSO FORTH DEFINITIONS
: VAL ( ADDR -- UD2 FLAG )
0 0 ROT COUNT >NUMBER NIP 0= ;
VARIABLE CUR-PAB
HERE 0 , CUR-PAB !
: ?PABLIC ( CFA -- FLAG )
CUR-PAB @
BEGIN 2DUP @ U<
WHILE @
REPEAT CELL+ @ = ;
: PABLIC ( -- )
HERE CUR-PAB @ , LAST @ NAME> , CUR-PAB ! ;
: >L
-4 LSP +!
LSP @ ! ;
: L>
LSP @ @
4 LSP +! ;
: ERR_ TRUE ABORT" " ;
C" 1-!" FIND NIP 0=
[IF]
: 1-! ( ADDR -- )
DUP>R @ 1- R> ! ;
[THEN]
C" ON" FIND NIP 0=
[IF]
: ON ( ADDR -- )
TRUE SWAP ! ;
[THEN]
C" ?PAIRS" FIND NIP 0=
[IF]
: ?PAIRS XOR ABORT" conditionals not paired" ;
[THEN]
\ : 'Alias ' Alias ;
PREVIOUS DEFINITIONS

1
programs/develop/SPForth/devel/~mak/author.txt Normal file
View File

@ -0,0 +1 @@
Mihail Maksimov [mak@rtc.ru]

33
programs/develop/SPForth/devel/~mak/case.f Normal file
View File

@ -0,0 +1,33 @@
VARIABLE CSP \ Óêàçàòåëü ñòåêà êîíòðîëÿ
: CASE
CSP @ SP@ CSP ! ; IMMEDIATE
: ?OF_
POSTPONE IF POSTPONE DROP ; IMMEDIATE
: OF
POSTPONE OVER POSTPONE = POSTPONE ?OF_ ; IMMEDIATE
: ENDOF
POSTPONE ELSE ; IMMEDIATE
: DUPENDCASE
BEGIN SP@ CSP @ <> WHILE POSTPONE THEN REPEAT
CSP ! ; IMMEDIATE
: ENDCASE
POSTPONE DROP POSTPONE DUPENDCASE
; IMMEDIATE
: OF\
POSTPONE OVER POSTPONE <> POSTPONE IF ; IMMEDIATE
: OF;
POSTPONE OVER POSTPONE = POSTPONE IF 2>R
POSTPONE DUPENDCASE 2R>
POSTPONE DROP ; IMMEDIATE
HEX

637
programs/develop/SPForth/devel/~mak/djgpp/gdis.F Normal file
View File

@ -0,0 +1,637 @@
\ HSSSS H.
[IFNDEF] BREAK
: BREAK POSTPONE EXIT POSTPONE THEN ; IMMEDIATE
[THEN]
C" VECT-CODE" FIND NIP 0=
[IF] ' _VECT-CODE VALUE VECT-CODE
[ELSE] ' _VECT-CODE TO VECT-CODE
[THEN]
C" USER-CODE" FIND NIP 0=
[IF] ' _USER-CODE VALUE USER-CODE
[ELSE] ' _USER-CODE TO USER-CODE
[THEN]
C" USER-VALUE-CODE" FIND NIP 0=
[IF] ' _USER-VALUE-CODE VALUE USER-VALUE-CODE
[ELSE] ' _USER-VALUE-CODE TO USER-VALUE-CODE
[THEN]
\ ' _CONSTANT-CODE TO CONSTANT-CODE
\ ' _CREATE-CODE TO CREATE-CODE
\ ' _CLITERAL-CODE TO CLITERAL-CODE
\ ' _SLITERAL-CODE TO SLITERAL-CODE
BASE @ HEX
: DUP5B?0 ( C -- C FLAG )
DUP 0C7 AND 5 = \ ADD|OR|ADC|SBB|AND|SUB|XOR|CMP EAX, # X
OVER 0FC AND 0B8 = OR \ MOV EAX|EBX|ECX|EDX, # X
;
: DUP5B?1 ( C -- C FLAG )
DUP 0FD AND 0A1 = \ MOV EAX, X | X , EAX
;
: DUP6B?0 ( W -- W FLAG )
DUP C3FF AND C081 = \ ADD|OR|ADC|SBB|AND|SUB|XOR|CMP EAX, # X
OVER 0C7 = OR \ MOV [EAX], # X
\ OVER 878B = OR \ MOV EAX, X [EDI]
\ OVER 878D = OR \ LEA EAX, X [EDI]
\ OVER 873B = OR \ CMP EAX, X [EDI]
;
: DUP6B?1 ( W -- W FLAG )
DUP 00501 = \ ADD X , EAX
OVER 053B = OR \ CMP EAX, X
\ X00X.X101 1000.10X1
OVER 67FD AND 0589 = OR \ MOV X {[EBP]}, E(ACDB)X | E(ACDB)X , X {[EBP]}
OVER 0589 = OR \ MOV X , EAX
OVER 058D = OR \ MOV EAX, X
OVER 1D8D = OR \ MOV EBX, X
OVER 808B = OR \ MOV EAX, X [EAX]
OVER 05FF = OR \ INC X
\ OVER FCFF AND C0C7 = OR \ MOV EAX|EBX|ECX|EDX, # X
;
: UV> ' >BODY @ TlsIndex@ + POSTPONE LITERAL ; IMMEDIATE
\ : GGGX H. ." -0x" TlsIndex@ H. ." -0x" RESERVE H. ;
: .EDI ( ADDR n -- ADDR1 )
." [
DROP 2+ DUP @
\ ." XX" DUP H.
TlsIndex@ +
CASE
R0 OF ." T_R0" ENDOF
S0 OF ." T_S0" ENDOF
WARNING OF ." T_WARNING" ENDOF
STATE OF ." T_STATE" ENDOF
BLK OF ." T_BLK" ENDOF
CURFILE OF ." T_CURFILE" ENDOF
HANDLER OF ." T_HANDLER" ENDOF
HLD OF ." T_HLD" ENDOF
BASE OF ." T_BASE" ENDOF
PAD OF ." T_PAD" ENDOF
ER-A OF ." T_ERminusA" ENDOF
ER-U OF ." T_ERminusU" ENDOF
DOES>A OF ." T_DOESgreatA" ENDOF
#TIB OF ." T_nTIB" ENDOF
>IN OF ." T_greatIN" ENDOF
UV> TIB OF ." T_TIB" ENDOF
ATIB OF ." T_ATIB" ENDOF
UV> SOURCE-ID OF ." T_SOURCEminusID" ENDOF
CURSTR OF ." T_CURSTR" ENDOF
\ WBW-NFA OF ." T_WBWminusNFA" ENDOF
\ WBW-OFFS OF ." T_WBWminusOFFS" ENDOF
CURRENT OF ." T_CURRENT" ENDOF
S-O OF ." T_SminusO" ENDOF
UV> CONTEXT OF ." T_CONTEXT" ENDOF
>OUT OF ." T_greatOUT" ENDOF
W-CNT OF ." T_WminusCNT" ENDOF
\ NNN OF ." T_NNN" ENDOF
TlsIndex@ - RESERVE - DUP 0< IF CR ." (%edi) RESERVE " ABORT THEN
." reserve+0x"
H. ." +edi]" CELL+ EXIT
ENDCASE ." -main_task+edi]" CELL+
;
\ RESERVE - DUP 0< IF CR ." (%edi) RESERVE "
\ TlsIndex@ H. RESERVE H. TlsIndex@ - H. H. ABORT THEN
\ ." reserve+0x" GGGX ." +edi]" CELL+ EXIT
\ ." reserve+0x" TlsIndex@ - H. RESERVE H. ." +edi]" CELL+ EXIT
\ ENDCASE ." -main_task+edi]" CELL+ ;
: H.-H ." 0" BASE @ HEX SWAP U>D (D.) TYPE BASE ! ." H" ;
: 1_GD_STEP ( ADDR n -- ADDR1 )
CR ." DB " 0xFF AND H.-H 1+ ;
: 2_GD_STEP ( ADDR -- ADDR1 )
1_GD_STEP ." ," DUP C@ H.-H 1+ ;
: 3_GD_STEP ( ADDR -- ADDR1 )
2_GD_STEP ." ," DUP C@ H.-H 1+ ;
: 4_GD_STEP ( ADDR -- ADDR1 )
3_GD_STEP ." ," DUP C@ H.-H 1+ ;
[IFNDEF] OCTAL : OCTAL 8 BASE ! ;
[THEN]
: \ooo. ( n1 -- )
BASE @ >R DECIMAL
0 (D.) TYPE
R> BASE ! ;
: ATYPE ( arrd len -- )
DUP 0= IF 2DROP BREAK
[CHAR] ' EMIT
0 ?DO COUNT DUP [CHAR] ' = IF ." '" THEN EMIT
LOOP DROP
[CHAR] ' EMIT
;
0x5F535953 CONSTANT 'SYS_'
: GTYPE
OVER @ 'SYS_' = IF 4 - SWAP 4 + SWAP TYPE BREAK
." cfa_"
2DUP S" CONTEXT" COMPARE 0= IF 2DROP ." _CONTEXT" BREAK
2DUP S" WORD" COMPARE 0= IF 2DROP ." _WORD" BREAK
2DUP S" LEAVE" COMPARE 0= IF 2DROP ." _LEAVE" BREAK
2DUP S" REPEAT" COMPARE 0= IF 2DROP ." _REPEAT" BREAK
2DUP S" exit" COMPARE 0= IF 2DROP ." _exit" BREAK
2DUP S" CHAR" COMPARE 0= IF 2DROP ." _CHAR" BREAK
2DUP S" IF" COMPARE 0= IF 2DROP ." _IF" BREAK
2DUP S" ELSE" COMPARE 0= IF 2DROP ." _ELSE" BREAK
2DUP S" WHILE" COMPARE 0= IF 2DROP ." _WHILE" BREAK
2DUP S" RESIZE" COMPARE 0= IF 2DROP ." _RESIZE" BREAK
2DUP S" free" COMPARE 0= IF 2DROP ." _free" BREAK
2DUP S" write" COMPARE 0= IF 2DROP ." _write" BREAK
2DUP S" KEY_EVENT" COMPARE 0= IF 2DROP ." _KEY_EVENT" BREAK
2DUP S" PAGE" COMPARE 0= IF 2DROP ." _PAGE" BREAK
2DUP S" PAGE_EXECUTE_READWRITE" COMPARE 0= IF 2DROP ." _PAGE_EXECUTE_READWRITE" BREAK
2DUP S" MEM_COMMIT" COMPARE 0= IF 2DROP ." _MEM_COMMIT" BREAK
2DUP S" MEM_RESERVE" COMPARE 0= IF 2DROP ." _MEM_RESERVE" BREAK
2DUP S" INVALID_HANDLE_VALUE" COMPARE 0= IF 2DROP ." _INVALID_HANDLE_VALUE" BREAK
2DUP S" FILE_ATTRIBUTE_ARCHIVE" COMPARE 0= IF 2DROP ." _FILE_ATTRIBUTE_ARCHIVE" BREAK
2DUP S" CREATE_ALWAYS" COMPARE 0= IF 2DROP ." _CREATE_ALWAYS" BREAK
2DUP S" OPEN_EXISTING" COMPARE 0= IF 2DROP ." _OPEN_EXISTING" BREAK
2DUP S" FILE_BEGIN" COMPARE 0= IF 2DROP ." _FILE_BEGIN" BREAK
2DUP S" FILE_CURRENT" COMPARE 0= IF 2DROP ." _FILE_CURRENT" BREAK
2DUP S" EXTERN" COMPARE 0= IF 2DROP ." _EXTERN" BREAK
2DUP S" EXPORT" COMPARE 0= IF 2DROP ." _EXPORT" BREAK
2DUP S" BREAK" COMPARE 0= IF 2DROP ." _BREAK" BREAK
2DUP S" ERR" COMPARE 0= IF 2DROP ." _ERR" BREAK
0 DO COUNT
CASE
[CHAR] @ OF ." _ld" ENDOF
[CHAR] ! OF ." save" ENDOF
[CHAR] = OF ." _equ" ENDOF
[CHAR] < OF ." less" ENDOF
[CHAR] > OF ." great" ENDOF
[CHAR] + OF ." plus" ENDOF
[CHAR] - OF ." minus" ENDOF
[CHAR] * OF ." _mul" ENDOF
[CHAR] / OF ." _div" ENDOF
[CHAR] . OF ." dot" ENDOF
[CHAR] : OF ." dcoma" ENDOF
[CHAR] ; OF ." _end" ENDOF
[CHAR] ? OF ." que" ENDOF
[CHAR] ( OF ." _c" ENDOF
[CHAR] ) OF ." cend" ENDOF
[CHAR] [ OF ." _x" ENDOF
[CHAR] ] OF ." _y" ENDOF
[CHAR] { OF ." lsk" ENDOF
[CHAR] } OF ." rsk" ENDOF
[CHAR] , OF ." com" ENDOF
[CHAR] ' OF ." tic" ENDOF
[CHAR] ~ OF ." til" ENDOF
[CHAR] ^ OF ." pic" ENDOF
[CHAR] " OF ." dtic" ENDOF
[CHAR] | OF ." l" ENDOF
[CHAR] # OF ." n" ENDOF
[CHAR] $ OF ." dol" ENDOF
[CHAR] \ OF ." sl" ENDOF
[CHAR] & OF ." and_" ENDOF
I IF EMIT ENDOF
[CHAR] 0 OF ." _0" ENDOF
[CHAR] 1 OF ." _1" ENDOF
[CHAR] 2 OF ." _2" ENDOF
[CHAR] 3 OF ." _3" ENDOF
[CHAR] 4 OF ." _4" ENDOF
[CHAR] 5 OF ." _5" ENDOF
[CHAR] 6 OF ." _6" ENDOF
[CHAR] 7 OF ." _7" ENDOF
[CHAR] 8 OF ." _8" ENDOF
[CHAR] 9 OF ." _9" ENDOF
EMIT
0 ENDCASE
LOOP DROP ;
0 VALUE #GN
: GN. ( ADDR -- )
DUP 0x80 + 0xFFFFFF00 AND 0= \ ABS 0x7F <
IF H.-H EXIT THEN
DUP HERE U<
IF DUP WordByAddr
OVER >R GTYPE ." +"
R> 1- NAME> - DUP TO #GN H.-H
ELSE NEGATE DUP WordByAddr
>R >R
R@ 1- NAME> - DUP TO #GN H.-H
." -" R> R> GTYPE
THEN
;
: .INT ( ADDR -- ADDR1 )
CR DUP HSSSS @ +
@ OVER @ \ ." I=" 2DUP H. H. CR
=
IF ." DD " DUP @ H.-H
ELSE ." DD " DUP @ GN.
THEN CELL+ ;
: .ADR ( ADDR -- ADDR1 )
CR ." DD " DUP @ GN. CELL+ ;
: .ADR68 ( ADDR -- ADDR1 )
CR ." DD 68 " DUP @ DUP H. GN. CELL+ ;
: 5_GD_STEP0 ( ADDR -- ADDR1 )
1_GD_STEP .INT ;
: 5_GD_STEP1 ( ADDR -- ADDR1 )
1_GD_STEP .ADR ;
: 6_GD_STEP0 ( ADDR -- ADDR1 )
2_GD_STEP .INT ;
: 6_GD_STEP1 ( ADDR -- ADDR1 )
2_GD_STEP .ADR ;
: 7_GD_STEP ( ADDR -- ADDR1 )
3_GD_STEP .ADR ;
: 1A_GD_STEP ( ADDR c -- ADDR1 )
DROP 1+ DUP REL@ CELL+ GN. CELL+ ;
: 2A_GD_STEP ( ADDR W -- ADDR1 )
CR ." DW "
H.-H 2+ DUP REL@ CELL+
CR ." DD " GN. ." -$-4" CELL+ ;
C" C>S" FIND NIP 0=
[IF] : C>S ( c -- n ) 0xFF AND [ 0x7F INVERT ] LITERAL XOR 0x80 + ;
[THEN]
: J_GD_STEP_
0x70 - 3 *
C" jo jnojb jaeje jnejbeja js jnsjp jnpjl jgejlejg " 1+ +
CR 3 TYPE ." " 1+ DUP C@ C>S OVER + 1+ GN. 1+
; \ short
: J_GD_STEP
DUP >R
0x70 - 3 *
C" jo jnojb jaeje jnejbeja js jnsjp jnpjl jgejlejg " 1+ +
CR ." ;" 3 TYPE ." " 1+ DUP C@ C>S OVER + 1+ GN. 1+
2- R>
#GN IF 2_GD_STEP EXIT THEN
J_GD_STEP_
; \ short
: GD-STEP ( CFA -- CFA+N )
\ DUP 9 EMIT H.
DUP C@ \ CFA N'
DUP 0C3 = IF 1_GD_STEP EXIT THEN \ RET
DUP 066 = IF 1_GD_STEP EXIT THEN \ D16:
DUP 064 = IF 1_GD_STEP EXIT THEN \ FS:
DUP 068 = IF 1_GD_STEP .INT EXIT THEN \ push X
\ LOOPNZ X LOOPZ X LOOP X JECXZ X IN AL, 0 IN EAX, 0 OUT 0 , AL OUT 0 , EAX
\ 1110.0XXX
DUP 0F8 AND 0E0 = IF 2_GD_STEP EXIT THEN
\ 010X.XXXX
DUP 0E0 AND 040 = IF 1_GD_STEP EXIT THEN \ INC|DEC|PUSH|POP E_X
\ 0111.0XXX
DUP 0F0 AND 070 = IF J_GD_STEP EXIT THEN \ JO short
DUP 0EB = IF 2_GD_STEP EXIT THEN \ JMP
DUP 090 = IF 1_GD_STEP EXIT THEN \ !!!!!
DUP 099 = IF 1_GD_STEP EXIT THEN \ CDQ
DUP 0A4 = IF 1_GD_STEP EXIT THEN \
DUP 0A5 = IF 1_GD_STEP EXIT THEN \
DUP 0A6 = IF 1_GD_STEP EXIT THEN \
DUP 0AA = IF 1_GD_STEP EXIT THEN \
DUP 0AB = IF 1_GD_STEP EXIT THEN \
DUP 0AC = IF 1_GD_STEP EXIT THEN \
DUP 0AE = IF 1_GD_STEP EXIT THEN \
DUP 024 = IF 2_GD_STEP EXIT THEN \ AND AL , # 1
DUP 02C = IF 2_GD_STEP EXIT THEN \ SUB AL , # 1
DUP 03C = IF 2_GD_STEP EXIT THEN \ CMP AL , # 1
DUP 0CD = IF 2_GD_STEP EXIT THEN \ INT X
DUP 0B0 = IF 2_GD_STEP EXIT THEN \
DUP 0F2 = IF 1_GD_STEP EXIT THEN \
DUP 0F3 = IF 2_GD_STEP EXIT THEN \ REPZ CMPSB
DUP 0FC = IF 1_GD_STEP EXIT THEN \ CLD
DUP 0FD = IF 1_GD_STEP EXIT THEN \ STD
DUP 09C = IF 1_GD_STEP EXIT THEN \ PUSHFD
DUP 09D = IF 1_GD_STEP EXIT THEN \ POPFD
DUP5B?0 IF 5_GD_STEP0 EXIT THEN
DUP5B?1 IF 5_GD_STEP1 EXIT THEN
DUP 0E9 = IF CR ." DB 0E9H"
CR ." DD " 1A_GD_STEP ." -$-4" EXIT THEN \ JMP
DUP 0E8 = IF CR ." call " 1A_GD_STEP
DUP CELL- REL@ CELL+
DUP USER-VALUE-CODE =
OVER USER-CODE = OR
IF CR ." DD reserve+"
DROP DUP @ RESERVE - H.-H CELL+
EXIT
THEN
CONSTANT-CODE =
IF .INT EXIT
THEN
DUP CELL- REL@ CELL+
CREATE-CODE =
IF .INT 2DUP U>
IF DUP C@ 1_GD_STEP
BEGIN 2DUP U>
WHILE DUP 7 AND
IF ." ,"
ELSE CR ." DB "
THEN DUP C@ H.-H 1+
REPEAT
THEN EXIT
THEN
DUP CELL- REL@ CELL+
DUP CLITERAL-CODE =
OVER ALITERAL-CODE = OR
SWAP SLITERAL-CODE = OR
IF CR ." DB " DUP COUNT DUP>R DUP H.-H
CR ." DB " ATYPE ." ,0"
R> + 2+ EXIT
THEN
DUP CELL- REL@ CELL+
VECT-CODE =
IF .ADR EXIT
THEN
EXIT THEN \ CALL
\ 1110.11XX
DUP FC AND EC = IF 1_GD_STEP EXIT THEN \ IN|OUT EAX AL, DX | DX, EAX EL
DROP
DUP W@ \ CR ." G=" DUP H.
DUP3B?[EBP] IF 3_GD_STEP EXIT THEN
DUP3B? IF 3_GD_STEP EXIT THEN
DUP2B? IF 2_GD_STEP EXIT THEN
DUP 0DB0A = IF 2_GD_STEP EXIT THEN \ OR BL, BL
DUP 0C90A = IF 2_GD_STEP EXIT THEN \ OR CL, CL
DUP 0038B = IF 2_GD_STEP EXIT THEN \ MOV EAX, [EBX]
DUP 0EC87 = IF 2_GD_STEP EXIT THEN \
DUP 0188A = IF 2_GD_STEP EXIT THEN \ MOV BL, [EAX]
DUP 07D8B = IF 3_GD_STEP EXIT THEN \ MOV EDI, X [EBP]
DUP 0C58B = IF 2_GD_STEP EXIT THEN \ MOV EAX, EBP
DUP 0E08B = IF 2_GD_STEP EXIT THEN \ MOV EAX, EBP
DUP 0E88B = IF 2_GD_STEP EXIT THEN \ MOV EAX, EBP
DUP 0458F = IF 3_GD_STEP EXIT THEN \ POP X [EBP]
DUP 075FF = IF 3_GD_STEP EXIT THEN \ PUSH X [EBP]
DUP 0C009 = IF 2_GD_STEP EXIT THEN \ OR EAX, EAX
DUP 0E3FF = IF 2_GD_STEP EXIT THEN \ JMP EBX
\ DUP 0D2FF = IF 2_GD_STEP EXIT THEN \ JMP EDX
DUP 0E2FF = IF 2_GD_STEP EXIT THEN \ JMP EDX
DUP 0D0FF = IF 2_GD_STEP EXIT THEN
DUP 0D2FF = IF 2_GD_STEP EXIT THEN \ CALL EDX
DUP 023FF = IF 2_GD_STEP EXIT THEN \ JMP [EBX]
DUP 0F903 = IF 2_GD_STEP EXIT THEN \ ADD EDI, ECX
DUP 0F103 = IF 2_GD_STEP EXIT THEN \ ADD ESI, ECX
DUP 0F003 = IF 2_GD_STEP EXIT THEN \ ADD ESI, EAX
DUP 0D703 = IF 2_GD_STEP EXIT THEN \ ADD EDX, EDI
DUP 0C703 = IF 2_GD_STEP EXIT THEN \ ADD EAX, EDI
DUP 0DF03 = IF 2_GD_STEP EXIT THEN \ ADD EBX, EDI
DUP 0E103 = IF 2_GD_STEP EXIT THEN \ ADD ESP, ECX
DUP 0E303 = IF 2_GD_STEP EXIT THEN \ ADD ESP, EBX
DUP 0E803 = IF 2_GD_STEP EXIT THEN \ ADD EBP, EAX
DUP 0EB03 = IF 2_GD_STEP EXIT THEN
DUP 0F803 = IF 2_GD_STEP EXIT THEN \ ADD EDI, EAX
DUP 0E903 = IF 2_GD_STEP EXIT THEN \ ADD EBP, ECX
DUP 0523 = IF 2_GD_STEP .INT EXIT THEN \ AND EAX , 55C18F
DUP 052B = IF 2_GD_STEP .INT EXIT THEN \ SUB EAX , 55C18F
DUP 0C72B = IF 2_GD_STEP EXIT THEN \ SUB EAX, EDI
DUP 0CD2B = IF 2_GD_STEP EXIT THEN \ SUB ECX, EBP
DUP 0CF2B = IF 2_GD_STEP EXIT THEN \ SUB ECX, EDI
DUP 0D72B = IF 2_GD_STEP EXIT THEN \ SUB EDX, EDI
DUP 0F22B = IF 2_GD_STEP EXIT THEN \ SUB ESI, EDX
DUP 0DE2B = IF 2_GD_STEP EXIT THEN \ SUB EBX, ESI
DUP 0E32B = IF 2_GD_STEP EXIT THEN \ SUB ESP, EBX
DUP 0E82B = IF 2_GD_STEP EXIT THEN \ SUB EBP, EAX
DUP 0FF33 = IF 2_GD_STEP EXIT THEN \ xor EDI, EDI
DUP 0D233 = IF 2_GD_STEP EXIT THEN \ xor EDX, EDX
DUP 0F33B = IF 2_GD_STEP EXIT THEN \ CMP ESI, EBX
DUP 0C13A = IF 2_GD_STEP EXIT THEN \ CMP AL, CL
DUP 0C23A = IF 2_GD_STEP EXIT THEN \ CMP AL, DL
DUP 0D83A = IF 2_GD_STEP EXIT THEN \ CMP BL, AL
DUP 0EB80 = IF 3_GD_STEP EXIT THEN \ SUB BL, # X
DUP 0FB80 = IF 3_GD_STEP EXIT THEN \ CMP BL, # X
DUP 0C0C6 = IF 3_GD_STEP EXIT THEN \ MOV AL, # 0
DUP 00081 = IF 2_GD_STEP .INT EXIT THEN \ ADD [EAX] , # 800
DUP 0581 = IF 2_GD_STEP .ADR .INT EXIT THEN \ ADD X , # Y
DUP 0E181 = IF 2_GD_STEP .INT EXIT THEN \ AND ECX, # FF
DUP 0E281 = IF 2_GD_STEP .INT EXIT THEN \ AND EDX, # FF
DUP 0F981 = IF 2_GD_STEP .INT EXIT THEN \ CMP ECX, # 1
DUP 04583 = IF 4_GD_STEP EXIT THEN \ ADD F8 [EBP] , # 2
DUP 0EB83 = IF 3_GD_STEP EXIT THEN \ SUB EBX, # X
DUP 0FB83 = IF 3_GD_STEP EXIT THEN \ CMP EBX, # X
DUP 0EE83 = IF 3_GD_STEP EXIT THEN \ SUB ESI, # X
DUP 0E183 = IF 3_GD_STEP EXIT THEN \ AND ECX, # 3
DUP 0E383 = IF 3_GD_STEP EXIT THEN \ AND EBX, # 3
DUP 0EC83 = IF 3_GD_STEP EXIT THEN
DUP 0F9C1 = IF 3_GD_STEP EXIT THEN \ SAR ECX, # 2
DUP 01889 = IF 2_GD_STEP EXIT THEN \ MOV [EAX], EBX
DUP 04889 = IF 3_GD_STEP EXIT THEN \ MOV X [EAX], ECX
DUP 04289 = IF 3_GD_STEP EXIT THEN \ MOV 4 [EDX], EAX
DUP 04B89 = IF 3_GD_STEP EXIT THEN \ MOV 2 [EBX], ECX
DUP 0468A = IF 3_GD_STEP EXIT THEN \ MOV AL, X [ESI]
DUP 0088A = IF 2_GD_STEP EXIT THEN \ MOV CL, [EAX]
DUP 0068B = IF 2_GD_STEP EXIT THEN \ MOV EAX, [ESI]
DUP 01B8B = IF 2_GD_STEP EXIT THEN \ MOV EBX, [EBX]
DUP DF8B = IF 2_GD_STEP EXIT THEN \ MOV EBX, EDI
DUP EC8B = IF 2_GD_STEP EXIT THEN
DUP 05089 = IF 3_GD_STEP EXIT THEN \ MOV X [EAX] , EDX
DUP 0368B = IF 2_GD_STEP EXIT THEN \ MOV ESI, [ESI]
DUP 0758B = IF 3_GD_STEP EXIT THEN \ MOV ESI, X [EBP]
DUP 0408B = IF 3_GD_STEP EXIT THEN \ MOV EAX, X [EAX]
DUP 0498B = IF 3_GD_STEP EXIT THEN \ MOV ECX, FC [ECX]
DUP 04B8B = IF 3_GD_STEP EXIT THEN \ MOV ECX, 12 [EBX]
DUP 0E58B = IF 2_GD_STEP EXIT THEN
DUP 06D8D = IF 3_GD_STEP EXIT THEN \ LEA EBP, OFF-EBP [EBP]
DUP 0C583 = IF 3_GD_STEP EXIT THEN \ ADD EBP, # OFF-EBP
DUP 0ED83 = IF 3_GD_STEP EXIT THEN \ SUB EBP, # X
DUP 0C483 = IF 3_GD_STEP EXIT THEN \ ADD ESP, # X
DUP 0FA83 = IF 3_GD_STEP EXIT THEN \ CMP EDX, # 3
DUP 07D83 = IF 4_GD_STEP EXIT THEN \ CMP X [EBP] , # Y
DUP 07D89 = IF 3_GD_STEP EXIT THEN \ MOV X [EBP], EDI
DUP 0CC8B = IF 2_GD_STEP EXIT THEN
DUP 0F58B = IF 2_GD_STEP EXIT THEN
DUP 0FC8B = IF 2_GD_STEP EXIT THEN
DUP 0F0FF AND
0800F = IF 2A_GD_STEP EXIT THEN \ JNO X
DUP 075F7 = IF 3_GD_STEP EXIT THEN \ DIV DWORD [EBP]
DUP 0D9F7 = IF 2_GD_STEP EXIT THEN \ NEG ECX
DUP 0DBF7 = IF 2_GD_STEP EXIT THEN \ NEG EBX
DUP 0E3F7 = IF 2_GD_STEP EXIT THEN \ MUL EBX
DUP 0EBF7 = IF 2_GD_STEP EXIT THEN \ IMUL EBX
DUP 0FBF7 = IF 2_GD_STEP EXIT THEN \ IDIV EBX
DUP 0F3F7 = IF 2_GD_STEP EXIT THEN \ DIV EBX
DUP 0F60B = IF 2_GD_STEP EXIT THEN \ OR ESI, ESI
DUP 0CE8B = IF 2_GD_STEP EXIT THEN \ MOV ECX, ESI
DUP 0C48B = IF 2_GD_STEP EXIT THEN \ MOV EAX, ESP
DUP 0F18B = IF 2_GD_STEP EXIT THEN \ MOV ESI, ECX
DUP 0F08B = IF 2_GD_STEP EXIT THEN \ MOV ESI, EAX
DUP 0D58B = IF 2_GD_STEP EXIT THEN \ MOV EDX, EBP
DUP 0D78B = IF 2_GD_STEP EXIT THEN \ MOV EDX, EDI
DUP 0DD8B = IF 2_GD_STEP EXIT THEN \ MOV EBX, EBP
DUP 0FA8B = IF 2_GD_STEP EXIT THEN \ MOV EDI, EDX
DUP 01A8B = IF 2_GD_STEP EXIT THEN \ MOV EBX, [EDX]
DUP 0028B = IF 2_GD_STEP EXIT THEN \ MOV EAX, [EDX]
DUP 0078B = IF 2_GD_STEP EXIT THEN \ MOV EAX, [EDI]
DUP 088B = IF 2_GD_STEP EXIT THEN \ MOV ECX, [EAX]
DUP 098B = IF 2_GD_STEP EXIT THEN \ MOV ECX, [ECX]
DUP 0A8B = IF 2_GD_STEP EXIT THEN \ MOV ECX, [EDX]
DUP 00C6 = IF 3_GD_STEP EXIT THEN \ MOV [EAX] , # x
DUP 0688D = IF 3_GD_STEP EXIT THEN \ LEA EBP, 4 [EAX]
DUP 0428D = IF 3_GD_STEP EXIT THEN \ LEA EAX , FE [EDX]
DUP 0498D = IF 3_GD_STEP EXIT THEN \ LEA ECX, -1 [ECX]
DUP 0488D = IF 3_GD_STEP EXIT THEN \ LEA ECX , FC [EAX]
DUP 07F8D = IF 3_GD_STEP EXIT THEN \ LEA EDI, -1 [EDI]
DUP 0528D = IF 3_GD_STEP EXIT THEN \ LEA EDX, -4 [EDX]
\ DUP 01C8D = IF 3_GD_STEP EXIT THEN \ LEA EBX, [EDX] [EAX]
DUP 0038F = IF 2_GD_STEP EXIT THEN \ POP [EBX]
DUP 05DD1 = IF 3_GD_STEP EXIT THEN \ RCR [EBP], # 1
DUP 0D0D1 = IF 2_GD_STEP EXIT THEN \ RCL EAX, # 1
DUP 065D1 = IF 3_GD_STEP EXIT THEN \ SHL [EBP], # 1
DUP 0C0C1 = IF 3_GD_STEP EXIT THEN \ ROL [EBP], # 1
DUP 45FF = IF 3_GD_STEP EXIT THEN \ INC 0 [EBP]
DUP 0310F = IF 2_GD_STEP EXIT THEN \ RDTSC
DUP 873B = IF CR ." cmp " ." eax," .EDI EXIT THEN \ CMP EAX, X [EDI]
DUP 878B = IF CR ." mov " ." eax," .EDI EXIT THEN \ MOV EAX, X [EDI]
DUP 8F8B = IF CR ." mov " ." ecx," .EDI EXIT THEN \ MOV ECX, X [EDI]
DUP 878D = IF CR ." lea " ." eax," .EDI EXIT THEN \ LEA EAX, X [EDI]
DUP 87FF = IF CR ." inc DWORD" .EDI EXIT THEN \ INC 19F9 [EDI]
DUP 8788 = IF CR ." mov al," .EDI EXIT THEN \ MOV 19F9 [EDI] , AL
DUP 8789 = IF CR ." mov " .EDI ." ,eax" EXIT THEN \ MOV X [EDI], EAX
DUP 8703 = IF CR ." add eax," .EDI EXIT THEN \ ADD EAX , X [EDI]
DUP 8733 = IF CR ." xor eax," .EDI EXIT THEN \ XOR EAX , X [EDI]
DUP 87C7 = IF CR ." mov " DROP DUP 6 + @
H. ." ," DUP @ .EDI 6 + EXIT THEN \ MOV X [EDI], # Y
DUP 45C7 = IF 3_GD_STEP .INT EXIT THEN \ MOV X [EBP], # X
DUP 3D83 = IF 2_GD_STEP .ADR DUP C@ 1_GD_STEP EXIT THEN \ MOV X [EBP], # X
DUP 0533 = IF 2_GD_STEP .ADR EXIT THEN \ XOR X [EBP], X
DUP 0503 = IF 2_GD_STEP .ADR EXIT THEN \ ADD EAX , X
DUP 1501 = IF 2_GD_STEP .ADR EXIT THEN \ ADD X , EDX
DUP 050B = IF 2_GD_STEP .ADR EXIT THEN \ OR EAX , X
DUP 0D3B = IF 2_GD_STEP .ADR EXIT THEN \ CMP ECX , x
DUP 2DF7 = IF 2_GD_STEP .ADR EXIT THEN \ IMUL x
DUP 808D = IF 2_GD_STEP .INT EXIT THEN \ LEA EAX , 8700 [EAX]
DUP 9A8D = IF 2_GD_STEP .INT EXIT THEN \ LEA EBX , 55C298 [EDX]
DUP 01C7 = IF 2_GD_STEP .INT EXIT THEN \ MOV [ECX] , # 424648D
DUP 0C0C7 = IF 2_GD_STEP .INT EXIT THEN \ MOV EAX, # X
DUP 0C1C7 = IF 2_GD_STEP .INT EXIT THEN \ MOV ECX, # X
DUP 0C069 = IF 2_GD_STEP .INT EXIT THEN \ IMUL EAX , EAX , # 4
DUP 0C3C7 = IF 2_GD_STEP .INT EXIT THEN \ MOV EBX, # X
DUP 05C7 = IF 2_GD_STEP .ADR .INT EXIT THEN \ MOV 5746E5 ( OPT?+5 ) , # FFFFFFFF
DUP6B?0 IF 6_GD_STEP0 EXIT THEN \ MOV EAX, # X
DUP6B?1 IF 6_GD_STEP1 EXIT THEN
DUP 00583 = IF 6_GD_STEP1
DUP C@ 1_GD_STEP EXIT THEN
DROP
DUP @ FFFFFF AND
DUP 021C8D = IF 3_GD_STEP EXIT THEN
DUP 240401 = IF 3_GD_STEP EXIT THEN \ ADD [ESP] , EAX
DUP C09D0F = IF 3_GD_STEP EXIT THEN \ SETGE AL
DUP C09E0F = IF 3_GD_STEP EXIT THEN \ SETLE AL
DUP 8D1C8D = IF 7_GD_STEP EXIT THEN \ LEA EBX, [ECX*4]
\ CMPXCHG [EAX] , AL| EAX
\ LSS EAX , [EAX]
\ BTR [EAX] , EAX
\ LFS EAX , [EAX]
\ LGS EAX , [EAX]
\ MOVZX EAX , BYTE|WORD PTR [EAX]
\ 0000.0000 1011.1XXX 0000.1111
DUP FFF8FF
AND 00B00F = IF 3_GD_STEP EXIT THEN
DUP 24442B = IF 4_GD_STEP EXIT THEN \ SUB EAX, X [ESP]
DUP 24648D = IF 4_GD_STEP EXIT THEN \ LEA ESP, X [ESP]
\ MOV|LEA EAX, X [E__] [E__*X]
\ MOV|LEA X [E__] [E__*X], EAX
\ POP X [E__] [E__*X]
\ XXXX.X1XX 0100.0100 1000.1XX1
DUP 04FFF9
AND 044489 = IF 4_GD_STEP EXIT THEN
DUP 035C8D = IF 4_GD_STEP EXIT THEN \ MOV EBX, X [EBX] [EAX]
DUP 03448B = IF 4_GD_STEP EXIT THEN \ MOV EAX, X [EBX] [EAX]
DUP 03B60F = IF 3_GD_STEP EXIT THEN \ MOVZX EAX, BYTE PTR [EBX]
DUP 18B60F = IF 3_GD_STEP EXIT THEN \ MOVZX EBX, BYTE PTR [EAX]
DUP 31348B = IF 3_GD_STEP EXIT THEN \ MOV ESI, [ESI+ECX]
DUP 40B60F = IF 4_GD_STEP EXIT THEN \ MOVZX EAX , BYTE PTR x [EAX]
DUP 345C8B = IF 4_GD_STEP EXIT THEN \ LEA EAX , [EAX] [ECX*4]
DUP 0E348B = IF 3_GD_STEP EXIT THEN \ MOV ESI, [ESI] [ECX]
DUP 03048D = IF 3_GD_STEP EXIT THEN \ LEA EAX, [EBX] [EAX]
DUP 355C89 = IF 4_GD_STEP EXIT THEN \ MOV EBX, [ESI+ESP-4]
DUP 30748B = IF 4_GD_STEP EXIT THEN \ MOV ESI, [1+ESI+EAX]
DUP 88048D = IF 3_GD_STEP EXIT THEN \ LEA EAX , [EAX] [ECX*4]
DUP 02048D = IF 3_GD_STEP EXIT THEN \ LEA EAX, [EDX] [EAX]
DUP 06748B = IF 4_GD_STEP EXIT THEN \ MOV ESI, 1 [ESI] [EAX]
DUP 245C8B = IF 4_GD_STEP EXIT THEN \ MOV EBX, 8 [ESP]
DUP 244C8B = IF 4_GD_STEP EXIT THEN \ MOV ECX, 8 [ESP]
DUP 2E5C89 = IF 4_GD_STEP EXIT THEN \ MOV -4 [ESI] [EBP], EBX
DUP 045C89 = IF 4_GD_STEP EXIT THEN \ MOV 4 [ESP] [EAX], EBX
DUP 2E74FF = IF 4_GD_STEP EXIT THEN \ PUSH -4 [ESI] [EBP]
DUP 3574FF = IF 4_GD_STEP EXIT THEN \ PUSH -4 [EBP] [ESI]
DUP 240CFF = IF 3_GD_STEP EXIT THEN \ DEC [ESP]
DUP 09B70F = IF 3_GD_STEP EXIT THEN \ MOVZX ECX , WORD PTR X [ECX]
DUP 40B70F = IF 4_GD_STEP EXIT THEN \ MOVZX EAX , WORD PTR X [EAX]
DUP 42B60F = IF 4_GD_STEP EXIT THEN \ MOVZX EAX , WORD PTR X [EDX]
DUP 24048B = IF 3_GD_STEP EXIT THEN \ MOV EAX, 0 [ESP]
DUP 240C8B = IF 3_GD_STEP EXIT THEN \ MOV ECX , [ESP]
DUP 1048B = IF 3_GD_STEP EXIT THEN \ MOV EAX , [ECX] [EAX]
DUP 01048D = IF 3_GD_STEP EXIT THEN \ LEA EAX , [ECX] [EAX]
DUP C0BE0F = IF 3_GD_STEP EXIT THEN \ MOV EAX, AL
DUP 0045C7 = IF 3_GD_STEP .INT EXIT THEN \ MOV 0 [EBP], # 0
DUP 240481 = IF 3_GD_STEP .INT EXIT THEN \ ADD [ESP] , # 4
DUP B5348D = IF 3_GD_STEP .INT EXIT THEN \ LEA ESI, [ESI*4]
DUP 8D0C8D = IF 3_GD_STEP .INT EXIT THEN \ LEA ECX, [ECX*4]
DUP 84248D = IF 3_GD_STEP EXIT THEN \ LEA ESP, [ESP] [EAX*4]
DUP 244C2B = IF 4_GD_STEP EXIT THEN \ SUB ECX , 4 [ESP]
DUP 04B60F = IF 4_GD_STEP EXIT THEN \ MOVZX EAX, BYTE [EDI] [ESI]
DUP 243C83 = IF 4_GD_STEP EXIT THEN \ CMP [ESP] , # 0
DUP7B? IF 7_GD_STEP EXIT THEN
DUP 2404FF = IF 3_GD_STEP EXIT THEN \ INC [ESP]
DUP 241C8B = IF 3_GD_STEP EXIT THEN \ MOV EBX, [ESP]
DUP 240403 = IF 3_GD_STEP EXIT THEN \ ADD EAX , [ESP]
DUP 87B60F = IF CR ." movzx eax,BYTE" DROP 1+ DUP .EDI EXIT THEN \ MOVZX EAX , BYTE PTR 19E3 [EDI]
CR H. TRUE ABORT" UNKNOWN CODE"
;
: GDIS ( A-limit A-init -- )
\ CR ." VV=" 2DUP H. H. 2DUP - .
BEGIN
\ H-STDOUT 1 TO H-STDOUT ." ." TO H-STDOUT
GD-STEP 2DUP U> 0=
UNTIL 2DROP ;
BASE !
\EOF
2DUP S" MOD" COMPARE 0= IF 2DROP ." _MOD" BREAK
2DUP S" DUP" COMPARE 0= IF 2DROP ." _DUP" BREAK
2DUP S" OR" COMPARE 0= IF 2DROP ." _OR" BREAK
2DUP S" XOR" COMPARE 0= IF 2DROP ." _XOR" BREAK
2DUP S" AND" COMPARE 0= IF 2DROP ." _AND" BREAK
2DUP S" CMOVE" COMPARE 0= IF 2DROP ." _CMOVE" BREAK
2DUP S" TYPE" COMPARE 0= IF 2DROP ." _TYPE" BREAK
2DUP S" ALIGN" COMPARE 0= IF 2DROP ." _ALIGN" BREAK
2DUP S" TITLE" COMPARE 0= IF 2DROP ." _TITLE" BREAK
2DUP S" LT" COMPARE 0= IF 2DROP ." _LT" BREAK
2DUP S" BL" COMPARE 0= IF 2DROP ." _BL" BREAK
2DUP S" DP" COMPARE 0= IF 2DROP ." _DP" BREAK
2DUP S" TRUE" COMPARE 0= IF 2DROP ." _TRUE" BREAK
2DUP S" FALSE" COMPARE 0= IF 2DROP ." _FALSE" BREAK
2DUP S" LOOP" COMPARE 0= IF 2DROP ." _LOOP" BREAK

13
programs/develop/SPForth/devel/~mak/do_want.f Normal file
View File

@ -0,0 +1,13 @@
WANT_BUFF COUNT SFIND [IF] DROP \EOF [THEN]
[WANT] WDS ~mak\wds.f
[WANT] SKIP : SKIP PSKIP ;
[WANT] PSKIP : PSKIP SKIP ;
[WANT] CASE ~mak\case.f
[WANT] [IF] ~mak/CompIF.f
[WANT] MS : MS 0 DO 100099 0 DO LOOP LOOP ;
[WANT] #define : #define HEADER ['] _CONSTANT-CODE COMPILE, 0 PARSE EVALUATE , ;
-321 THROW

25
programs/develop/SPForth/devel/~mak/lib/csr.f Normal file
View File

@ -0,0 +1,25 @@
[IFNDEF] CSP
VARIABLE CSP \ Указатель стека контроля
[THEN]
6 CONSTANT L-CAS# \ Допустимый уровень вложенности
CREATE S-CSP L-CAS# CELLS ALLOT \ Стек контроля
S-CSP CSP !
: +CSP ( -> P) \ Добавить уровень
CSP @ DUP CELL+ CSP !
;
: -CSP ( -> ) \ Убрать уровень
CSP @ 1 CELLS - CSP !
;
: !CSP ( -> ) \ Инициализировать уровень
SP@ +CSP !
;
: CSP@ ( -> A)
CSP @ 1 CELLS - @
;
: ?CSP ( -> ) \ Проверить выдержанность стека
SP@ CSP@ <> 37 ?ERROR ( ABORT" Сбой стека по CSP !")
-CSP
;

39
programs/develop/SPForth/devel/~mak/lib/locals-ans2.f Normal file
View File

@ -0,0 +1,39 @@
\ $Id: locals-ans.f,v 1.2 2003/01/10 16:44:16 anfilat Exp $
\ Work in spf3, spf4
\ LOCALS ñòàíäàðòà 94.
\ Îáúÿâëåíèå -
\ LOCALS| n1 n2 n3 |
REQUIRE { ~mak/lib/locals4.f
GET-CURRENT ALSO vocLocalsSupport_M DEFINITIONS
: CompileANSLocInit
uPrevCurrent @ SET-CURRENT
uLocalsUCnt @ ?DUP
IF NEGATE CELLS R_ALLOT,
THEN
uLocalsCnt @ uLocalsUCnt @ - ?DUP
IF DUP CELLS NEGATE uAddDepth +!
DUP 0
DO uLocalsCnt @ uLocalsUCnt @ - I - 1-
LIT, S" PICK >R " EVALUATE LOOP
0 DO POSTPONE DROP LOOP
THEN
;;
SET-CURRENT
: LOCALS|
LocalsStartup
BEGIN
BL PSKIP PeekChar
[CHAR] | <>
WHILE
CREATE LocalsDoes@ IMMEDIATE
REPEAT
[CHAR] | PARSE 2DROP
CompileANSLocInit
;; IMMEDIATE
PREVIOUS

401
programs/develop/SPForth/devel/~mak/lib/locals4.f Normal file
View File

@ -0,0 +1,401 @@
( 28.Mar.2000 Andrey Cherezov Copyright [C] RU FIG
ˆá¯®«ì§®¢ ­ë ¨¤¥¨ á«¥¤ãîé¨å  ¢â®à®¢:
Ruvim Pinka; Dmitry Yakimov; Oleg Shalyopa; Yuriy Zhilovets;
Konstantin Tarasov; Michail Maximov.
!! <EFBFBD> ¡®â ¥â ⮫쪮 ¢ SPF4.
)
( <20>à®á⮥ à áè¨à¥­¨¥ ‘<>-”®àâ  «®ª «ì­ë¬¨ ¯¥à¥¬¥­­ë¬¨.
<20>¥ «¨§®¢ ­® ¡¥§ ¨á¯®«ì§®¢ ­¨ï LOCALS áâ ­¤ àâ  94.
Ž¡ê¥­¨¥ ¢à¥¬¥­­ëå ¯¥à¥¬¥­­ëå, ¢¨¤¨¬ëå ⮫쪮 ¢­ãâà¨
⥪ã饣® á«®¢  ¨ ®£à ­¨ç¥­­ëå ¢à¥¬¥­¥¬ ¢ë§®¢  ¤ ­­®£®
á«®¢  ¢ë¯®«­ï¥âáï á ¯®¬®éìî á«®¢  "{". ‚­ãâਠ®¯à¥¤¥«¥­¨ï
á«®¢  ¨á¯®«ì§ã¥âáï ª®­áâàãªæ¨ï, ¯®¤®¡­ ï á⥪®¢®© ­®â æ¨¨ ”®àâ 
{ ᯨ᮪_¨­¨æ¨ «¨§¨à®¢ ­­ëå_«®ª «®¢ \ á¯.­¥¨­¨æ.«®ª «®¢ -- ç⮠㣮¤­® }
<20> ¯à¨¬¥à:
{ a b c d \ e f -- i j }
ˆ«¨ { a b c d \ e f[ EVALUATE_¢ëà ¦¥­¨¥ ] -- i j }
<20>â® §­ ç¨â çâ® ¤«ï ¯¥à¥¬¥­­®© f[ ¡ã¤¥â ¢ë¤¥«¥­ ­  á⥪¥ ¢®§¢à â®¢ ãç á⮪
¯ ¬ï⨠¤«¨­®© n ¡ ©â. ˆá¯®«ì§®¢ ­¨¥ ¯¥à¥¬¥­­®© f[ ¤ áâ  ¤à¥á ­ ç «  í⮣®
ãç á⪠. \‚ á⨫¥ MPE\
ˆ«¨ { a b c d \ e [ 12 ] f -- i j }
<20>â® §­ ç¨â çâ® ¤«ï ¯¥à¥¬¥­­®© f ¡ã¤¥â ¢ë¤¥«¥­ ­  á⥪¥ ¢®§¢à â®¢ ãç á⮪
¯ ¬ï⨠¤«¨­®© 12 ¡ ©â. ˆá¯®«ì§®¢ ­¨¥ ¯¥à¥¬¥­­®© f ¤ áâ  ¤à¥á ­ ç «  í⮣®
ãç á⪠.
— áâì "\ á¯.­¥¨­¨æ.«®ª «®¢" ¬®¦¥â ®âáãâá⢮¢ âì, ­ ¯à¨¬¥à:
{ item1 item2 -- }
<20>â® § áâ ¢«ï¥â ‘<EFBFBD>-”®àâ  ¢â®¬ â¨ç¥áª¨ ¢ë¤¥«ïâì ¬¥áâ® ¢
á⥪¥ ¢®§¢à â®¢ ¤«ï íâ¨å ¯¥à¥¬¥­­ëå ¢ ¬®¬¥­â ¢ë§®¢  á«®¢ 
¨  ¢â®¬ â¨ç¥áª¨ ®á¢®¡®¦¤ âì ¬¥áâ® ¯à¨ ¢ë室¥ ¨§ ­¥£®.
Ž¡à é¥­¨¥ ª â ª¨¬ «®ª «ì­ë¬ ¯¥à¥¬¥­­ë¬ - ª ª ª VALUE-¯¥à¥¬¥­­ë¬
¯® ¨¬¥­¨. …᫨ ­ã¦¥­  ¤à¥á ¯¥à¥¬¥­­®©, â® ¨á¯®«ì§ã¥âáï "^ ¨¬ï"
¨«¨ "AT ¨¬ï".
‚¬¥áâ® \ ¬®¦­® ¨á¯®«ì§®¢ âì |
‚¬¥áâ® -> ¬®¦­® ¨á¯®«ì§®¢ âì TO
<20>ਬ¥àë:
: TEST { a b c d \ e f -- } a . b . c . b c + -> e e . f . ^ a @ . ;
Ok
1 2 3 4 TEST
1 2 3 5 0 1 Ok
: TEST { a b -- } a . b . CR 5 0 DO I . a . b . CR LOOP ;
Ok
12 34 TEST
12 34
0 12 34
1 12 34
2 12 34
3 12 34
4 12 34
Ok
: TEST { a b } a . b . ;
Ok
1 2 TEST
1 2 Ok
: TEST { a b \ c } a . b . c . ;
Ok
1 2 TEST
1 2 0 Ok
: TEST { a b -- } a . b . ;
Ok
1 2 TEST
1 2 Ok
: TEST { a b \ c -- d } a . b . c . ;
Ok
1 2 TEST
1 2 0 Ok
: TEST { \ a b } a . b . 1 -> a 2 -> b a . b . ;
Ok
TEST
0 0 1 2 Ok
ˆ¬¥­  «®ª «ì­ëå ¯¥à¥¬¥­­ëå áãé¥áâ¢ãîâ ¢ ¤¨­ ¬¨ç¥áª®¬
¢à¥¬¥­­®¬ á«®¢ à¥ ⮫쪮 ¢ ¬®¬¥­â ª®¬¯¨«ï樨 á«®¢ ,  
¯®á«¥ í⮣® ¢ëç¨é îâáï ¨ ¡®«¥¥ ­¥¤®áâ㯭ë.
ˆá¯®«ì§®¢ âì ª®­áâàãªæ¨î "{ ... }" ¢­ãâਠ®¤­®£® ®¯à¥¤¥«¥­¨ï ¬®¦­®
⮫쪮 ®¤¨­ à §.
Š®¬¯¨«ïæ¨ï í⮩ ¡¨¡«¨®â¥ª¨ ¤®¡ ¢«ï¥â ¢ ⥪ã騩 á«®¢ àì ª®¬¯¨«ï樨
’®«ìª® ¤¢  á«®¢ :
á«®¢ àì "vocLocalsSupport" ¨ "{"
‚ᥠ®áâ «ì­ë¥ ¤¥â «¨ "á¯àïâ ­ë" ¢ á«®¢ à¥, ¨á¯®«ì§®¢ âì ¨å
­¥ ४®¬¥­¤ã¥âáï.
)
REQUIRE [IF] ~MAK\CompIF.f
C" 'DROP_V" FIND NIP 0=
[IF] ' DROP VALUE 'DROP_V
: 'DROP 'DROP_V ;
[THEN]
C" 'DUP_V" FIND NIP 0=
[IF] ' DUP VALUE 'DUP_V
: 'DUP 'DUP_V ;
[THEN]
C" 'DROP" FIND NIP 0=
[IF] ' DROP VALUE 'DROP
[THEN]
C" 'DUP" FIND NIP 0=
[IF] ' DUP VALUE 'DUP
[THEN]
\ C" '(LocalsExit)_V" FIND NIP 0=
\ [IF] ' (LocalsExit)_V VALUE '(LocalsExit)_V
\ [THEN]
MODULE: vocLocalsSupport_M
VARIABLE uLocalsCnt
VARIABLE uLocalsUCnt
VARIABLE uPrevCurrent
VARIABLE uAddDepth
: LocalOffs ( n -- offs )
2+ CELLS uAddDepth @ +
;
BASE @ HEX
' RP@ 7 + @ 0xC3042444 =
[IF]
: R_ALLOT,
DUP SHORT?
OPT_INIT SetOP
IF 8D C, 64 C, 24 C, C, \ mov esp, offset [esp]
ELSE 8D C, A4 C, 24 C, , \ mov esp, offset [esp]
THEN
OPT_CLOSE
;
C" MACRO," FIND NIP 0=
[IF] : MACRO, INLINE, ;
[THEN]
: CompileLocalRec ( u -- )
LocalOffs DUP
'DUP MACRO,
SHORT?
OPT_INIT SetOP
IF 8D C, 44 C, 24 C, C, \ lea eax, offset [esp]
ELSE 8D C, 84 C, 24 C, , \ lea eax, offset [esp]
THEN OPT
OPT_CLOSE
;
: CompileLocal@ ( n -- )
'DUP MACRO,
LocalOffs DUP SHORT?
OPT_INIT SetOP
IF 8B C, 44 C, 24 C, C, \ mov eax, offset [esp]
ELSE 8B C, 84 C, 24 C, , \ mov eax, offset [esp]
THEN OPT
OPT_CLOSE
;
: CompileLocal! ( n -- )
LocalOffs DUP SHORT?
OPT_INIT SetOP
IF 89 C, 44 C, 24 C, C, \ mov offset [esp], eax
ELSE 89 C, 84 C, 24 C, , \ mov offset [esp], eax
THEN OPT
OPT_CLOSE
'DROP MACRO,
;
\ : CompileLocal@ ( n -- )
\ LocalOffs LIT, POSTPONE RP+@
\ ;
[ELSE]
: R_ALLOT,
] POSTPONE LITERAL S" RP@ + RP! " EVALUATE
POSTPONE [ ;
: CompileLocalRec ( u -- )
LocalOffs
POSTPONE LITERAL
\ S" RP@ + " EVALUATE
;
: CompileLocal@ ( n -- )
CompileLocalRec
S" @ " EVALUATE
;
: CompileLocal! ( n -- )
CompileLocalRec
S" ! " EVALUATE
;
[THEN]
VARIABLE TEMP-DP
: CompileLocalsInit
TEMP-DP @ DP !
uPrevCurrent @ SET-CURRENT
uLocalsUCnt @ ?DUP
IF NEGATE CELLS R_ALLOT,
THEN
uLocalsCnt @ uLocalsUCnt @ - ?DUP
IF DUP CELLS NEGATE uAddDepth +! 0 DO S" >R " EVALUATE LOOP THEN
uLocalsCnt @ ?DUP
IF CELLS POSTPONE LITERAL S" >R ['] (LocalsExit) >R" EVALUATE
-2 CELLS uAddDepth +!
THEN
;
\ : CompileLocal@ ( n -- )
\ LocalOffs LIT, POSTPONE RP+@
\ ;
BASE !
WORDLIST CONSTANT widLocals@
CREATE TEMP-BUF 1000 ALLOT
: LocalsStartup
GET-CURRENT uPrevCurrent !
ALSO vocLocalsSupport_M
ALSO widLocals@ CONTEXT ! DEFINITIONS
HERE TEMP-DP !
TEMP-BUF DP !
widLocals@ 0!
uLocalsCnt 0!
uLocalsUCnt 0!
uAddDepth 0!
;
: LocalsCleanup
PREVIOUS PREVIOUS
;
: ProcessLocRec ( "name" -- u )
[CHAR] ] PARSE
STATE 0!
EVALUATE CELL 1- + CELL / \ ¤¥« ¥¬ ªà â­ë¬ 4
-1 STATE !
\ DUP uLocalsCnt +!
uLocalsCnt @
;
: CreateLocArray
[CHAR] [ PSKIP
ProcessLocRec
CREATE ,
DUP uLocalsCnt +!
;
: LocalsRecDoes@ ( -- u )
DOES> @ CompileLocalRec
;
: LocalsRecDoes@2 ( -- u )
ProcessLocRec ,
DUP uLocalsCnt +!
DOES> @ CompileLocalRec
;
: LocalsDoes@
uLocalsCnt @ ,
uLocalsCnt 1+!
DOES> @ CompileLocal@
;
: ;; POSTPONE ; ; IMMEDIATE
: ^
' >BODY @
CompileLocalRec
; IMMEDIATE
: -> ' >BODY @ CompileLocal! ; IMMEDIATE
WARNING DUP @ SWAP 0!
: AT
[COMPILE] ^
; IMMEDIATE
: TO ( "name" -- )
>IN @ NextWord widLocals@ SEARCH-WORDLIST 1 =
IF >BODY @ CompileLocal! DROP
ELSE >IN ! [COMPILE] TO
THEN
; IMMEDIATE
WARNING !
: ¢ POSTPONE -> ; IMMEDIATE
WARNING @ WARNING 0!
\ ===
\ ¯¥à¥®¯à¥¤¥«¥­¨¥ ᮮ⢥âáâ¢ãîé¨å á«®¢ ¤«ï ¢®§¬®¦­®á⨠¨á¯®«ì§®¢ âì
\ ¢à¥¬¥­­ë¥ ¯¥à¥¬¥­­ë¥ ¢­ãâਠ横«  DO LOOP ¨ ­¥§ ¢¨á¨¬® ®â ¨§¬¥­¥­¨ï
\ ᮤ¥à¦¨¬®£® á⥪  ¢®§¢à â®¢ á«®¢ ¬¨ >R R>
C" DO_SIZE" FIND NIP 0=
[IF] 3 CELLS CONSTANT DO_SIZE
[THEN]
: DO POSTPONE DO DO_SIZE uAddDepth +! ; IMMEDIATE
: ?DO POSTPONE ?DO DO_SIZE uAddDepth +! ; IMMEDIATE
: LOOP POSTPONE LOOP DO_SIZE NEGATE uAddDepth +! ; IMMEDIATE
: +LOOP POSTPONE +LOOP DO_SIZE NEGATE uAddDepth +! ; IMMEDIATE
: >R POSTPONE >R [ 1 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: R> POSTPONE R> [ -1 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: RDROP POSTPONE RDROP [ -1 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: 2>R POSTPONE 2>R [ 2 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: 2R> POSTPONE 2R> [ -2 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
\ ===
\ uLocalsCnt @ ?DUP
\ IF CELLS RLIT, ['] (LocalsExit) RLIT, THEN
: ; LocalsCleanup
S" ;" EVAL-WORD
; IMMEDIATE
WARNING !
\ =====================================================================
EXPORT
: {
LocalsStartup
BEGIN
BL PSKIP PeekChar DUP [CHAR] \ <>
OVER [CHAR] - <> AND
OVER [CHAR] } <> AND
OVER [CHAR] | <> AND
SWAP [CHAR] ) XOR AND
WHILE
CREATE LocalsDoes@ IMMEDIATE
REPEAT
PeekChar >IN 1+! DUP [CHAR] } <>
IF
DUP [CHAR] \ =
SWAP [CHAR] | = OR
IF
BEGIN
BL PSKIP PeekChar DUP
DUP [CHAR] - <>
SWAP [CHAR] } <> AND
SWAP [CHAR] ) XOR AND
WHILE
PeekChar [CHAR] [ =
IF CreateLocArray LocalsRecDoes@
ELSE
CREATE LATEST DUP C@ + C@
[CHAR] [ =
IF
LocalsRecDoes@2
ELSE
LocalsDoes@ 1
THEN
THEN DUP U.
uLocalsUCnt +!
IMMEDIATE
REPEAT
THEN
[CHAR] } PARSE 2DROP
ELSE DROP THEN
CompileLocalsInit
;; IMMEDIATE
;MODULE

35
programs/develop/SPForth/devel/~mak/lib/map.f Normal file
View File

@ -0,0 +1,35 @@
\ ~mak/want.f WANT #define
0 VALUE M#define-CODE
: M#define CREATE PARSE-WORD EVALUATE ,
DOES> [ HERE 5 - TO M#define-CODE ] @ ;
: Archive_
PARSE-WORD EVALUATE
' DUP 1+ REL@ CELL+ M#define-CODE =
IF
>BODY ! EXIT
THEN 1 THROW ;
: Archive \ F7_ED
BEGIN
PARSE-WORD DUP 0=
IF NIP REFILL 0= IF DROP TRUE THEN
ELSE S" size" COMPARE 0= THEN
UNTIL
REFILL DROP
BEGIN REFILL 0= IF \EOF EXIT THEN
SOURCE NIP
WHILE M#define
REPEAT
BEGIN REFILL
WHILE SOURCE NIP 40 >
IF
['] Archive_ CATCH DROP
THEN
REPEAT POSTPONE \
;

15
programs/develop/SPForth/devel/~mak/lib/vt/colors.f Normal file
View File

@ -0,0 +1,15 @@
: (ESC) 27 EMIT TYPE ;
: CLEAR S" [2J" (ESC) ; : HOME CLEAR S" [1;1H" (ESC) ;
: NORMAL S" [0m" (ESC) ; : BOLD S" [1m" (ESC) ;
: BLACK S" [30m" (ESC) ; : RED S" [31m" (ESC) ;
: GREEN S" [32m" (ESC) ; : YELLOW S" [33m" (ESC) ;
: BLUE S" [34m" (ESC) ; : MAGENTA S" [35m" (ESC) ;
: CYAN S" [36m" (ESC) ; : WHITE S" [37m" (ESC) ;
: ONBLACK S" [40m" (ESC) ; : ONRED S" [41m" (ESC) ;
: ONGREEN S" [42m" (ESC) ; : ONYELLOW S" [43m" (ESC) ;
: ONBLUE S" [44m" (ESC) ; : ONMAGENTA S" [45m" (ESC) ;
: ONCYAN S" [46m" (ESC) ; : ONWHITE S" [47m" (ESC) ;

161
programs/develop/SPForth/devel/~mak/listing3.f Normal file
View File

@ -0,0 +1,161 @@
REQUIRE PLACE ~mak/place.f
REQUIRE [IF] ~mak/CompIF.f
REQUIRE DISASSEMBLER lib/ext/disasm.f
C" STREAM-FILE" FIND NIP
[IF]
: FROM_SOURCE-ID SOURCE-ID STREAM-FILE ;
: TO_SOURCE-ID FILE>RSTREAM TO SOURCE-ID ;
[ELSE]
: FROM_SOURCE-ID SOURCE-ID ;
: TO_SOURCE-ID TO SOURCE-ID ;
[THEN]
: INST [ ALSO DISASSEMBLER ] INST
[ PREVIOUS ] ;
C" -CELL" FIND NIP 0=
[IF] -1 CELLS CONSTANT -CELL
[THEN]
CREATE FILE_NAME_L 120 ALLOT
CREATE HERE-TAB 5000 CELLS ALLOT
HERE CELL- CONSTANT HERE-TAB-MAX
VARIABLE HERE-TAB-CUR
HERE-TAB HERE-TAB-CUR !
VARIABLE S_STATE
: HERE-TAB-CUR+
HERE-TAB-CUR @ CELL+ HERE-TAB-MAX UMIN
HERE-TAB-CUR
!
\ [ .( XXXX) DIS-OPT KEY DROP ]
;
: HERE-TO-TAB DP @ HERE-TAB-CUR @ ! HERE-TAB-CUR+ ;
CREATE SHERE-TAB 800 CELLS ALLOT
HERE CELL- CONSTANT SHERE-TAB-MAX
VARIABLE SHERE-TAB-CUR
SHERE-TAB SHERE-TAB-CUR !
: SHERE-TAB-CUR+
SHERE-TAB-CUR @ CELL+ SHERE-TAB-MAX UMIN
SHERE-TAB-CUR ! ;
: SHERE-TO-TAB DP @ SHERE-TAB-CUR @ ! SHERE-TAB-CUR+ ;
80 VALUE DUMP_MAX
: MDUMP ( addr u -- )
DUP 0= IF 2DROP EXIT THEN
BASE @ >R HEX
BEGIN
CR OVER BASE-ADDR - 4 .0 SPACE
2DUP 0x10 MIN
2DUP 0 DO I 4 MOD 0= IF SPACE THEN
DUP C@ 2 .0 SPACE 1+
LOOP DROP
DUP >R PTYPE
R@ - SWAP R> + SWAP DUP 0=
UNTIL 2DROP
R> BASE ! CR
;
: .LIST ( ADDR ADDR1 -- ADDR1' )
S_STATE @
IF
SWAP
BEGIN 2DUP U>
WHILE INST CR
REPEAT NIP
ELSE
TUCK
OVER - DUP
IF DUP DUMP_MAX U>
IF >R DUMP_MAX DUMP
CR DUP U. R> DUMP_MAX - U. ." bytes"
ELSE MDUMP
THEN CR
ELSE 2DROP
THEN
THEN
;
VECT INCLUDED$
' INCLUDED TO INCLUDED$
: INCLUDED_L
['] <PRE> >BODY @ >R
['] HERE-TO-TAB TO <PRE>
HERE-TAB HERE-TAB-CUR !
SHERE-TAB SHERE-TAB-CUR !
2DUP 2>R INCLUDED$ 2R> R> TO <PRE>
-1 SHERE-TAB-CUR @ ! SHERE-TAB-CUR+
HERE-TO-TAB
HERE-TO-TAB -CELL HERE-TAB-CUR +!
HERE-TAB-CUR @ @ -CELL HERE-TAB-CUR +!
BEGIN HERE-TAB-CUR @ HERE-TAB <>
WHILE HERE-TAB-CUR @ @ UMIN DUP HERE-TAB-CUR @ !
-CELL HERE-TAB-CUR +!
REPEAT DROP
S_STATE 0!
SHERE-TAB SHERE-TAB-CUR !
2DUP FILE_NAME_L PLACE
S" _L" FILE_NAME_L +PLACE
R/O OPEN-FILE THROW
FILE_NAME_L COUNT 2DUP + 0!
W/O CREATE-FILE THROW
TIB >R >IN @ >R #TIB @ >R SOURCE-ID >R BLK @ >R CURSTR @ >R
H-STDOUT >R BASE @ >R HEX
C/L 2 + ALLOCATE THROW TO TIB BLK 0!
TO H-STDOUT
." ZZ=" DUP .
TO_SOURCE-ID
CURSTR 0! HERE-TAB-CUR @ @
BEGIN REFILL
WHILE
SOURCE TYPE CR
BEGIN SHERE-TAB-CUR @ @ HERE-TAB-CUR @ CELL+ @ U<
WHILE SHERE-TAB-CUR @ @ .LIST SHERE-TAB-CUR+
S_STATE @ INVERT S_STATE !
REPEAT HERE-TAB-CUR+ HERE-TAB-CUR @ @ .LIST
REPEAT DROP
TIB FREE THROW
FROM_SOURCE-ID
." ZZ=" DUP .
CLOSE-FILE THROW ( îøèáêà çàêðûòèÿ ôàéëà )
H-STDOUT CLOSE-FILE THROW ( îøèáêà çàêðûòèÿ ôàéëà )
R> BASE ! R> TO H-STDOUT
R> CURSTR ! R> BLK ! R> TO SOURCE-ID R> #TIB ! R> >IN ! R> TO TIB
;
: REQUIRED_L ( waddr wu laddr lu -- )
2SWAP SFIND
IF DROP 2DROP EXIT
ELSE 2DROP INCLUDED_L THEN
;
[UNDEFINED] PSKIP [IF]
: PSKIP SKIP ;
[THEN]
: REQUIRE_L ( "word" "libpath" -- )
BL PSKIP BL PARSE
BL PSKIP BL PARSE 2DUP + 0 SWAP C!
REQUIRED_L
;
: : : SHERE-TO-TAB ;
: ; POSTPONE ; SHERE-TO-TAB ; IMMEDIATE
: SSSS
HERE-TAB HERE-TAB-CUR !
SHERE-TAB SHERE-TAB-CUR !
;

198
programs/develop/SPForth/devel/~mak/temps4.f Normal file
View File

@ -0,0 +1,198 @@
\ Temporary variables
( 24.09.1997 —¥à¥§®¢ €. )
\ April 12th, 2000 - 14:44 Mihail Maksimov
\ ¤®¡ ¢¨« ª®­áâàãªæ¨¨ !! ... !! ¨ >| ... | , «¨ª¢¨¤¨à®¢ « |DOES
\ ®¯â¨¬¨§¨à®¢ ­­ë© ¢ à¨ ­â. ¯¥à¥¬¥­­ë¥ ¬®¦­® ¨á¯®«ì§®¢ âì ¨ ¢­ãâਠDO LOOP
( 10.06.1999 Ruvim Pinka, idea - Mihail Maksimov )
( <20>à®á⮥ à áè¨à¥­¨¥ ‘<>-”®àâ  «®ª «ì­ë¬¨ ¯¥à¥¬¥­­ë¬¨.
<20>¥ «¨§®¢ ­® ¡¥§ ¨á¯®«ì§®¢ ­¨ï LOCALS áâ ­¤ àâ  94.
Ž¡ê¥­¨¥ ¢à¥¬¥­­ëå ¯¥à¥¬¥­­ëå, ¢¨¤¨¬ëå ⮫쪮 ¢­ãâà¨
⥪ã饣® á«®¢  ¨ ®£à ­¨ç¥­­ëå ¢à¥¬¥­¥¬ ¢ë§®¢  ¤ ­­®£®
á«®¢  ¢ë¯®«­ï¥âáï á ¯®¬®éìî á«®¢  "|"  ­ «®£¨ç­®
‘¬®«â®«ªã: ¢­ãâਠ®¯à¥¤¥«¥­¨ï á«®¢  ¨á¯®«ì§ã¥âáï
ª®­áâàãªæ¨ï
| ᯨ᮪ «®ª «ì­ëå ¯¥à¥¬¥­­ëå ç¥à¥§ ¯à®¡¥« |
<20>â® § áâ ¢«ï¥â ‘<EFBFBD>-”®àâ  ¢â®¬ â¨ç¥áª¨ ¢ë¤¥«ïâì ¬¥áâ® ¢
á⥪¥ ¢®§¢à â®¢ ¤«ï íâ¨å ¯¥à¥¬¥­­ëå ¢ ¬®¬¥­â ¢ë§®¢  á«®¢ 
¨  ¢â®¬ â¨ç¥áª¨ ®á¢®¡®¦¤ âì ¬¥áâ® ¯à¨ ¢ë室¥ ¨§ ­¥£®.
Ž¡à é¥­¨¥ ª â ª¨¬ «®ª «ì­ë¬ ¯¥à¥¬¥­­ë¬ - ª ª ª ®¡ëç­ë¬
¯¥à¥¬¥­­ë¬ ¯® ¨¬¥­¨ ¨ á«¥¤ãî騬¨ @ ¨ !
ˆ¬¥­  «®ª «ì­ëå ¯¥à¥¬¥­­ëå áãé¥áâ¢ãîâ ¢ ¤¨­ ¬¨ç¥áª®¬
á«®¢ à¥ TEMP-NAMES ⮫쪮 ¢ ¬®¬¥­â ª®¬¯¨«ï樨 á«®¢ ,  
¯®á«¥ í⮣® ¢ëç¨é îâáï ¨ ¡®«¥¥ ­¥¤®áâ㯭ë.
)
\ ˆ­¨æ¨ «¨§ æ¨ï ¢à¥¬¥­­ëå ¯¥à¥¬¥­­ëå §­ ç¥­¨ï¬¨, «¥¦ é¨¬¨ ­ 
\ á⥪¥ (­ ¯à¨¬¥à, ¢å®¤­ë¬¨ ¯ à ¬¥âà ¬¨), ¢®§¬®¦­  "ᯨ᪮¬"
\ á ¯®¬®éìî ª®­áâàãªæ¨¨
\ (( ¨¬¥­  ¨­¨æ¨ «¨§¨à㥬ëå «®ª «ì­ëå ¯¥à¥¬¥­­ëå ))
\ ˆ¬¥­  ¤®«¦­ë ¡ëâì à ­¥¥ ®¡ê¥­ë ¢ á«®¢¥ á ¯®¬®éìî | ... |
( ˆá¯®«ì§®¢ ­¨¥ «®ª «ì­ëå ¯¥à¥¬¥­­ëå ¢­ãâਠ横«®¢ DO LOOP
­¥¢®§¬®¦­® ¯® ¯à¨ç¨­¥, ®¯¨á ­­®© ¢ áâ ­¤ à⥠94.
<20>ਠ¦¥« ­¨¨ ¨á¯®«ì§®¢ âì «®ª «ì­ë¥ ¯¥à¥¬¥­­ë¥ ¢ á⨫¥ VALUE-¯¥à¥¬¥­­ëå
¬®¦­® ¨á¯®«ì§®¢ âì ª®­áâàãªæ¨î
|| ᯨ᮪ «®ª «ì­ëå ¯¥à¥¬¥­­ëå ç¥à¥§ ¯à®¡¥« ||
ˆ¬¥­  íâ¨å ¯¥à¥¬¥­­ëå ¡ã¤ãâ ¤ ¢ âì ­¥  ¤à¥á,   ᢮¥ §­ ç¥­¨¥.
‘®®â¢¥âá⢥­­® ¯à¨á¢®¥­¨¥ §­ ç¥­¨© ¡ã¤¥â ®áãé¥á⢫ïâìáï ª®­áâàãªæ¨¥©
-> ¨¬ï
¯®  ­ «®£¨¨ á ¯à¨á¢®¥­¨¥¬ §­ ç¥­¨© VALUE-¯¥à¥¬¥­­ë¬ á«®¢®¬ TO.
)
VARIABLE TEMP-CNT
WORDLIST CONSTANT TEMP-NAMES
: INIT-TEMP-NAMES
ALSO TEMP-NAMES CONTEXT !
TEMP-CNT 0!
;
: DEL-NAMES ( A -- )
DUP>R
@
BEGIN
DUP 0<>
WHILE
DUP CDR SWAP 5 - FREE THROW
REPEAT DROP
R> 0!
;
: DEL-TEMP-NAMES
TEMP-NAMES DEL-NAMES
;
HEX
: COMPIL, ( A -- )
0E8 DOES>A @ C! DOES>A 1+! \ ¬ è¨­­ ï ª®¬ ­¤  CALL
DOES>A @ CELL+ - DOES>A @ !
DOES>A @ 1- DOES>A !
;
DECIMAL
C" LAST-HERE" FIND NIP
[IF]
: TEMP-DOES ( N -- ) ( -- ADDR )
['] DUP MACRO,
0x8D C, 0x44 C, 0x24 C, C, \ LEA EAX , X [ESP]
HERE TO LAST-HERE \ à §à¥è¥­® ®¯â¨¬¨§¨à®¢ âì
;
[ELSE]
: TEMP-DOES ( N -- ) ( -- ADDR )
POSTPONE RP@ LIT, POSTPONE + ;
[THEN]
: |TEMP-DOES ( N -- ) ( -- VALUE )
TEMP-DOES ['] @ COMPILE,
;
: |TEMP-DOES! ( N -- ) ( X -- )
TEMP-DOES ['] ! COMPILE,
;
VARIABLE add_depth add_depth 0!
\ £«ã¡¨­  ¢ á⥪¥ ¢®§¢à â®¢ ¤® ­ ç «  ¯¥à¥¬¥­­ëå
: !TEMP-CREATE ( addr u -- )
DUP 20 + ALLOCATE THROW >R
R@ CELL+ CHAR+ 2DUP C!
CHAR+ SWAP MOVE ( name )
TEMP-NAMES @
R@ CELL+ CHAR+ TEMP-NAMES ! ( latest )
R@ CELL+ CHAR+ COUNT + DUP>R ! ( link )
R> CELL+ DUP DOES>A ! R@ ! ( cfa )
&IMMEDIATE R> CELL+ C! ( flags )
['] _CREATE-CODE COMPIL,
TEMP-CNT @ DOES>A @ 5 + !
TEMP-CNT 1+!
POSTPONE >R DOES> @ 2 + CELLS add_depth @ + |TEMP-DOES ;
: TEMP-CREATE ( addr u -- )
!TEMP-CREATE DOES> @ 2 + CELLS add_depth @ + TEMP-DOES ;
: -> ' 5 + @ 2 + CELLS add_depth @ + |TEMP-DOES!
; IMMEDIATE
: |DROP R> RP@ + RP! ;
' |DROP VALUE '|DROP
: !!!!; ( N N1 -- )
DROP TEMP-CNT @ CELLS LIT, POSTPONE >R
DROP '|DROP LIT, POSTPONE >R ;
: !!
BEGIN NextWord 2DUP S" !!" COMPARE 0<>
WHILE !TEMP-CREATE
REPEAT !!!!; ; IMMEDIATE
: ||
BEGIN NextWord 2DUP S" ||" COMPARE 0<>
WHILE 0 LIT, !TEMP-CREATE
REPEAT !!!!; ; IMMEDIATE
: |
BEGIN NextWord 2DUP S" |" COMPARE 0<>
WHILE 0 LIT, TEMP-CREATE
REPEAT !!!!; ; IMMEDIATE
: >|
BEGIN NextWord 2DUP S" |" COMPARE 0<>
WHILE TEMP-CREATE
REPEAT !!!!; ; IMMEDIATE
: ((
0
BEGIN
BL WORD DUP COUNT S" ))" COMPARE 0<>
WHILE
FIND IF >R 1+ ELSE 5012 THROW THEN
REPEAT DROP
BEGIN
DUP 0<>
WHILE
\ R> EXECUTE POSTPONE ! ( ¨á¯à ¢«¥­® ¤«ï ¯®¤¤¥à¦ª¨ || )
R> 5 + @ 2 + CELLS add_depth @ +
|TEMP-DOES!
1-
REPEAT DROP
; IMMEDIATE
\ ===
\ ¯¥à¥®¯à¥¤¥«¥­¨¥ ᮮ⢥âáâ¢ãîé¨å á«®¢ ¤«ï ¢®§¬®¦­®á⨠¨á¯®«ì§®¢ âì
\ ¢à¥¬¥­­ë¥ ¯¥à¥¬¥­­ë¥ ¢­ãâਠ横«  DO LOOP ¨ ­¥§ ¢¨á¨¬® ®â ¨§¬¥­¥­¨ï
\ ᮤ¥à¦¨¬®£® á⥪  ¢®§¢à â®¢ á«®¢ ¬¨ >R R>
: DO POSTPONE DO [ 3 CELLS ] LITERAL add_depth +!
; IMMEDIATE
: LOOP POSTPONE LOOP [ -3 CELLS ] LITERAL add_depth +!
; IMMEDIATE
: +LOOP POSTPONE +LOOP [ -3 CELLS ] LITERAL add_depth +!
; IMMEDIATE
: >R POSTPONE >R [ 1 CELLS ] LITERAL add_depth +!
; IMMEDIATE
: R> POSTPONE R> [ -1 CELLS ] LITERAL add_depth +!
; IMMEDIATE
\ ===
: :: : ;
: : ( -- )
: INIT-TEMP-NAMES
;
:: ; ( -- )
DEL-TEMP-NAMES PREVIOUS
POSTPONE ;
add_depth 0! \ ­  ¢á直© á«ãç © ;)
; IMMEDIATE

45
programs/develop/SPForth/devel/~mak/utils.f Normal file
View File

@ -0,0 +1,45 @@
REQUIRE [IF] ~MAK\CompIF.f
C" H." FIND NIP 0=
[IF]
: H. BASE @ HEX SWAP U. BASE ! ;
\ OP1
[THEN]
C" FIELD" FIND NIP 0=
[IF] : FIELD -- ;
[THEN]
C" BETWEEN" FIND NIP 0=
[IF] : BETWEEN 1+ WITHIN ;
[THEN]
C" ?EXIT" FIND NIP 0=
[IF]
: ?EXIT POSTPONE IF
POSTPONE EXIT
POSTPONE THEN ; IMMEDIATE
\ : ?EXIT IF RDROP THEN ;
[THEN]
C" DUP>R" FIND NIP 0=
[IF]
: DUP>R POSTPONE DUP
POSTPONE >R ; IMMEDIATE
[THEN]
C" >NAME" FIND NIP 0=
[IF] : >NAME 4 - DUP BEGIN 1- 2DUP COUNT + U< 0= UNTIL NIP ;
[THEN]
C" 2," FIND NIP 0=
[IF]
: 2, ( D -- )
HERE 2! 2 CELLS ALLOT ;
[THEN]
C" C>S" FIND NIP 0=
[IF] : C>S ( c -- n ) 0xFF AND [ 0x7F INVERT ] LITERAL XOR 0x80 + ;
[THEN]

510
programs/develop/SPForth/devel/~mak/utils_.f Normal file
View File

@ -0,0 +1,510 @@
CR .( UTILS_.F)
REQUIRE [IF] ~MAK\CompIF.f
\ WINAPI: GetCurrentDirectoryA KERNEL32.DLL
\ WINAPI: MoveFileA KERNEL32.DLL
: DEFER VECT ;
80 CONSTANT MAXSTRING
C" PLACE" FIND NIP 0=
[IF]
255 CONSTANT MAXCOUNTED \ maximum length of contents of a counted string
: "CLIP" ( a1 n1 -- a1 n1' ) \ clip a string to between 0 and MAXCOUNTED
MAXCOUNTED MIN 0 MAX ;
: PLACE ( addr len dest -- )
SWAP "CLIP" SWAP
2DUP 2>R
CHAR+ SWAP MOVE
2R> C! ;
: +PLACE ( addr len dest -- ) \ append string addr,len to counted
\ string dest
>R "CLIP" MAXCOUNTED R@ C@ - MIN R>
\ clip total to MAXCOUNTED string
2DUP 2>R
COUNT CHARS + SWAP MOVE
2R> +! ;
: C+PLACE ( c1 a1 -- ) \ append char c1 to the counted string at a1
DUP 1+! COUNT + 1- C! ;
[THEN]
: OFF 0! ;
: BLANK ( addr len -- ) \ fill addr for len with spaces (blanks)
BL FILL ;
: START/STOP ( -- )
KEY?
IF KEY 27 = IF ABORT THEN
THEN ;
: .S ( -- )
S0 @ SP@ CELL+ 2DUP =
IF ." EMPTY" 2DROP
ELSE DO I @ . START/STOP 1 CELLS +LOOP
THEN ;
C" TUCK" FIND NIP 0=
[IF]
: TUCK ( n1 n2 -- n2 n1 n2 ) \ copy top data stack to under second item
SWAP OVER ;
[THEN]
128 CONSTANT SPCS-MAX ( optimization for SPACES )
CREATE SPCS
SPCS-MAX ALLOT
SPCS SPCS-MAX BLANK
: (D.) ( d -- addr len ) TUCK DABS <# #S ROT SIGN #> ;
C" WITHIN" FIND NIP 0=
[IF]
: WITHIN ( n1 low high -- f1 ) \ f1=true if ((n1 >= low) & (n1 < high))
OVER - >R - R> U< ;
[THEN]
: BETWEEN 1+ WITHIN ;
80 VALUE COLS
: H.R ( n1 n2 -- ) \ display n1 as a hex number right
\ justified in a field of n2 characters
BASE @ >R HEX >R
0 <# #S #> R> OVER - SPACES TYPE
R> BASE ! ;
: H.N ( n1 n2 -- ) \ display n1 as a HEX number of n2 digits
BASE @ >R HEX >R
0 <# R> 0 ?DO # LOOP #> TYPE
R> BASE ! ;
: COL ( N -- )
DROP 9 EMIT ;
: UPC [ CHAR A CHAR a XOR INVERT ] LITERAL AND ;
: 2, ( D -- )
HERE 2! 2 CELLS ALLOT ;
: VOC-STATE,
CONTEXT @ ,
CONTEXT @ @ ,
VOC-LIST @ VOC-LIST 2,
CURRENT @ CURRENT 2,
LAST @ LAST 2,
VOC-LIST @
BEGIN ?DUP
WHILE DUP CELL+ DUP @ SWAP 2, @
REPEAT
;
: INCLUDE BL WORD COUNT INCLUDED ;
: CELLS+ CELLS + ;
: ? @ . ;
: DEFINED ( -- str 0 | cfa flag )
BL WORD FIND ;
: [IFUNDEF] DEFINED NIP 0= POSTPONE [IF] ;
\ C" CELL-" FIND NIP 0=
1
[IF] : CELL- 1 CELLS - ;
[THEN]
\ C" LCOUNT" FIND NIP 0=
1
[IF] : LCOUNT CELL+ DUP CELL- @ ;
[THEN]
: INCR 1 SWAP +! ;
: FIELD+ -- ;
0 [IF]
: CUR_DIR PAD 256 GetCurrentDirectoryA PAD SWAP ;
CREATE FIRST-PATH-BUF CUR_DIR NIP 1+ ALLOT
CUR_DIR FIRST-PATH-BUF PLACE
: FIRST-PATH" FIRST-PATH-BUF COUNT ;
: RENAME-FILE ( adr1 len adr2 len -- ior )
4DUP + DUP @ 2>R + DUP @ 2>R
4DUP + 0! + 0!
DROP NIP SWAP MoveFileA
2R> SWAP ! 2R> SWAP !
;
[THEN]
: FILE-APPEND ( fileid -- ior )
DUP >R FILE-SIZE DROP
R> RESIZE-FILE ;
C" U>" FIND NIP 0=
[IF]
: U> ( U1 U2 -- FLAG )
SWAP U< ;
[THEN]
C" FOLLOWER" FIND NIP
[IF]
: 2, ( D -- )
HERE 2! 2 CELLS ALLOT ;
: VOC-STATE,
CONTEXT @ ,
CONTEXT @ @ ,
VOC-LIST @ VOC-LIST 2,
CURRENT @ CURRENT 2,
LAST @ LAST 2,
VOC-LIST @
BEGIN ?DUP
WHILE DUP CELL+ DUP @ SWAP 2, @
REPEAT
;
: MARKER, ( -- ADDR )
HERE
VOC-STATE,
FOLLOWER @ FOLLOWER 2,
HERE 4 CELLS + DP 2, 0. 2,
;
: MARKER! ( ADDR -- )
DUP @ CONTEXT ! CELL+
DUP @ CONTEXT @ ! CELL+
BEGIN DUP 2@ DUP
WHILE ! 2 CELLS +
REPEAT 2DROP DROP ;
[ELSE]
: MARKER ( "<spaces>name" -- ) \ 94 CORE EXT
\ Ïðîïóñòèòü âåäóùèå ïðîáåëû. Âûäåëèòü name, îãðàíè÷åííîå ïðîáåëàìè.
\ Ñîçäàòü îïðåäåëåíèå ñ ñåìàíòèêîé âûïîëíåíèÿ, îïèñàííîé íèæå.
\ name Âûïîëíåíèå: ( -- )
\ Âîññòàíîâèòü ðàñïðåäåëåíèå ïàìÿòè ñëîâàðÿ è óêàçàòåëè ïîðÿäêà ïîèñêà
\ ê ñîñòîÿíèþ, êîòîðîå îíè èìåëè ïåðåä îïðåäåëåíèåì name. Óáðàòü
\ îïðåäåëåíèå name è âñå ïîñëåäóþùèå îïðåäåëåíèÿ. Íå òðåáóåòñÿ
\ îáÿçàòåëüíî âîññòàíàâëèâàòü ëþáûå îñòàâøèåñÿ ñòðóêòóðû, êîòîðûå
\ ìîãóò áûòü ñâÿçàíû ñ óäàëåííûìè îïðåäåëåíèÿìè èëè îñâîáîæäåííûì
\ ïðîñòðàíñòâîì äàííûõ. Íèêàêàÿ äðóãàÿ êîíòåêñòóàëüíàÿ èíôîðìàöèÿ,
\ êàê îñíîâàíèå ñèñòåìû ñ÷èñëåíèÿ, íå èçìåíÿåòñÿ.
HERE
\ [C]HERE , [E]HERE ,
GET-CURRENT ,
GET-ORDER DUP , 0 ?DO DUP , @ , LOOP
CREATE ,
DOES> @ DUP \ ONLY
\ DUP @ [C]DP ! CELL+
\ DUP @ [E]DP ! CELL+
DUP @ SET-CURRENT CELL+
DUP @ >R R@ CELLS 2* + 1 CELLS - R@ 0
?DO DUP DUP @ SWAP CELL+ @ OVER ! SWAP 2 CELLS - LOOP
DROP R> SET-ORDER
DP !
;
[THEN]
C" BODY>" FIND NIP 0=
[IF] : BODY> 5 - ;
[THEN]
C" >NAME" FIND NIP 0=
[IF] : >NAME 4 - DUP BEGIN 1- 2DUP COUNT + U< 0= UNTIL NIP ;
[THEN]
C" CELL/" FIND NIP 0=
[IF] : CELL/ ( N - N1 ) 2 RSHIFT ;
[THEN]
C" IMAGE-BEGIN" FIND NIP
[IF]
: ?NAME ( ADDR - FLAG )
DUP IMAGE-BEGIN U>
OVER HERE U< AND
IF DUP >NAME COUNT + CELL+ =
ELSE DROP FALSE
THEN ;
[THEN]
H-STDOUT CONSTANT FORTH-OUT
: FORTH-IO
FORTH-OUT H-STDOUT <>
IF H-STDOUT CLOSE-FILE DROP
FORTH-OUT TO H-STDOUT
THEN
;
: H. BASE @ HEX SWAP U. BASE ! ;
: 3DROP DROP 2DROP ;
: 4DUP 2OVER 2OVER ;
: 0.0 0 DUP ;
: IS POSTPONE TO ; IMMEDIATE
C" -ROT" FIND NIP 0=
[IF] : -ROT ROT ROT ;
[THEN]
: SCAN ( adr len char -- adr' len' )
\ Scan for char through addr for len, returning addr' and len' of char.
>R 2DUP R> -ROT
OVER + SWAP
?DO DUP I C@ =
IF LEAVE
ELSE >R 1 -1 D+ R>
THEN
LOOP DROP ;
: SSKIP ( adr len char -- adr' len' )
\ Skip char through addr for len, returning addr' and len' of char+1.
>R 2DUP R> -ROT
OVER + SWAP
?DO DUP I C@ <>
IF LEAVE
ELSE >R 1 -1 D+ R>
THEN
LOOP DROP ;
1 CELLS CONSTANT CELL
C" LSCAN" FIND NIP 0=
[IF]
: LSCAN ( adr len long -- adr' len' )
\ Scan for char through addr for len, returning addr' and len' of char.
>R 2DUP CELLS R> -ROT \ adr len long adr len
OVER + SWAP \ adr len long adr+len adr
?DO DUP I @ =
IF LEAVE
ELSE >R 1- >R CELL+ R> R>
THEN CELL
+LOOP DROP ;
[THEN]
C" /STRING" FIND NIP 0=
[IF] : /STRING DUP >R - SWAP R> + SWAP ;
[THEN]
: "TO-PATHEND" ( a1 n1 --- a2 n2 ) \ return a2 and count=n1 of filename
OVER 1+ C@ [CHAR] : = \ second char is ':'
OVER 2 > AND \ and name is longer than two characters
IF 2 /STRING \ then remove first two characters
THEN \ now scan to end of last '\' in filename
BEGIN 2DUP [CHAR] \ SCAN ?DUP
WHILE 2SWAP 2DROP 1 /STRING
REPEAT DROP ;
: ON TRUE SWAP ! ;
C" -ROT" FIND NIP 0=
[IF] : -ROT ROT ROT ;
[THEN]
C" BOUNDS" FIND NIP 0=
[IF] : BOUNDS OVER + SWAP ;
[THEN]
: >= < INVERT ;
: 4DROP 2DROP 2DROP ;
C" RECURSE" FIND NIP 0=
[IF]
: RECURSE ( -- ) \ cause current definition to execute itself
?COMP LAST @ NAME> COMPILE, ; IMMEDIATE
[THEN]
C" DUP>R" FIND NIP 0=
[IF] : DUP>R POSTPONE DUP POSTPONE >R ; IMMEDIATE
[THEN]
C" PICK" FIND NIP 0=
[IF]
: PICK ( n -- n' )
1+ CELLS SP@ + @ ;
[THEN]
C" ROLL" FIND NIP 0=
[IF]
: ROLL ( n1 n2 .. nk k -- n2 n3 .. nk n1 )
\ Rotate k values on the stack, bringing the deepest to the top.
\ ?DUP IF 1- SWAP >R RECURSE R> SWAP THEN ;
DUP>R PICK SP@ DUP CELL+ R> 1+ CELLS MOVE DROP ;
[THEN]
C" AHEAD" FIND NIP 0=
[IF]
: AHEAD POSTPONE FALSE POSTPONE IF ; IMMEDIATE
[THEN]
C" NOT" FIND NIP 0=
[IF] : NOT 0= ;
[THEN]
C" ?EXIT" FIND NIP 0=
[IF]
: ?EXIT POSTPONE IF
POSTPONE EXIT
POSTPONE THEN ; IMMEDIATE
\ : ?EXIT IF RDROP THEN ;
[THEN]
: BEEP 7 EMIT ;
16 CONSTANT #VOCS
-1 CELLS CONSTANT -CELL
C" D2*" FIND NIP 0=
[IF] : D2* 2DUP D+ ;
[THEN]
: ," [CHAR] " WORD C@ 1+ ALLOT 0 C, ;
: TAB 9 EMIT ;
: (D.) ( d -- addr len ) TUCK DABS <# #S ROT SIGN #> ;
: D.R ( d w -- ) >R (D.) R> OVER - SPACES TYPE ;
: U.R ( u w -- ) 0 SWAP D.R ;
: $ SOURCE TYPE CR ; IMMEDIATE
: +NULL ( a1 -- ) \ append a NULL just beyond the counted chars
COUNT + 0 SWAP C! ;
C" CELLS+" FIND NIP 0=
[IF]
: CELLS+ CELLS + ;
[THEN]
C" +CELLS" FIND NIP 0=
[IF]
: +CELLS SWAP CELLS+ ;
[THEN]
C" PERFORM" FIND NIP 0=
[IF]
: PERFORM @ EXECUTE ;
[THEN]
C" UPPER" FIND NIP 0=
[IF]
: UPPER ( A L -- )
OVER + SWAP
?DO I C@ DUP [CHAR] Z U>
IF 0xDF AND
THEN I C!
LOOP ;
[THEN]
C" RESET-STACKS" FIND NIP 0=
[IF]
: RESET-STACKS S0 @ SP! ;
[THEN]
C" D-" FIND NIP 0=
[IF]
: D- ( D1 D2 -- FLAG )
DNEGATE D+ ;
[THEN]
C" D=" FIND NIP 0=
[IF]
: D= ( D1 D2 -- FLAG )
D- D0= ;
[THEN]
C" D<>" FIND NIP 0=
[IF]
: D<> ( D1 D2 -- FLAG )
D= INVERT ;
[THEN]
C" <=" FIND NIP 0=
[IF]
: <= ( D1 D2 -- FLAG )
> INVERT ;
[THEN]
C" UMAX" FIND NIP 0=
[IF]
: UMAX ( D1 D2 -- FLAG )
2DUP U< IF NIP ELSE DROP THEN ;
[THEN]
C" D2/" FIND NIP 0=
[IF]
: D2/ ( d1 -- d2 ) \ divide the double number d1 by two
DUP 1 AND 0x1F RSHIFT ROT 2/ OR SWAP 2/ ;
[THEN]
C" D0<" FIND NIP 0=
[IF]
: D0< ( d1 -- f1 )
\ Signed compare d1 double number with zero. If d1 < 0, RETNurn TRUE.
0< NIP ;
[THEN]
C" \S" FIND NIP 0=
[IF]
: \S \ comment to end of file
BEGIN REFILL 0= UNTIL
\ SOURCE-ID FILE-SIZE DROP
\ SOURCE-ID REPOSITION-FILE DROP
[COMPILE] \ ; IMMEDIATE
[THEN]
\ C" NEEDS" FIND NIP 0=
0
[IF]
: NEEDS
BL WORD FIND NIP
BL WORD SWAP 0=
IF COUNT INCLUDED
ELSE DROP
THEN
;
[THEN]
C" 0MIN" FIND NIP 0=
[IF] : 0MIN 0 MIN ;
[THEN]
C" 0MAX" FIND NIP 0=
[IF] : 0MAX 0 MIN ;
[THEN]
C" H." FIND NIP 0=
[IF] : H. BASE @ SWAP HEX U. BASE ! ;
[THEN]
C" .HS" FIND NIP 0=
[IF]
: .HS ( N -- N1 )
BASE @ >R HEX .S R> BASE ! ;
[THEN]
C" MS" FIND NIP 0=
[IF]
C" PAUSE" FIND NIP
[IF] : MS ( N -- ) PAUSE ;
[THEN]
[THEN]
C" 0>" FIND NIP 0=
[IF]
: 0> ( N -- ) NEGATE 0< ;
[THEN]
C" CS-DUP" FIND NIP 0=
[IF] : CS-DUP 2DUP ;
[THEN]
C" M_WL" FIND NIP 0=
[IF] : M_WL CS-DUP POSTPONE WHILE ; IMMEDIATE
[THEN]
C" AHEAD" FIND NIP 0=
[IF] : AHEAD ?COMP HERE BRANCH, >MARK 1 ; IMMEDIATE
[THEN]
C" CS-DUP" FIND NIP 0=
[IF] : CS-DUP 2DUP ;
[THEN]
C" CS-!" FIND NIP 0=
[IF] : CS-! 2! ;
[THEN]
C" CS-@" FIND NIP 0=
[IF] : CS-@ 2@ ;
[THEN]
C" CS-CELLS" FIND NIP 0=
[IF] : CS-CELLS CELLS 2* ;
[THEN]

22
programs/develop/SPForth/devel/~mak/want.f Normal file
View File

@ -0,0 +1,22 @@
REQUIRE [IF] ~mak/CompIF.f
REQUIRE $! ~mak\place.f
REQUIRE [IFNDEF] ~nn\lib\ifdef.f
[IFNDEF] PARSE-WORD
: PARSE-WORD NextWord ;
[THEN]
CREATE WANT_BUFF 0x101 ALLOT
CREATE WANT_FILE 0x101 ALLOT
S" ~mak\do_want.f" WANT_FILE $!
: [WANT] ( addr len -- addr len | )
2DUP PARSE-WORD COMPARE
IF POSTPONE \ EXIT THEN
2DROP INTERPRET \EOF ;
: WANT ( -- )
PARSE-WORD WANT_BUFF $!
WANT_FILE COUNT INCLUDED ;

75
programs/develop/SPForth/devel/~mak/~af/lib/c/zstr.f Normal file
View File

@ -0,0 +1,75 @@
\ $Id: zstring.f,v 1.1 2003/01/18 09:02:11 anfilat Exp $
\ <20>ã«ì-áâப¨. ’¥å­®«®£¨ï ¢§ïâ  ¨§ ~yz\common.f
\ Š®¯¨àã¥â áâபã addr u ¯®  ¤à¥áã z. ‚ ª®­¥æ áâப¨ § ¯¨á뢠¥â 0
: CZMOVE ( a # z --) 2DUP + >R SWAP CMOVE R> 0 SWAP C! ;
: ALITERAL R> COUNT OVER + 1+ >R ;
\ VOCABULARY ZStrSupport
\ GET-CURRENT ALSO ZStrSupport DEFINITIONS
USER toadr USER fromadr USER counter
: zchar ( --c/0) counter @ 1 <
IF 0 ELSE -1 counter +! fromadr @ C@ fromadr 1+! THEN ;
: unchar counter 1+! -1 fromadr +! ;
: c> ( c--) toadr @ C! toadr 1+! ;
: escape ( c--c )
DUP [CHAR] n = IF DROP 10 ELSE
DUP [CHAR] r = IF DROP 13 ELSE
DUP [CHAR] t = IF DROP 9 ELSE
DUP [CHAR] b = IF DROP 8 ELSE
DUP [CHAR] q = IF DROP [CHAR] " ELSE
DUP [ CHAR 0 1- ] LITERAL OVER < SWAP [ CHAR 9 1+ ] LITERAL < AND IF
[CHAR] 0 -
BEGIN ( n) zchar DUP
[ CHAR 0 1- ] LITERAL OVER < SWAP [ CHAR 9 1+ ] LITERAL < AND
WHILE
( n c) [CHAR] 0 - SWAP 10 * +
REPEAT
0<> IF unchar THEN
THEN
THEN
THEN
THEN
THEN
THEN
;
: ESC-CZMOVE ( a # to --)
toadr ! counter ! fromadr !
BEGIN
zchar
DUP [CHAR] \ = IF DROP zchar escape THEN
DUP c> 0= UNTIL ;
\ SET-CURRENT
: Z\LITERAL ( addr u -- \ a) \ ¢ ०¨¬¥ ¨­â¥à¯à¥â æ¨¨ ¢®§¢à é ¥â  ¤à¥á
\ ¡ãä¥à  ¢ ¤¨­ ¬¨ç¥áª®© ¯ ¬ïâ¨. <20>ãä¥à ¦¥« â¥«ì­® ®á¢®¡®¤¨âì
STATE @ IF
POSTPONE ALITERAL
HERE 1+ DUP >R ESC-CZMOVE
R@ ASCIIZ> NIP 2+ DUP ALLOT 2- R> 1- C!
ELSE
DUP 1+ ALLOCATE THROW DUP >R ESC-CZMOVE R>
THEN
; IMMEDIATE
: ZLITERAL ( addr u -- \ a)
STATE @ IF
POSTPONE ALITERAL
DUP C,
HERE SWAP DUP ALLOT MOVE 0 C,
ELSE
DUP 1+ ALLOCATE THROW DUP >R CZMOVE R>
THEN
; IMMEDIATE
\ ‘®§¤ ¥â áâபã, ®ª ­ç¨¢ îéãîáï ­ã«¥¬
: Z" ( -->") [CHAR] " PARSE [COMPILE] ZLITERAL ; IMMEDIATE
\ ‘®§¤ ¥â 0-áâபã, ¯à¨ í⮬ ¯à¥®¡à §ã¥â ¥¥ ¯® C-¯à ¢¨« ¬.
: Z\" ( -->") [CHAR] " PARSE [COMPILE] Z\LITERAL ; IMMEDIATE
\ PREVIOUS

21
programs/develop/SPForth/devel/~nn/lib/ifdef.f Normal file
View File

@ -0,0 +1,21 @@
C" [DEFINED]" FIND NIP 0=
[IF]
: [DEFINED] ( -- f ) \ "name"
NextWord SFIND IF DROP TRUE ELSE 2DROP FALSE THEN
; IMMEDIATE
: [UNDEFINED] ( -- f ) \ "name"
POSTPONE [DEFINED] 0=
; IMMEDIATE
[THEN]
: [IFDEF]
POSTPONE [DEFINED]
0= IF POSTPONE [ELSE] THEN
; IMMEDIATE
: [IFNDEF]
POSTPONE [UNDEFINED]
0= IF POSTPONE [ELSE] THEN
; IMMEDIATE

318
programs/develop/SPForth/gif_lite.inc Normal file
View File

@ -0,0 +1,318 @@
; GIF LITE v2.0 by Willow
; Written in pure assembler by Ivushkin Andrey aka Willow
;
; This include file will contain functions to handle GIF image format
;
; Created: August 15, 2004
; Last changed: September 9, 2004
; Change COLOR_ORDER in your program
; if colors are displayed improperly
if ~ (COLOR_ORDER in <MENUETOS,OTHER>)
; This message may not appear under MenuetOS, so watch...
display 'Please define COLOR_ORDER: MENUETOS or OTHER',13,10
end if
struc GIF_info
{
; .NextImg rd 1 ; used internally
.Left rw 1
.Top rw 1
.Width rw 1
.Height rw 1
}
_null fix 0x1000
; ****************************************
; FUNCTION GetGIFinfo - retrieve Nth image info
; ****************************************
; in:
; esi - pointer to image list header
; ecx - image_index (0...img_count-1)
; edi - pointer to GIF_info structure to be filled
; out:
; eax - pointer to RAW data, or 0, if error
GetGIFinfo:
push esi ecx edi
xor eax,eax
jecxz .eloop
.lp:
mov esi,[esi]
test esi,esi
jz .error
loop .lp
.eloop:
add esi,4
movsd
movsd
mov eax,esi
.error:
pop edi ecx esi
ret
; ****************************************
; FUNCTION ReadGIF - unpacks GIF image
; ****************************************
; in:
; esi - pointer to GIF file in memory
; edi - pointer to output image list
; eax - pointer to work area (MIN 16 KB!)
; out:
; eax - 0, all OK;
; eax - 1, invalid signature;
; eax >=8, unsupported image attributes
;
; ecx - number of images
ReadGIF:
push esi edi
mov [.table_ptr],eax
mov [.cur_info],edi
xor eax,eax
mov [.globalColor],eax
mov [.img_count],eax
inc eax
cmp dword[esi],'GIF8'
jne .er ; signature
mov ecx,[esi+0xa]
inc eax
add esi,0xd
mov edi,esi
bt ecx,7
jnc .nextblock
mov [.globalColor],esi
call .Gif_skipmap
.nextblock:
cmp byte[edi],0x21
jne .noextblock
inc edi
cmp byte[edi],0xf9 ; Graphic Control Ext
jne .no_gc
add edi,7
jmp .nextblock
.no_gc:
cmp byte[edi],0xfe ; Comment Ext
jne .no_comm
inc edi
.block_skip:
movzx eax,byte[edi]
lea edi,[edi+eax+1]
cmp byte[edi],0
jnz .block_skip
inc edi
jmp .nextblock
.no_comm:
cmp byte[edi],0xff ; Application Ext
jne .nextblock
add edi,13
jmp .block_skip
.noextblock:
cmp byte[edi],0x2c ; image beginning
jne .er
inc [.img_count]
inc edi
mov esi,[.cur_info]
add esi,4
xchg esi,edi
movsd
movsd
push edi
movzx ecx,word[esi]
inc esi
bt ecx,7
jc .uselocal
push [.globalColor]
mov edi,esi
jmp .setPal
.uselocal:
call .Gif_skipmap
push esi
.setPal:
movzx ecx,byte[edi]
inc ecx
mov [.codesize],ecx
dec ecx
pop [.Palette]
lea esi,[edi+1]
mov edi,[.table_ptr]
xor eax,eax
cld
lodsb ; eax - block_count
add eax,esi
mov [.block_ofs],eax
mov [.bit_count],8
mov eax,1
shl eax,cl
mov [.CC],eax
inc eax
mov [.EOI],eax
lea ecx,[eax-1]
mov eax, _null shl 16
.filltable:
stosd
inc eax
loop .filltable
pop edi
mov [.img_start],edi
.reinit:
mov edx,[.EOI]
inc edx
push [.codesize]
pop [.compsize]
call .Gif_get_sym
cmp eax,[.CC]
je .reinit
call .Gif_output
.cycle:
movzx ebx,ax
call .Gif_get_sym
cmp eax,edx
jae .notintable
cmp eax,[.CC]
je .reinit
cmp eax,[.EOI]
je .end
call .Gif_output
.add:
push eax
mov eax,[.table_ptr]
mov [eax+edx*4],ebx
pop eax
cmp edx,0xFFF
jae .cycle
inc edx
bsr ebx,edx
cmp ebx,[.compsize]
jne .noinc
inc [.compsize]
.noinc:
jmp .cycle
.notintable:
push eax
mov eax,ebx
call .Gif_output
push ebx
movzx eax,bx
call .Gif_output
pop ebx eax
jmp .add
.er:
pop edi
jmp .ex
.end:
mov eax,[.cur_info]
mov [eax],edi
mov [.cur_info],edi
add esi,2
xchg esi,edi
.nxt:
cmp byte[edi],0
jnz .continue
inc edi
jmp .nxt
.continue:
cmp byte[edi],0x3b
jne .nextblock
xor eax,eax
stosd
mov ecx,[.img_count]
.ex:
pop edi esi
ret
.Gif_skipmap:
; in: ecx - image descriptor, esi - pointer to colormap
; out: edi - pointer to area after colormap
and ecx,111b
inc ecx ; color map size
mov ebx,1
shl ebx,cl
lea ebx,[ebx*2+ebx]
lea edi,[esi+ebx]
ret
.Gif_get_sym:
mov ecx,[.compsize]
push ecx
xor eax,eax
.shift:
ror byte[esi],1
rcr eax,1
dec [.bit_count]
jnz .loop1
inc esi
cmp esi,[.block_ofs]
jb .noblock
push eax
xor eax,eax
lodsb
test eax,eax
jnz .nextbl
mov eax,[.EOI]
sub esi,2
add esp,8
jmp .exx
.nextbl:
add eax,esi
mov [.block_ofs],eax
pop eax
.noblock:
mov [.bit_count],8
.loop1:
loop .shift
pop ecx
rol eax,cl
.exx:
xor ecx,ecx
ret
.Gif_output:
push esi eax edx
mov edx,[.table_ptr]
.next:
push word[edx+eax*4]
mov ax,word[edx+eax*4+2]
inc ecx
cmp ax,_null
jnz .next
shl ebx,16
mov bx,[esp]
.loop2:
pop ax
lea esi,[eax+eax*2]
add esi,[.Palette]
if COLOR_ORDER eq MENUETOS
mov esi,[esi]
bswap esi
shr esi,8
mov [edi],esi
add edi,3
else
movsw
movsb
end if
loop .loop2
pop edx eax esi
ret
.globalColor rd 1
.img_count rd 1
.cur_info rd 1 ; image table pointer
.img_start rd 1
.codesize rd 1
.compsize rd 1
.bit_count rd 1
.CC rd 1
.EOI rd 1
.Palette rd 1
.block_ofs rd 1
.table_ptr rd 1

29075
programs/develop/SPForth/img.asm Normal file
View File

File diff suppressed because it is too large Load Diff

2103
programs/develop/SPForth/lib/asm/486asm.f Normal file
View File

File diff suppressed because it is too large Load Diff

111
programs/develop/SPForth/lib/asm/asmmac.f Normal file
View File

@ -0,0 +1,111 @@
( Miscellaneous macros for Win32FORTH 486ASM version 1.24 )
( copyright [c] 1994 by Jim Schneider )
( This file version 1.2 )
( This program is free software; you can redistribute it and/or modify )
( it under the terms of the GNU General Public License as published by )
( the Free Software Foundation; either version 2 of the License, or )
( <at your option> any later version. )
( )
( This program is distributed in the hope that it will be useful, )
( but WITHOUT ANY WARRANTY; without even the implied warranty of )
( MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the )
( GNU General Public License for more details. )
( )
( You should have received a copy of the GNU General Public License )
( along with this program; if not, write to the Free Software )
( Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. )
MACRO: ;M POSTPONE ;MACRO ENDM IMMEDIATE
MACRO: AL, AL , ;M
MACRO: CL, CL , ;M
MACRO: DL, DL , ;M
MACRO: BL, BL , ;M
MACRO: AH, AH , ;M
MACRO: CH, CH , ;M
MACRO: DH, DH , ;M
MACRO: BH, BH , ;M
MACRO: AX, AX , ;M
MACRO: CX, CX , ;M
MACRO: DX, DX , ;M
MACRO: BX, BX , ;M
MACRO: SP, SP , ;M
MACRO: BP, BP , ;M
MACRO: SI, SI , ;M
MACRO: DI, DI , ;M
MACRO: EAX, EAX , ;M
MACRO: ECX, ECX , ;M
MACRO: EDX, EDX , ;M
MACRO: EBX, EBX , ;M
MACRO: ESP, ESP , ;M
MACRO: EBP, EBP , ;M
MACRO: ESI, ESI , ;M
MACRO: EDI, EDI , ;M
MACRO: [BX+SI], [BX+SI] , ;M
MACRO: [BX+DI], [BX+DI] , ;M
MACRO: [BP+SI], [BP+SI] , ;M
MACRO: [BP+DI], [BP+DI] , ;M
MACRO: [SI], [SI] , ;M
MACRO: [DI], [DI] , ;M
MACRO: [BP], [BP] , ;M
MACRO: [BX], [BX] , ;M
MACRO: [EAX], [EAX] , ;M
MACRO: [ECX], [ECX] , ;M
MACRO: [EDX], [EDX] , ;M
MACRO: [EBX], [EBX] , ;M
MACRO: [ESP], [ESP] , ;M
MACRO: [EBP], [EBP] , ;M
MACRO: [ESI], [ESI] , ;M
MACRO: [EDI], [EDI] , ;M
MACRO: [EAX*2], [EAX*2] , ;M
MACRO: [ECX*2], [ECX*2] , ;M
MACRO: [EDX*2], [EDX*2] , ;M
MACRO: [EBX*2], [EBX*2] , ;M
\ MACRO: [ESP*2], [ESP*2] , ;M
MACRO: [EBP*2], [EBP*2] , ;M
MACRO: [ESI*2], [ESI*2] , ;M
MACRO: [EDI*2], [EDI*2] , ;M
MACRO: [EAX*4], [EAX*4] , ;M
MACRO: [ECX*4], [ECX*4] , ;M
MACRO: [EDX*4], [EDX*4] , ;M
MACRO: [EBX*4], [EBX*4] , ;M
MACRO: [EBP*4], [EBP*4] , ;M
MACRO: [ESI*4], [ESI*4] , ;M
MACRO: [EDI*4], [EDI*4] , ;M
MACRO: [EAX*8], [EAX*8] , ;M
MACRO: [ECX*8], [ECX*8] , ;M
MACRO: [EDX*8], [EDX*8] , ;M
MACRO: [EBX*8], [EBX*8] , ;M
MACRO: [EBP*8], [EBP*8] , ;M
MACRO: [ESI*8], [ESI*8] , ;M
MACRO: [EDI*8], [EDI*8] , ;M
MACRO: ES, ES , ;M
MACRO: CS, CS , ;M
MACRO: SS, SS , ;M
MACRO: DS, DS , ;M
MACRO: FS, FS , ;M
MACRO: GS, GS , ;M
MACRO: CR0, CR0 , ;M
MACRO: CR2, CR2 , ;M
MACRO: CR3, CR3 , ;M
MACRO: CR4, CR4 , ;M
MACRO: DR0, DR0 , ;M
MACRO: DR1, DR1 , ;M
MACRO: DR2, DR2 , ;M
MACRO: DR3, DR3 , ;M
MACRO: DR6, DR6 , ;M
MACRO: DR7, DR7 , ;M
MACRO: TR3, TR3 , ;M
MACRO: TR4, TR4 , ;M
MACRO: TR5, TR5 , ;M
MACRO: TR6, TR6 , ;M
MACRO: TR7, TR7 , ;M
MACRO: ST, ST , ;M
MACRO: ST(0), ST(0) , ;M
MACRO: ST(1), ST(1) , ;M
MACRO: ST(2), ST(2) , ;M
MACRO: ST(3), ST(3) , ;M
MACRO: ST(4), ST(4) , ;M
MACRO: ST(5), ST(5) , ;M
MACRO: ST(6), ST(6) , ;M
MACRO: ST(7), ST(7) , ;M

42
programs/develop/SPForth/lib/ext/case.f Normal file
View File

@ -0,0 +1,42 @@
\ Ęîíńňđóęöč˙ âűáîđŕ CASE
\ ń ó÷ĺňîě âîçěîćíîé âëîćĺííîńňč îďĺđŕňîđîâ CASE
DECIMAL
VARIABLE CSP \ Óęŕçŕňĺëü ńňĺęŕ ęîíňđîë˙
6 CONSTANT L-CAS# \ Äîďóńňčěűé óđîâĺíü âëîćĺííîńňč
CREATE S-CSP L-CAS# CELLS ALLOT \ Ńňĺę ęîíňđîë˙
S-CSP CSP !
: +CSP ( -> P) \ Äîáŕâčňü óđîâĺíü
CSP @ DUP CELL+ CSP !
;
: -CSP ( -> ) \ Óáđŕňü óđîâĺíü
CSP @ 1 CELLS - CSP !
;
: !CSP ( -> ) \ Číčöčŕëčçčđîâŕňü óđîâĺíü
SP@ +CSP !
;
: CSP@ ( -> A)
CSP @ 1 CELLS - @
;
: ?CSP ( -> ) \ Ďđîâĺđčňü âűäĺđćŕííîńňü ńňĺęŕ
\ SP@ CSP@ <> 37 ?ERROR ( ABORT" Ńáîé ńňĺęŕ ďî CSP !")
-CSP
;
: CASE ( -> )
!CSP
; IMMEDIATE
: OF
POSTPONE OVER POSTPONE =
[COMPILE] IF POSTPONE DROP
; IMMEDIATE
: ENDOF
[COMPILE] ELSE
; IMMEDIATE
: ENDCASE
POSTPONE DROP BEGIN SP@ CSP@ =
0= WHILE [COMPILE] THEN REPEAT -CSP
; IMMEDIATE

1555
programs/develop/SPForth/lib/ext/disasm.f Normal file
View File

File diff suppressed because it is too large Load Diff

1955
programs/develop/SPForth/lib/ext/disasm2.f Normal file
View File

File diff suppressed because it is too large Load Diff

324
programs/develop/SPForth/lib/ext/locals.f Normal file
View File

@ -0,0 +1,324 @@
( 28.Mar.2000 Andrey Cherezov Copyright [C] RU FIG
Использованы идеи следующих авторов:
Ruvim Pinka; Dmitry Yakimov; Oleg Shalyopa; Yuriy Zhilovets;
Konstantin Tarasov; Michail Maximov.
!! Работает только в SPF4.
)
( Простое расширение СП-Форта локальными переменными.
Реализовано без использования LOCALS стандарта 94.
Объявление временных переменных, видимых только внутри
текущего слова и ограниченных временем вызова данного
слова выполняется с помощью слова "{". Внутри определения
слова используется конструкция, подобная стековой нотации Форта
{ список_инициализированных_локалов \ сп.неиниц.локалов -- что угодно }
Например:
{ a b c d \ e f -- i j }
Или { a b c d \ e f[ EVALUATE_выражение ] -- i j }
Это значит что для переменной f[ будет выделен на стеке возвратов участок
памяти длиной n байт. Использование переменной f[ даст адрес начала этого
участка. \В стиле MPE\
Или { a b c d \ e [ 12 ] f -- i j }
Это значит что для переменной f будет выделен на стеке возвратов участок
памяти длиной 12 байт. Использование переменной f даст адрес начала этого
участка.
Часть "\ сп.неиниц.локалов" может отсутствовать, например:
{ item1 item2 -- }
Это заставляет СП-Форт автоматически выделять место в
стеке возвратов для этих переменных в момент вызова слова
и автоматически освобождать место при выходе из него.
Обращение к таким локальным переменным - как к VALUE-переменным
по имени. Если нужен адрес переменной, то используется "^ имя"
или "AT имя".
Вместо \ можно использовать |
Вместо -> можно использовать TO
Примеры:
: TEST { a b c d \ e f -- } a . b . c . b c + -> e e . f . ^ a @ . ;
Ok
1 2 3 4 TEST
1 2 3 5 0 1 Ok
: TEST { a b -- } a . b . CR 5 0 DO I . a . b . CR LOOP ;
Ok
12 34 TEST
12 34
0 12 34
1 12 34
2 12 34
3 12 34
4 12 34
Ok
: TEST { a b } a . b . ;
Ok
1 2 TEST
1 2 Ok
: TEST { a b \ c } a . b . c . ;
Ok
1 2 TEST
1 2 0 Ok
: TEST { a b -- } a . b . ;
Ok
1 2 TEST
1 2 Ok
: TEST { a b \ c -- d } a . b . c . ;
Ok
1 2 TEST
1 2 0 Ok
: TEST { \ a b } a . b . 1 -> a 2 -> b a . b . ;
Ok
TEST
0 0 1 2 Ok
Имена локальных переменных существуют в динамическом
временном словаре только в момент компиляции слова, а
после этого вычищаются и более недоступны.
Использовать конструкцию "{ ... }" внутри одного определения можно
только один раз.
Компиляция этой библиотеки добавляет в текущий словарь компиляции
Только два слова:
словарь "vocLocalsSupport" и "{"
Все остальные детали "спрятаны" в словаре, использовать их
не рекомендуется.
)
MODULE: vocLocalsSupport
USER widLocals
USER uLocalsCnt
USER uLocalsUCnt
USER uPrevCurrent
USER uAddDepth
: (Local^) ( N -- ADDR )
RP@ +
;
: LocalOffs ( n -- offs )
uLocalsCnt @ SWAP - CELLS CELL+ uAddDepth @ +
;
BASE @ HEX
: CompileLocalsInit
uPrevCurrent @ SET-CURRENT
uLocalsCnt @ uLocalsUCnt @ - ?DUP IF CELLS LIT, POSTPONE DRMOVE THEN
uLocalsUCnt @ ?DUP
IF
LIT, POSTPONE (RALLOT)
THEN
uLocalsCnt @ ?DUP
IF CELLS RLIT, ['] (LocalsExit) RLIT, THEN
;
: CompileLocal@ ( n -- )
['] DUP MACRO,
LocalOffs DUP SHORT?
OPT_INIT SetOP
IF 8B B, 44 B, 24 B, B, \ mov eax, offset [esp]
ELSE 8B B, 84 B, 24 B, , \ mov eax, offset [esp]
THEN OPT
OPT_CLOSE
;
\ : CompileLocal@ ( n -- )
\ LocalOffs LIT, POSTPONE RP+@
\ ;
: CompileLocal! ( n -- )
LocalOffs DUP SHORT?
OPT_INIT SetOP
IF 89 B, 44 B, 24 B, B, \ mov offset [esp], eax
ELSE 89 B, 84 B, 24 B, , \ mov offset [esp], eax
THEN OPT
OPT_CLOSE
['] DROP MACRO,
;
: CompileLocalRec ( u -- )
LocalOffs DUP
['] DUP MACRO,
SHORT?
OPT_INIT SetOP
IF 8D B, 44 B, 24 B, B, \ lea eax, offset [esp]
ELSE 8D B, 84 B, 24 B, , \ lea eax, offset [esp]
THEN OPT
OPT_CLOSE
;
BASE !
: LocalsStartup
TEMP-WORDLIST widLocals !
GET-CURRENT uPrevCurrent !
ALSO vocLocalsSupport
ALSO widLocals @ CONTEXT ! DEFINITIONS
uLocalsCnt 0!
uLocalsUCnt 0!
uAddDepth 0!
;
: LocalsCleanup
PREVIOUS PREVIOUS
widLocals @ FREE-WORDLIST
;
: ProcessLocRec ( "name" -- u )
[CHAR] ] PARSE
STATE 0!
EVALUATE CELL 1- + CELL / \ делаем кратным 4
-1 STATE !
DUP uLocalsCnt +!
uLocalsCnt @ 1-
;
: CreateLocArray
ProcessLocRec
CREATE ,
;
: LocalsRecDoes@ ( -- u )
DOES> @ CompileLocalRec
;
: LocalsRecDoes@2 ( -- u )
ProcessLocRec ,
DOES> @ CompileLocalRec
;
: LocalsDoes@
uLocalsCnt @ ,
uLocalsCnt 1+!
DOES> @ CompileLocal@
;
: ;; POSTPONE ; ; IMMEDIATE
: ^
' >BODY @
CompileLocalRec
; IMMEDIATE
: -> ' >BODY @ CompileLocal! ; IMMEDIATE
WARNING DUP @ SWAP 0!
: AT
[COMPILE] ^
; IMMEDIATE
: TO ( "name" -- )
>IN @ NextWord widLocals @ SEARCH-WORDLIST 1 =
IF >BODY @ CompileLocal! DROP
ELSE >IN ! [COMPILE] TO
THEN
; IMMEDIATE
WARNING !
: в POSTPONE -> ; IMMEDIATE
WARNING @ WARNING 0!
\ ===
\ переопределение соответствующих слов для возможности использовать
\ временные переменные внутри цикла DO LOOP и независимо от изменения
\ содержимого стека возвратов словами >R R>
: DO POSTPONE DO [ 3 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: ?DO POSTPONE ?DO [ 3 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: LOOP POSTPONE LOOP [ -3 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: +LOOP POSTPONE +LOOP [ -3 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: >R POSTPONE >R [ 1 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: R> POSTPONE R> [ -1 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: RDROP POSTPONE RDROP [ -1 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: 2>R POSTPONE 2>R [ 2 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: 2R> POSTPONE 2R> [ -2 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
\ ===
\ { ... | ... -- _____ }
: ParseLocals3
BEGIN
PARSE-NAME
DUP 0= ABORT" Locals bad syntax (3)"
2DUP S" }" COMPARE 0= IF 2DROP EXIT THEN
2DROP
AGAIN
;
\ { ... | _____ -- ... }
: ParseLocals2
BEGIN
PARSE-NAME
DUP 0= ABORT" Locals bad syntax (2)"
2DUP S" --" COMPARE 0= IF 2DROP ParseLocals3 EXIT THEN
2DUP S" }" COMPARE 0= IF 2DROP EXIT THEN
2DUP S" [" COMPARE 0=
IF
2DROP CreateLocArray LocalsRecDoes@
ELSE
CREATED
LATEST DUP C@ CHARS + C@
[CHAR] [ =
IF
LocalsRecDoes@2
ELSE
LocalsDoes@ 1
THEN
THEN
uLocalsUCnt +! IMMEDIATE
AGAIN
;
\ { _____ | ... -- ... }
: ParseLocals1
BEGIN
PARSE-NAME
DUP 0= ABORT" Locals bad syntax (1)"
2DUP S" |" COMPARE 0= IF 2DROP ParseLocals2 EXIT THEN
2DUP S" \" COMPARE 0= IF 2DROP ParseLocals2 EXIT THEN
2DUP S" --" COMPARE 0= IF 2DROP ParseLocals3 EXIT THEN
2DUP S" }" COMPARE 0= IF 2DROP EXIT THEN
CREATED LocalsDoes@ IMMEDIATE
AGAIN ;
\ uLocalsCnt @ ?DUP
\ IF CELLS RLIT, ['] (LocalsExit) RLIT, THEN
: ; LocalsCleanup
S" ;" EVAL-WORD
; IMMEDIATE
WARNING !
\ =====================================================================
EXPORT
: {
LocalsStartup
ParseLocals1
CompileLocalsInit
;; IMMEDIATE
;MODULE

8
programs/develop/SPForth/lib/ext/patch.f Normal file
View File

@ -0,0 +1,8 @@
\ from gforth
: REPLACE-WORD ( by-xt what-xt )
[ HEX ] E9 [ DECIMAL ] OVER C! \ JMP ...
1+ DUP >R
CELL+ -
R> !
;

40
programs/develop/SPForth/lib/ext/spf-asm.f Normal file
View File

@ -0,0 +1,40 @@
REQUIRE CASE lib/ext/case.f
REQUIRE !CSP ~mak/lib/csr.f
: DEFER CREATE ['] NOOP , DOES> @ EXECUTE ;
: DEFER@ ' >BODY STATE @ IF POSTPONE LITERAL POSTPONE @ ELSE @ THEN ; IMMEDIATE
: IS ' >BODY STATE @ IF POSTPONE LITERAL POSTPONE ! ELSE ! THEN ; IMMEDIATE
: +TO ' >BODY STATE @ IF POSTPONE LITERAL POSTPONE +! ELSE +! THEN ; IMMEDIATE
: REVEAL SMUDGE ;
: COMPILE ' POSTPONE LITERAL POSTPONE COMPILE, ; IMMEDIATE
: (;CODE) R> LATEST 5 - ! ;
VECT EXIT-ASSEMBLER
VOCABULARY ASSEMBLER
S" lib/asm/486asm.f" INCLUDED
( FORTH HEADER CREATION WORDS )
ALSO ASSEMBLER ALSO ASM-HIDDEN
IN-HIDDEN
: _CODE ( START A NATIVE CODE DEFINITION )
CREATE CFL NEGATE ALLOT HIDE !CSP INIT-ASM ;
: _;CODE ( CREATE THE [;CODE] PART OF A LOW LEVEL DEFINING WORD )
?CSP !CSP COMPILE (;CODE) POSTPONE [ INIT-ASM ;
IN-FORTH
' _CODE IS CODE
' _;CODE IS ;CODE
: FCALL A; [COMPILE] ' COMPILE, ;
ONLY FORTH DEFINITIONS
ALSO FORTH IMMEDIATE PREVIOUS
S" lib/asm/asmmac.f" INCLUDED

60
programs/develop/SPForth/lib/ext/vocs.f Normal file
View File

@ -0,0 +1,60 @@
REQUIRE [DEFINED] lib/include/tools.f
\ Ðàñïå÷àòàòü ñïèñîê ñëîâàðåé.
: VOCS
VOC-LIST
BEGIN @ DUP WHILE
DUP CELL+ VOC-NAME.
DUP 3 CELLS + @ \ wid ïðåäêà
?DUP IF ." defined in " VOC-NAME.
ELSE ." is the main vocabulary"
THEN CR
REPEAT
DROP
;
0x200 VALUE MAX-WORD-SIZE
C" NEAR_NFA" FIND NIP 0=
[IF] : NEAR_NFA ( addr -- NFA addr | 0 addr ) DUP WordByAddr DROP 1- SWAP
2DUP 1000 - U< IF NIP 0 SWAP THEN ;
[THEN]
\ Opposite to CDR, might be slow!
\ It does not take wordlists into account.
: NextNFA ( nfa1 -- nfa2 | 0 )
NEAR_NFA SWAP >R
BEGIN
1+ NEAR_NFA ( nfa addr )
OVER 0 >
ROT R@ <> AND
OVER R@ - MAX-WORD-SIZE > OR
UNTIL
DUP R> - MAX-WORD-SIZE >
IF DROP 0
ELSE NEAR_NFA DROP
THEN
;
: NFAInVoc? ( nfa voc -- f )
@ \ last nfa
BEGIN ( nfa 'nfa )
DUP
WHILE
2DUP = IF 2DROP TRUE EXIT THEN
CDR
REPEAT 2DROP 0
;
: VocByNFA ( nfa -- wid | 0 )
VOC-LIST
BEGIN @ DUP WHILE ( nfa voc )
2DUP CELL+ NFAInVoc?
IF
NIP CELL+ EXIT
THEN
REPEAT
2DROP 0
;

81
programs/develop/SPForth/lib/include/core-ext.f Normal file
View File

@ -0,0 +1,81 @@
\ 94 CORE EXT
: .R ( n1 n2 -- ) \ 94 CORE EXT
\ Вывести на экран n1 выравненным вправо в поле шириной n2 символов.
\ Если число символов, необходимое для изображения n1, больше чем n2,
\ изображаются все цифры числа без ведущих пробелов в поле необходимой
\ ширины.
>R DUP >R ABS
S>D <# #S R> SIGN #>
R> OVER - 0 MAX SPACES TYPE
;
: 0> ( n -- flag ) \ 94 CORE EXT
\ flag "истина" тогда и только тогда, когда n больше нуля
0 >
;
: MARKER ( "<spaces>name" -- ) \ 94 CORE EXT
\ Пропустить ведущие пробелы. Выделить name, ограниченное пробелами.
\ Создать определение с семантикой выполнения, описанной ниже.
\ name Выполнение: ( -- )
\ Восстановить распределение памяти словаря и указатели порядка поиска
\ к состоянию, которое они имели перед определением name. Убрать
\ определение name и все последующие определения. Не требуется
\ обязательно восстанавливать любые оставшиеся структуры, которые
\ могут быть связаны с удаленными определениями или освобожденным
\ пространством данных. Никакая другая контекстуальная информация,
\ как основание системы счисления, не изменяется.
HERE
\ [C]HERE , [E]HERE ,
GET-CURRENT ,
GET-ORDER DUP , 0 ?DO DUP , @ , LOOP
CREATE ,
DOES> @ DUP \ ONLY
\ DUP @ [C]DP ! CELL+
\ DUP @ [E]DP ! CELL+
DUP @ SET-CURRENT CELL+
DUP @ >R R@ CELLS 2* + 1 CELLS - R@ 0
?DO DUP DUP @ SWAP CELL+ @ OVER ! SWAP 2 CELLS - LOOP
DROP R> SET-ORDER
DP !
;
: SAVE-INPUT ( -- xn ... x1 n ) \ 94 CORE EXT
\ x1 - xn описывают текущее состояние спецификаций входного потока для
\ последующего использования словом RESTORE-INPUT.
SOURCE-ID 0>
IF TIB #TIB @ 2DUP C/L 2 + ALLOCATE THROW DUP >R SWAP CMOVE
R> TO TIB >IN @
SOURCE-ID FILE-POSITION THROW
5
ELSE BLK @ >IN @ 2 THEN
;
: RESTORE-INPUT ( xn ... x1 n -- flag ) \ 94 CORE EXT
\ Попытка восстановить спецификации входного потока к состоянию,
\ описанному x1 - xn. flag "истина", если спецификации входного
\ потока не могут быть восстановлены.
\ Неопределенная ситуация возникает, если входной поток,
\ представленный аргументами не тот же, что и текущий входной поток.
SOURCE-ID 0>
IF DUP 5 <> IF 0 ?DO DROP LOOP -1 EXIT THEN
DROP SOURCE-ID REPOSITION-FILE ?DUP IF >R 2DROP DROP R> EXIT THEN
>IN ! #TIB ! TO TIB FALSE
ELSE DUP 2 <> IF 0 ?DO DROP LOOP -1 EXIT THEN
DROP >IN ! BLK ! FALSE
THEN
;
: U.R ( u n -- ) \ 94 CORE EXT
\ Вывести на экран u выравненным вправо в поле шириной n символов.
\ Если число символов, необходимое для изображения u, больше чем n,
\ изображаются все цифры числа без ведущих пробелов в поле необходимой
\ ширины.
>R U>D <# #S #>
R> OVER - 0 MAX SPACES TYPE
;
\EOF
: UNUSED ( -- u ) \ 94 CORE EXT
\ u - объем памяти, оставшейся в области, адресуемой HERE,
\ в байтах.
IMAGE-SIZE
HERE IMAGE-BASE - -
;

78
programs/develop/SPForth/lib/include/tools.f Normal file
View File

@ -0,0 +1,78 @@
\ 94 TOOLS
: .S ( -- ) \ 94 TOOLS
\ Скопировать и показать значения, находящиеся на стеке данных. Формат зависит
\ от реализации.
\ .S может быть реализовано с использованием слов форматного преобразования
\ чисел. Соответственно, он может испортить перемещаемую область,
\ идентифицируемую #>.
DEPTH .SN
;
: ? ( a-addr -- ) \ 94 TOOLS
\ Показать значение, хранящееся по адресу a-addr.
\ ? может быть реализован с использованием слов форматного преобразования
\ чисел. Соответственно, он может испортить перемещаемую область,
\ идентифицируемую #>.
@ .
;
: AHEAD \ 94 TOOLS EXT
\ Интерпретация: семантика неопределена.
\ Компиляция: ( C: -- orig )
\ Положить место неразрешенной ссылки вперед orig на стек управления.
\ Добавить семантику времени выполнения, данную ниже, к текущему определению.
\ Семантика незавершена до тех пор, пока orig не разрешится (например,
\ по THEN).
\ Время выполнения: ( -- )
\ Продолжить выполнение с позиции, заданной разрешением orig.
HERE BRANCH, >MARK 2
; IMMEDIATE
: [ELSE] \ 94 TOOLS EXT
\ Компиляция: Выполнить семантику выполнения, данную ниже.
\ Выполнение: ( "<spaces>name..." -- )
\ Пропустить ведущие пробелы, выделить и отбросить ограниченные пробелами
\ слова из разбираемой области, включая вложенные [IF]...[THEN] и
\ [IF]...[ELSE]...[THEN], до выделения и отбрасывания слова [THEN].
\ Если разбираемая область опустошается, она снова заполняется по REFILL.
\ [ELSE] - слово немедленного исполнения.
1
BEGIN
NextWord DUP
IF
2DUP S" [IF]" COMPARE 0= IF 2DROP 1+ ELSE
2DUP S" [ELSE]" COMPARE 0= IF 2DROP 1- DUP IF 1+ THEN ELSE
S" [THEN]" COMPARE 0= IF 1- THEN
THEN THEN
ELSE 2DROP REFILL AND \ SOURCE TYPE
THEN DUP 0=
UNTIL DROP ; IMMEDIATE
: [IF] \ 94 TOOLS EXT
\ Компиляция: Выполнить семантику выполнения, данную ниже.
\ Выполнение: ( flag | flag "<spaces>name..." -- )
\ Если флаг "истина", ничего не делать. Иначе, пропустив ведущие пробелы,
\ выделять и отбрасывать ограниченные пробелами слова из разбираемой области,
\ включая вложенные [IF]...[THEN] и [IF]...[ELSE]...[THEN], до тех пор, пока не
\ будет выделено и отброшено слово [ELSE] или [THEN].
\ Если разбираемая область опустошается, она снова заполняется по REFILL.
\ [ELSE] - слово немедленного исполнения.
0= IF POSTPONE [ELSE] THEN
; IMMEDIATE
: [THEN] \ 94 TOOLS EXT
\ Компиляция: Выполнить семантику выполнения, данную ниже.
\ Выполнение: ( -- )
\ Ничего не делать. [THEN] - слово немедленного исполнения.
; IMMEDIATE
\ Ruvim Pinka additions:
: [DEFINED] ( -- f ) \ "name"
NextWord SFIND IF DROP TRUE ELSE 2DROP FALSE THEN
; IMMEDIATE
: [UNDEFINED] ( -- f ) \ "name"
POSTPONE [DEFINED] 0=
; IMMEDIATE

1
programs/develop/SPForth/mbuild.bat Normal file
View File

@ -0,0 +1 @@
fasm.exe meforth.ASM

504
programs/develop/SPForth/meforth.ASM Normal file
View File

@ -0,0 +1,504 @@
; KolSPForth v12
SYSTEM equ EMUL
;Memory Map
;
;0
;0x02C7D ;I_END
;0x05430 ;CTOP
;0x3F800 ;Data stack
;0x3FA00 ;return stack
;0x3FC00 ;User
;0x3FE00 ;TIB
;0x30000 ;FILE BUFF
;0x40000 (256K)
;; Version control
VER EQU 1 ;major release version
EXT EQU 0 ;minor extension
;; Constants
TRUEE EQU -1 ;true flag
COMPO EQU 040H ;lexicon compile only bit
IMEDD EQU 080H ;lexicon immediate bit
MASKK EQU 01FH ;lexicon bit mask
CELLL EQU 4 ;size of a cell
BASEE EQU 10 ;default radix
VOCSS EQU 8 ;depth of vocabulary stack
BKSPP EQU 8 ;back space
LF EQU 10 ;line feed
CRR EQU 13 ;carriage return
ERR EQU 27 ;error escape
TIC EQU 39 ;tick
CALLL EQU 0E8H ;CALL opcodes
ROWH EQU 13
KEY_DELAY EQU 20
FW_WIDTH equ 500
FW_HEIGHT equ 352
;; Memory allocation
EM EQU 256*1024 ;top of memory
FILE_BS EQU 64*1024 ;file buff size
US EQU 128*CELLL ;user area size in cells
RTS EQU 1024*CELLL ;return stack/TIB size
FILE_B EQU EM-FILE_BS ;terminal input buffer (TIB)
TIBB EQU FILE_B-RTS ;terminal input buffer (TIB)
; UPP EQU TIBB-US ;start of user area (UP0)
RPP EQU UPP-RTS ;start of return stack (ESP0)
SPP EQU RPP-RTS ;start of data stack (EBP0)
LastNFA = 0
LastCFA EQU INIT
macro AHEADER FLAG,ID,F_CFA {
db FLAG
DD F_CFA
DD LastNFA
The_Nfa = $
DB ID,0
LastNFA = The_Nfa
F_CFA:
}
macro cfa_AHEADER FLAG,ID,F_CFA {
db FLAG
DD cfa_#F_CFA
DD LastNFA
The_Nfa = $
DB ID,0
LastNFA = The_Nfa
cfa_#F_CFA:
}
;; Main entry points and COLD start data
use32
org 0x0
db 'MENUET01' ; 8 byte id
dd 0x01 ; header version
dd ORIG ; start of code
dd I_END ; size of image
MEMS: dd EM ; memory for app
dd SPP ; esp
if SYSTEM eq MEOS
dd FINFO.path
else
dd 0
end if
dd 0x0 ; I_Param , I_Icon
lang fix ru
include 'MACROS.INC'
include "proc32.inc"
align 4
proc strncmp stdcall, s1:dword, s2:dword, n:dword
push esi
push edi
mov ecx, [n]
test ecx, ecx ; Max length is zero?
je .done
mov esi, [s1] ; esi = string s1
mov edi, [s2] ; edi = string s2
cld
.compare:
cmpsb ; Compare two bytes
jne .done
cmp byte [esi-1], 0 ; End of string?
je .done
dec ecx ; Length limit reached?
jne .compare
.done:
seta al ; al = (s1 > s2)
setb ah ; ah = (s1 < s2)
sub al, ah
movsx eax, al ; eax = (s1 > s2) - (s1 < s2), i.e. -1, 0, 1
pop edi
pop esi
ret
endp
align 4
proc GetPr stdcall, exp:dword, sz_name:dword
mov edx, [exp]
.next:
push edx
stdcall strncmp, edx, [sz_name], 16
pop edx
test eax, eax
jz .ok
mov edx, [edx-4]
test edx, edx
jnz .next
mov eax,edx
ret
.ok:
mov eax, [edx-8]
ret
endp
AHEADER 0 ,'GETPR',cfa_GETPR
JMP GetPr
ORIG:
MOV EBP,RPP ;initialize RP
CLD ;ESI gets incremented
finit
call draw_window
call calc_lines
XCHG ESP,EBP
CALL amain
BYE: mcall -1
ULAST: ; DD 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
draw_cursor:
draw_window:
pusha
mcall 12,1
mov [fRed],ebx
mcall 0, <0,FW_WIDTH>, <0,FW_HEIGHT>, 0x03000000, 0x805080D0, 0x005080D0
mcall 4, <8,8>, 0x10DDEEFF, header, header.size
mcall 9,pinfo,-1
mov eax,[pinfo.x_size]
cdq
sub eax,20
mov ebx,6
div ebx
mov [pinfo.x_start],eax
mov eax,[pinfo.y_size]
cdq
sub eax,40
mov ebx,ROWH
div ebx
mov [pinfo.y_start],eax
call erase_screen
mcall 12, 2
if ~ SYSTEM eq EMUL
mcall 67,-1,-1,FW_WIDTH,FW_HEIGHT
end if
popa
ret
lsz header,\
ru,'”®àâ ¤«ï MenuetOS (SPF)',\
en,'EXAMPLE APPLICATION',\
fr,"L'exemplaire programme"
erase_screen:
mov ebx,[pinfo.x_size]
add ebx,10 shl 16-20
mov ecx,[pinfo.y_size]
add ecx,30 shl 16-35
mcall 13,,,0;xff
ret
AHEADER 0,"CC_LINES",cfa_CC_LINES
calc_lines:
cmp dword[UPP+10*4],0
je .ex
pusha
mov ebp,os_work
mov al,0xd
mov edi,screen_buf
; mov esi,[cursor]
; mov byte[esi],'_'
; inc [cursor]
.again:
mov [ebp],edi
mov esi,[cursor]
sub esi,edi
mov ecx,[pinfo.x_start]
; test ecx,ecx
; jnz .no0
; inc ecx
; .no0:
cmp ecx,esi
jbe .ok
mov ecx,esi
.ok:
repne scasb
jecxz .nocrlf
cmp byte[edi],10
jne .nocrlf
inc edi
.nocrlf:
mov ecx,edi
sub ecx,[ebp]
add ebp,8
mov [ebp-4],ecx
cmp edi,[cursor]
jb .again
and dword[ebp],0
; dpd esi
mov eax,[pinfo.y_start]
shl eax,3
sub ebp,eax
cmp ebp,os_work
jae .ok2
mov ebp,os_work
.ok2:
cmp ebp,[last_ebp]
je .ok3
mov [last_ebp],ebp
call erase_screen
.ok3:
mov ebx,10 shl 16 +30
; ud2
.newl:
mcall 4,,0xffffff,[ebp],[ebp+4]
add ebp,8
add ebx,ROWH
cmp dword[ebp],0
jnz .newl
SUB ebx,ROWH
call set_cur
popa
.ex:
ret
set_cur:
MOV ecx,EBX
shl ecx,16
add ecx,EBX
MOV EAX,[ebp+4-8]
add EAX,2
imul EAX,6
mov EBX,EAX
shl ebx,16
add EBX,EAX
mov [lastcur],ecx
mov [lastcur+4],ebx
ret
e_calc_lines:
cmp dword[UPP+10*4],0
je e_.ex
pusha
mov ebp,os_work
mov al,0xd
mov edi,screen_buf
; mov esi,[cursor]
; mov byte[esi],'_'
; inc [cursor]
e_.again:
mov [ebp],edi
mov esi,[cursor]
sub esi,edi
mov ecx,[pinfo.x_start]
; test ecx,ecx
; jnz .no0
; inc ecx
; .no0:
cmp ecx,esi
jbe e_.ok
mov ecx,esi
e_.ok:
repne scasb
jecxz e_.nocrlf
cmp byte[edi],10
jne e_.nocrlf
inc edi
e_.nocrlf:
mov ecx,edi
sub ecx,[ebp]
add ebp,8
mov [ebp-4],ecx
cmp edi,[cursor]
jb e_.again
and dword[ebp],0
; dpd esi
mov eax,[pinfo.y_start]
shl eax,3
sub ebp,eax
cmp ebp,os_work
jae e_.ok2
mov ebp,os_work
e_.ok2:
cmp ebp,[last_ebp]
je e_.ok3
mov [last_ebp],ebp
cmp byte[edi],10
jne e_.ok3
call erase_screen
e_.ok3:
mov ebx,10 shl 16+30
; ud2
e_.newl:
; mcall 4,,0xffffff,[ebp],[ebp+4]
add ebp,8
add ebx,ROWH
cmp dword[ebp],0
jnz e_.newl
SUB ebx,ROWH
mcall 4,,0x00ffffff,[ebp-8],[ebp+4-8]
call set_cur
popa
e_.ex:
ret
AHEADER 0,"?KEY",cfa_queKEY
PUSH EDI
XCHG EBP,ESP
PUSH EAX
POP EBX
mov eax,10
test ebx,ebx
jz QRX0
inc eax
QRX0:
XOR ECX,ECX ;EBX=0 setup for false flag
mcall
cmp eax,1
jne QRX_
call draw_window
call calc_lines
QRX_:
cmp eax,3
je BYE
cmp eax,2
jne QRX3
mcall 2
QRX1: MOVZX ECX,AH
QRX2: PUSH ECX ;save character
QRX_TRUE:
MOV ECX,TRUEE ;true flag
QRX3: PUSH ECX
POP eax
XCHG EBP,ESP
POP EDI
ret
; ?RX ( -- c T | F )
; Return input character and true, or a false if no input.
AHEADER 0,"EMIT_N",cfa_EMIT_N
PUSH EDI
XCHG EBP,ESP
;char in AL
CMP AL,0FFH ;0FFH is interpreted as input
JNZ TX2 ;do NOT allow input
MOV AL,32 ;change to blank
TX2:
mov ebx,[cursor]
mov [ebx],AL
inc [cursor]
POP eax
XCHG EBP,ESP
POP EDI
RET
;; Basic I/O
cfa_AHEADER 0,'CL_CUR',CL_CUR
PUSH EAX
mcall 38,[lastcur+4],[lastcur],0
POP EAX
RET
cfa_AHEADER 0,'DR_CUR',DR_CUR
PUSH EAX
mcall 38,[lastcur+4],[lastcur],0x00FF00FF
POP EAX
RET
COLOR_ORDER equ MENUETOS
include 'gif_lite.inc'
cfa_AHEADER 0,'READ_GIF',READ_GIF ;( gif_ptr, out_ptr -- result )
push esi
push edi
push ebp
mov edi, eax
mov esi,[ebp]
mov eax,os_work
call ReadGIF
pop ebp
pop edi
pop esi
add ebp,4
RET
;===============================================================
cursor dd screen_buf
fRed dd 1
last_ebp dd 0
include 'amain.asm'
FINFO:
.mode dd 0
dd 0
.blk dd 1
.buf dd 0
.work dd os_work
.path:
if SYSTEM eq MEOS
; .path db 0
; .path db '/HD/1/FORTH/AUTORUN.DAT',0
; db '/RD/1/AUTOLOAD.F'
else
db '/RD/1/AUTOLOAD.F'
; db '/RD/1/EXAMPLE.F'
; db '/RD/1/PICTURE.F'
; db '/RD/1/AUTORUN.DAT'
; db '/HD/1/FORTH/AUTORUN.DAT'
end if
db 0
.end_path:
rb 256-($-.path)
lastcur dd 0,0
I_END:
squote_buf rb 1024
sys_v rd 6
screen_buf:
; sc_end:
rb 4096
pinfo process_information
os_work rb 16*1024
CTOP = $ ;next available memory in code dictionary
;=============================================================

41
programs/develop/SPForth/meforth_samples/autoload.f Normal file
View File

@ -0,0 +1,41 @@
VARIABLE wd 256 ALLOT
: setwd ( uaddr)
COUNT 1+ SWAP 1- SWAP wd SWAP CMOVE ;
: _wd
$" /rd/1/" setwd ; _wd
: "/ [CHAR] / ;
: strcat ( uaddr1 uaddr2 -- uaddr1+uaddr2)
>R DUP COUNT ( ua1 a1 c1)
>R R@ ( ua1 a1 c1)
+ OVER R> R@ SWAP >R ( ua1 ea1 ua1 ua1)
C@ R> + ( ua1 ea1 ua1 u+u2 )
SWAP C! ( ua1 ea1 )
R> COUNT ( ua1 ea1 a2 c2)
>R
SWAP R> CMOVE ;
: add/ ( uaddr -- uaddr/)
DUP DUP COUNT SWAP DROP + C@ "/ = IF ELSE $" /" strcat THEN ;
: cut/ ( uaddr -- uaddr w/o slash)
COUNT OVER SWAP + 1- ( ua1 lasta1)
DUP C@ "/ = IF 1- THEN .S
BEGIN 2DUP < WHILE 4 . DUP C@ "/ = IF OVER - OVER 1- C! 1- LEAVE ELSE 1- THEN
REPEAT ;
: t $" cat" $" dog" strcat COUNT TYPE ;
: makepath ( path normalizer: uaddr1 uaddr2 -- uaddr )
DUP 1+ C@ [CHAR] / = IF SWAP DROP ELSE DUP strcat THEN
add/ ;
: pwd ( print working directory: -- )
CR wd COUNT TYPE ;
: cd ( change directory)
wd BL WORD makepath setwd ;

15
programs/develop/SPForth/meforth_samples/autorun2.f Normal file
View File

@ -0,0 +1,15 @@
: >asciiz + 0 SWAP C! ;
: >path
finfo @ 20 + 0 finfo @ 8 + ! DUP >R SWAP DUP >R CMOVE R> R> SWAP >asciiz ;
: >param
OVER finfo @ 8 + ! >asciiz ;
: exec
16 finfo @ ! finfo @ 58 sys2 ." started, code=" . CR 5 sys2 DROP ;
S" /RD/1/GRSCREEN" >path 99 exec
S" /RD/1/@RB" >path 30 exec
S" /RD/1/@SS" >path 30 exec
S" /RD/1/@PANEL" >path 30 exec
S" /RD/1/SETUP" >path S" BOOT" >param 30 exec
S" /RD/1/ICON2" >path S" BOOT" >param 10 exec
S" /RD/1/board" >path 25 exec
BYE

53
programs/develop/SPForth/meforth_samples/example.f Normal file
View File

@ -0,0 +1,53 @@
DECIMAL
S" /rd/1/menuet.f" INCLUDED
: not_emit
emit_proc DUP @ NOT SWAP ! ;
new_reg wnd_size
CREATE Music $3090 , \ $90 C, $30 C, 0 C,
: my_wnd
12 ax 1 bx sysv DROP $805080D0 DUP $02AABBCC 200 50 << 200 DUP << 0
sys6 2 bx sysv 2DROP
$10DDEEFF $" <20><>ˆŒ…<EFBFBD> <20><EFBFBD>Žƒ<EFBFBD>€ŒŒ›" COUNT 8 DUP sys_print
0 $" <20> ¦¬¨â¥ «î¡ãî ª« ¢¨èã" COUNT 8 30 sys_print
$6688DD 1 5 12 << 200 19 - 12 << 8 sys5 DROP ;
: my_wnd_resize
200 dx 50 si 67 ax -1 DUP bx cx sysv DROP ;
: my_key
2 sys1 8 RSHIFT DUP 96 = IF not_emit DROP ELSE Music DUP si 1+ C!
55 DUP ax bx sysv DROP THEN ;
: my_btn
17 sys1 8 RSHIFT ." Pressed button #" DUP . CR 1 = IF BYE THEN ;
CREATE handlers ' my_wnd , ' my_key , ' my_btn ,
VARIABLE hnd
: msg_loop_console ( subs -- )
CR DUP hnd ! @EXECUTE my_wnd_resize
0 emit_proc !
BEGIN
10 sys1 ?DUP
IF
1-
CELLS hnd @ + @EXECUTE
emit_proc @
IF
WINDOW KEY 96 =
IF
not_emit hnd @ @EXECUTE my_wnd_resize
ELSE
EXIT
THEN
THEN
THEN
AGAIN ;
: new_me ( new main loop)
handlers msg_loop_console ;

34
programs/develop/SPForth/meforth_samples/locals.f Normal file
View File

@ -0,0 +1,34 @@
( ˆ§ <EFBFBD> à ­®¢ :
‘⥪ ¤ ­­ëå ª ª ã­¨¢¥àá «ì­®¥ á।á⢮ ¤«ï ¯¥à¥¤ ç¨ ¯ à ¬¥â஢ ¨ १ã«ìâ â®¢
¬¥¦¤ã ä®àâ-á«®¢ ¬¨ ¨¬¥¥â ­¥®á¯®à¨¬ë¥ ¯à¥¨¬ãé¥á⢠. ‚¬¥á⥠á ⥬ ¢­ãâà¨
®¯à¥¤¥«¥­¨ï ®­ ¨á¯®«ì§ã¥âáï ¤«ï ¯à®¬¥¦ãâ®ç­ëå ¢ëç¨á«¥­¨© ¨ à §¬¥é¥­¨ï §­ ç¥­¨©,
ª®â®àë¥ ¢ ­¨å ãç áâ¢ãîâ. <20>â® ¢ë§ë¢ ¥â ®¯à¥¤¥«¥­­ë¥ âà㤭®á⨠¤«ï ¤®áâ㯠 ª
â ª®¬ã «®ª «ì­®¬ã §­ ç¥­¨î, ¯®áª®«ìªã ¥£® ¯®«®¦¥­¨¥ ®â­®á¨â¥«ì­® ¢¥à設ë á⥪ 
¯®áâ®ï­­® ¬¥­ï¥âáï.
„«ï ã¯à®é¥­¨ï à ¡®âë ¦¥« â¥«ì­® § ªà¥¯¨âì §  «®ª «ì­ë¬ ®¡ê¥ªâ ¬¨ ¢­ãâà¨
®¯à¥¤¥«¥­¨ï ­¥ª®â®àë¥ ¯®áâ®ï­­ë¥ ¨¬¥­ , ç¥à¥§ ª®â®àë¥ ¨ ®áãé¥á⢫ïâì ¤®áâ㯠ª
­¨¬.
ˆ¬¥î騩áï ¢ ï§ëª¥ ¬¥å ­¨§¬ ®¯¨á ­¨ï ¯¥à¥¬¥­­ëå ¢ ¤ ­­®¬ á«ãç ¥ ­¥ ¯®¤å®¤¨â,
¯®áª®«ìªã ᮧ¤ ¥â £«®¡ «ì­ë¥ ¨¬¥­ , ⮣¤  ª ª âॡã¥âáï ¨¬¥­®¢ âì «®ª «ì­ë¥
®¡ê¥ªâë, ãç¨âë¢ ï ¯à¨ í⮬ ¢®§¬®¦­®áâì ४ãàᨢ­ëå ¢ë§®¢®¢. <EFBFBD>®áâ ¢«¥­­ãî § ¤ çã
à¥è ¥â ¢ª«î祭¨¥ ¢ à ¡®âã ¤®¯®«­¨â¥«ì­®£® á⥪ , ®â«¨ç­®£® ®â á⥪  ¤ ­­ëå.
‹®ª «ì­ë¥ §­ ç¥­¨ï à §¬¥é îâáï ¢ í⮬ á⥪¥ ¯à¨ ¢å®¤¥ ¢ ®¯à¥¤¥«¥­¨¥ ¨ 㡨à îâáï
¨§ ­¥£® ¯à¨ ¢ë室¥.
<20>  ¢á¥ ¢à¥¬ï ¨á¯®«­¥­¨ï ®¯à¥¤¥«¥­¨ï ¨å ¯®«®¦¥­¨¥ ®â­®á¨â¥«ì­® ¢¥à設ë á⥪ 
®áâ ¥âáï ¯®áâ®ï­­ë¬, íâ® ¯®§¢®«ï¥â ®à£ ­¨§®¢ âì ®ç¥­ì ¯à®á⮩ ¤®áâ㯠ª â ª¨¬
§­ ç¥­¨ï¬.
<20>à®á⥩è ï ­ ¤áâனª  ­ ¤ ï§ëª®¬ ”®àâ, ª®â®à ï ¯®§¢®«ï¥â à ¡®â âì á «®ª «ì­ë¬¨
¯¥à¥¬¥­­ë¬¨, ¢ë£«ï¤¨â â ª:)
100 ALLOT HERE CONSTANT LP0 ( <20>€—€‹Ž ‹ŽŠ.‘’…Š€)
VARIABLE LP ( ’…Š“™€Ÿ ‚…<EFBFBD>˜ˆ<EFBFBD>€ ‹ŽŠ€‹œ<EFBFBD>ŽƒŽ ‘’…Š€)
: INITLP ( ->) LP0 LP ! ; INITLP
: LOC ( N:‘—…’—ˆŠ->) 1+ CELLS LP @ OVER - DUP LP ! ! ;
: UNLOC ( ->) LP @ @ LP +! ;
: @@ ( N:‘Œ…™->) CREATE , DOES> ( PFA->A) @ CELLS LP @ + @ ;
: !! ( N:‘Œ…™->) CREATE , DOES> ( A,PFA->) @ CELLS LP @ + ! ;
1 @@ @1 2 @@ @2 3 @@ @3 4 @@ @4 5 @@ @5 ( ˆ ’.„.)
1 !! !1 2 !! !2 3 !! !3 4 !! !4 5 !! !5 ( ˆ ’.„.)

27
programs/develop/SPForth/meforth_samples/menuet.f Normal file
View File

@ -0,0 +1,27 @@
\ S" /rd/1/1st.4th" INCLUDED
S" /rd/1/locals.f" INCLUDED
\ : sys_wnd ( border, header, workarea, y, x -- )
\ 1 12 sys2 DROP 0 sys6 2 12 sys2 2DROP ;
\ : thread ( stack, entry -- )
\ 1 51 sys4 DROP ;
: >regs
reg_struc ! ;
: new_reg
CREATE 6 CELLS ALLOT LAST @ NAME> 9 + >regs ;
: ax reg_struc @ ! ;
: bx reg_struc @ 1 CELLS + ! ;
: cx reg_struc @ 2 CELLS + ! ;
: dx reg_struc @ 3 CELLS + ! ;
: si reg_struc @ 4 CELLS + ! ;
: di reg_struc @ 5 CELLS + ! ;
: << ( x,y -- x<<16+y )
SWAP 16 LSHIFT + ;
: sys_print ( color, stra, u, x, y -- )
<< >R SWAP ROT R> 4 sys5 DROP ;

109
programs/develop/SPForth/meforth_samples/picture.f Normal file
View File

@ -0,0 +1,109 @@
DECIMAL
S" /rd/1/menuet.f" INCLUDED
: not_emit
emit_proc DUP @ NOT SWAP ! ;
new_reg wnd_size
CREATE Music $3090 , \ $90 C, $30 C, 0 C,
73 CONSTANT img.width
22 CONSTANT img.height
CREATE raw img.width img.height * 3 * 16 + ALLOT
: my_wnd
12 ax 1 bx sysv DROP $805080D0 DUP $02AABBCC 200 150 << 200 DUP << 0
sys6 2 bx sysv 2DROP
$10DDEEFF $" <20><>ˆŒ…<EFBFBD> <20><EFBFBD>Žƒ<EFBFBD>€ŒŒ›" COUNT 8 DUP sys_print
0 $" <20> ¦¬¨â¥ «î¡ãî ª« ¢¨èã" COUNT 8 30 sys_print
$6688DD 1 5 12 << 200 19 - 12 << 8 sys5 DROP
30 DUP << img.width img.height << raw 12 + 7 sys4 ;
: my_wnd_resize
200 dx 50 si 67 ax -1 DUP bx cx sysv DROP ;
: my_key
2 sys1 8 RSHIFT DUP 96 = IF not_emit DROP ELSE Music DUP si 1+ C!
55 DUP ax bx sysv DROP THEN ;
: my_btn
17 sys1 8 RSHIFT ." Pressed button #" DUP . CR 1 = IF BYE THEN ;
CREATE handlers ' my_wnd , ' my_key , ' my_btn ,
VARIABLE hnd
: msg_loop_console ( subs -- )
CR DUP hnd ! @EXECUTE my_wnd_resize
0 emit_proc !
BEGIN
10 sys1 ?DUP
IF
1-
CELLS hnd @ + @EXECUTE
emit_proc @
IF
WINDOW KEY 96 =
IF
not_emit hnd @ @EXECUTE my_wnd_resize
ELSE
EXIT
THEN
THEN
THEN
AGAIN ;
CREATE gif 600 ALLOT
: new_me ( new main loop)
gif DUP $" /rd/1/Menu.gif" COUNT READ 2DROP
gif raw READ_GIF .
;
new_me handlers msg_loop_console WORDS
ABORT
: ENDOF ( orig1 #of -- orig2 #of )
>R ( ïåðåìåñòèòü ñî ñòåêà â ñëó÷àå, åñëè )
( ñòåê ïîòîêà óïðàâëåíèÿ ýòî ñòåê äàííûõ. )
POSTPONE ELSE
R> ( ìû äîëæíû òåïåðü âåðíóòü ñ÷åò÷èê íàçàä )
; IMMEDIATE
: ENDCASE ( orig1..orign #of -- )
POSTPONE DROP ( óäàëèòü case ïàðàìåòð )
0 ?DO
POSTPONE THEN
LOOP
; IMMEDIATE
[THEN]
: SS2 ( N ---> S:ÑÓÌÌÀ ÊÂÀÄÐÀÒÎÂ ÎÒ 1 ÄÎ N)
0 SWAP ( 0,N S[0]=0 )
1+ 1 ( S[0],N+1,1 )
DO I ( S[I-1],I )
DUP * + ( S[I] S[I]=S[I-1]+I*I)
LOOP ; ( S[N] )
5 SS2 . CR
: test 10 0 ?DO I . LEAVE LOOP 4 ;
test
: priem ( N:ÍÎÌÅÐ ÄÍß->) CASE
3 OF ." nepriemn" ENDOF
1 OF ." priemn" ENDOF
6 OF ." holiday" ENDOF
CR . ." - day #?" ABORT
( ENDCASE ) ." day" ;

268
programs/develop/SPForth/proc32.inc Normal file
View File

@ -0,0 +1,268 @@
; Macroinstructions for defining and calling procedures
macro stdcall proc,[arg] ; directly call STDCALL procedure
{ common
if ~ arg eq
reverse
pushd arg
common
end if
call proc }
macro invoke proc,[arg] ; indirectly call STDCALL procedure
{ common
if ~ arg eq
reverse
pushd arg
common
end if
call [proc] }
macro ccall proc,[arg] ; directly call CDECL procedure
{ common
size@ccall = 0
if ~ arg eq
reverse
pushd arg
size@ccall = size@ccall+4
common
end if
call proc
if size@ccall
add esp,size@ccall
end if }
macro cinvoke proc,[arg] ; indirectly call CDECL procedure
{ common
size@ccall = 0
if ~ arg eq
reverse
pushd arg
size@ccall = size@ccall+4
common
end if
call [proc]
if size@ccall
add esp,size@ccall
end if }
macro proc [args] ; define procedure
{ common
match name params, args>
\{ define@proc name,<params \} }
prologue@proc equ prologuedef
macro prologuedef procname,flag,parmbytes,localbytes,reglist
{ if parmbytes | localbytes
push ebp
mov ebp,esp
if localbytes
sub esp,localbytes
end if
end if
irps reg, reglist \{ push reg \} }
epilogue@proc equ epiloguedef
macro epiloguedef procname,flag,parmbytes,localbytes,reglist
{ irps reg, reglist \{ reverse pop reg \}
if parmbytes | localbytes
leave
end if
if (flag and 10000b) | (parmbytes=0)
retn
else
retn parmbytes
end if }
macro define@proc name,statement
{ local params,flag,regs,parmbytes,localbytes,current
if used name
name:
match =stdcall args, statement \{ params equ args
flag = 11b \}
match =stdcall, statement \{ params equ
flag = 11b \}
match =c args, statement \{ params equ args
flag = 10001b \}
match =c, statement \{ params equ
flag = 10001b \}
match =params, params \{ params equ statement
flag = 0 \}
virtual at ebp+8
match =uses reglist=,args, params \{ regs equ reglist
params equ args \}
match =regs =uses reglist, regs params \{ regs equ reglist
params equ \}
match =regs, regs \{ regs equ \}
match =,args, params \{ defargs@proc args \}
match =args@proc args, args@proc params \{ defargs@proc args \}
parmbytes = $ - (ebp+8)
end virtual
name # % = parmbytes/4
all@vars equ
current = 0
match prologue:reglist, prologue@proc:<regs> \{ prologue name,flag,parmbytes,localbytes,reglist \}
macro locals
\{ virtual at ebp-localbytes+current
macro label . \\{ deflocal@proc .,:, \\}
struc db [val] \\{ \common deflocal@proc .,db,val \\}
struc dw [val] \\{ \common deflocal@proc .,dw,val \\}
struc dp [val] \\{ \common deflocal@proc .,dp,val \\}
struc dd [val] \\{ \common deflocal@proc .,dd,val \\}
struc dt [val] \\{ \common deflocal@proc .,dt,val \\}
struc dq [val] \\{ \common deflocal@proc .,dq,val \\}
struc rb cnt \\{ deflocal@proc .,rb cnt, \\}
struc rw cnt \\{ deflocal@proc .,rw cnt, \\}
struc rp cnt \\{ deflocal@proc .,rp cnt, \\}
struc rd cnt \\{ deflocal@proc .,rd cnt, \\}
struc rt cnt \\{ deflocal@proc .,rt cnt, \\}
struc rq cnt \\{ deflocal@proc .,rq cnt, \\} \}
macro endl
\{ purge label
restruc db,dw,dp,dd,dt,dq
restruc rb,rw,rp,rd,rt,rq
restruc byte,word,dword,pword,tword,qword
current = $-(ebp-localbytes)
end virtual \}
macro ret operand
\{ match any, operand \\{ retn operand \\}
match , operand \\{ match epilogue:reglist, epilogue@proc:<regs>
\\\{ epilogue name,flag,parmbytes,localbytes,reglist \\\} \\} \}
macro finish@proc \{ localbytes = (((current-1) shr 2)+1) shl 2
end if \} }
macro defargs@proc [arg]
{ common
if ~ arg eq
forward
local ..arg,current@arg
match argname:type, arg
\{ current@arg equ argname
label ..arg type
argname equ ..arg
if dqword eq type
dd ?,?,?,?
else if tbyte eq type
dd ?,?,?
else if qword eq type | pword eq type
dd ?,?
else
dd ?
end if \}
match =current@arg,current@arg
\{ current@arg equ arg
arg equ ..arg
..arg dd ? \}
common
args@proc equ current@arg
forward
restore current@arg
common
end if }
macro deflocal@proc name,def,[val]
{ common
match vars, all@vars \{ all@vars equ all@vars, \}
all@vars equ all@vars name
forward
local ..var,..tmp
..var def val
match =?, val \{ ..tmp equ \}
match any =dup (=?), val \{ ..tmp equ \}
match tmp : value, ..tmp : val
\{ tmp: end virtual
initlocal@proc ..var,def value
virtual at tmp\}
common
match first rest, ..var, \{ name equ first \} }
macro initlocal@proc name,def
{ virtual at name
def
size@initlocal = $ - name
end virtual
position@initlocal = 0
while size@initlocal > position@initlocal
virtual at name
def
if size@initlocal - position@initlocal < 2
current@initlocal = 1
load byte@initlocal byte from name+position@initlocal
else if size@initlocal - position@initlocal < 4
current@initlocal = 2
load word@initlocal word from name+position@initlocal
else
current@initlocal = 4
load dword@initlocal dword from name+position@initlocal
end if
end virtual
if current@initlocal = 1
mov byte [name+position@initlocal],byte@initlocal
else if current@initlocal = 2
mov word [name+position@initlocal],word@initlocal
else
mov dword [name+position@initlocal],dword@initlocal
end if
position@initlocal = position@initlocal + current@initlocal
end while }
macro endp
{ purge ret,locals,endl
finish@proc
purge finish@proc
restore regs@proc
match all,args@proc \{ restore all \}
restore args@proc
match all,all@vars \{ restore all \} }
macro local [var]
{ common
locals
forward done@local equ
match varname[count]:vartype, var
\{ match =BYTE, vartype \\{ varname rb count
restore done@local \\}
match =WORD, vartype \\{ varname rw count
restore done@local \\}
match =DWORD, vartype \\{ varname rd count
restore done@local \\}
match =PWORD, vartype \\{ varname rp count
restore done@local \\}
match =QWORD, vartype \\{ varname rq count
restore done@local \\}
match =TBYTE, vartype \\{ varname rt count
restore done@local \\}
match =DQWORD, vartype \\{ label varname dqword
rq count+count
restore done@local \\}
match , done@local \\{ virtual
varname vartype
end virtual
rb count*sizeof.\#vartype
restore done@local \\} \}
match :varname:vartype, done@local:var
\{ match =BYTE, vartype \\{ varname db ?
restore done@local \\}
match =WORD, vartype \\{ varname dw ?
restore done@local \\}
match =DWORD, vartype \\{ varname dd ?
restore done@local \\}
match =PWORD, vartype \\{ varname dp ?
restore done@local \\}
match =QWORD, vartype \\{ varname dq ?
restore done@local \\}
match =TBYTE, vartype \\{ varname dt ?
restore done@local \\}
match =DQWORD, vartype \\{ label varname dqword
dq ?,?
restore done@local \\}
match , done@local \\{ varname vartype
restore done@local \\} \}
match ,done@local
\{ var
restore done@local \}
common
endl }

91
programs/develop/SPForth/src/KOL/spf_kol_con_io.f Normal file
View File

@ -0,0 +1,91 @@
( Š®­á®«ì­ë© ¢¢®¤-¢ë¢®¤.
)
: NMNM 0 IF THEN ;
: ACCEPT0 ( c-addr +n1 -- +n2 ) \ 94
\ ‚¢¥á⨠áâப㠬 ªá¨¬ «ì­®© ¤«¨­ë ¤® +n1 ᨬ¢®«®¢.
\ ˆáª«îç¨â¥«ì­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ +n1 0 ¨«¨ ¡®«ìè¥ 32767.
\ Žâ®¡à ¦ âì ᨬ¢®«ë ¯® ¬¥à¥ ¢¢®¤ .
\ ‚¢®¤ ¯à¥à뢠¥âáï, ª®£¤  ¯®«ã祭 ᨬ¢®« "ª®­¥æ áâப¨".
\ <20>¨ç¥£® ­¥ ¤®¡ ¢«ï¥âáï ¢ áâபã.
\ +n2 - ¤«¨­  áâப¨, § ¯¨á ­­®© ¯®  ¤à¥áã c-addr.
OVER + 1- OVER \ SA EA A
NMNM
BEGIN KEY \ SA EA A C
\ ." {" DUP H. ." }"
DUP 10 = OVER 13 = OR 0=
WHILE
DUP 0x1B = IF DROP DUP C@ EMIT ELSE
DUP 8 = IF EMIT BL EMIT 8 EMIT
2- >R OVER 1- R> UMAX ELSE
DUP 9 = IF DROP DUP 8 BLANK
>R OVER R> \ SA EA SA A
SWAP OVER - \ SA EA SA A-SA
8 / 1+ 8 * + ELSE DUP EMIT OVER C!
THEN THEN
THEN 1+ OVER UMIN \ SA EA A
REPEAT \ HEX CR DEPTH .SN
\ SA EA A C
DROP NIP - NEGATE ;
VECT ACCEPT
' ACCEPT0 TO ACCEPT
: TYPE_M ( c-addr1 u --- )
\ Output the string starting at c-addr and length u to the terminal.
OVER + SWAP BEGIN 2DUP - WHILE DUP C@ EMIT_N CHAR+ REPEAT
CC_LINES
2DROP
;
: _TYPE ( c-addr1 u --- )
\ Output the string starting at c-addr and length u to the terminal.
2DUP SCR_BUF AT-XY? 80 * + + SWAP CMOVE
SCR_TYPE
;
\ : ZTYPE ( ADDR -- )
\ DUP >R LZTYPE DROP RDROP ;
: _CR ( -- ) \ 94
\ <20>¥à¥¢®¤ áâப¨.
13 EMIT
;
VECT CR ' _CR TO CR
: _EMIT ( x -- ) \ 94
\ …᫨ x - ¨§®¡à ¦ ¥¬ë© ᨬ¢®«, ¢ë¢¥á⨠¥£® ­  ¤¨á¯«¥©.
\ DUP SCR_BUF AT-XY? 80 * + + C!
DUP 0xD = IF DROP SCR_CR EXIT THEN
DUP 0x8 = IF DROP 0x00800000
&AT-XY W@ 0xD * 0x15 + 16 LSHIFT 0xB OR
&AT-XY 2+ W@ 0x6 * 16 LSHIFT 6 OR
13 SYS4 DROP
AT-XY? >R 1- R> AT-XY
EXIT THEN
>R RP@ 1 _TYPE RDROP
;
: SWITCH_CHAR ( c1 -- c2 )
DUP [CHAR] a [CHAR] z 1+ WITHIN
OVER [CHAR] A [CHAR] Z 1+ WITHIN OR
IF 32 XOR THEN
;
: KEY_M DR_CUR BEGIN 0 ?KEY UNTIL CL_CUR SWITCH_CHAR ;
: _KEY
CORSOR_DROW
BEGIN KEY? UNTIL &KEY C@ &KEY 0! SWITCH_CHAR
;
: PAGE
draw_window
SCR_BUF SCR_WIDTH SCR_HEIGHT * BLANK
0 0 AT-XY
DRAW_LINS
;

21
programs/develop/SPForth/src/KOL/spf_kol_const.f Normal file
View File

@ -0,0 +1,21 @@
( Windows-ª®­áâ ­âë, ­¥®¡å®¤¨¬ë¥ ¯à¨ ¢/¢.
)
0x80000000 CONSTANT R/O ( -- fam ) \ 94 FILE
\ fam - ®¯à¥¤¥«¥­­®¥ ॠ«¨§ æ¨¥© §­ ç¥­¨¥ ¤«ï ¢ë¡®à  ¬¥â®¤  ¤®áâ㯠
\ ª ä ©«ã "⮫쪮 ¤«ï ç⥭¨ï"
0x40000000 CONSTANT W/O ( -- fam ) \ 94 FILE
\ fam - ®¯à¥¤¥«¥­­®¥ ॠ«¨§ æ¨¥© §­ ç¥­¨¥ ¤«ï ¢ë¡®à  ¬¥â®¤  ¤®áâ㯠
\ ª ä ©«ã "⮫쪮 ¤«ï § ¯¨á¨"
0xC0000000 CONSTANT R/W ( -- fam ) \ 94 FILE
\ fam - ®¯à¥¤¥«¥­­®¥ ॠ«¨§ æ¨¥© §­ ç¥­¨¥ ¤«ï ¢ë¡®à  ¬¥â®¤  ¤®áâ㯠
\ ª ä ©«ã "ç⥭¨¥/§ ¯¨áì"
DECIMAL
\ 7 CONSTANT ZZZ

139
programs/develop/SPForth/src/KOL/spf_kol_io.f Normal file
View File

@ -0,0 +1,139 @@
( ” ©«®¢ë© ¢¢®¤-¢ë¢®¤.
)
CREATE LT 0xD C, 0xA C, 0xD C, 0xA C, \ line terminator
CREATE LTL 2 , \ line terminator length
: DOS-LINES ( -- )
0xA0D LT ! 2 LTL !
;
: UNIX-LINES ( -- )
0xA0A LT ! 1 LTL !
;
: READ-FILE ( c-addr u1 fileid -- u2 ior ) \ 94 FILE
\ <20>à®ç¥áâì u1 ᨬ¢®«®¢ ¢ c-addr ¨§ ⥪ã饩 ¯®§¨æ¨¨ ä ©« ,
\ ¨¤¥­â¨ä¨æ¨à㥬®£® fileid.
\ …᫨ u1 ᨬ¢®«®¢ ¯à®ç¨â ­® ¡¥§ ¨áª«î祭¨©, ior ­®«ì ¨ u2 à ¢¥­ u1.
\ …᫨ ª®­¥æ ä ©«  ¤®á⨣­ãâ ¤® ¯à®ç⥭¨ï u1 ᨬ¢®«®¢, ior ­®«ì
\ ¨ u2 - ª®«¨ç¥á⢮ ॠ«ì­® ¯à®ç¨â ­­ëå ᨬ¢®«®¢.
\ …᫨ ®¯¥à æ¨ï ¯à®¨§¢®¤¨âáï ª®£¤  §­ ç¥­¨¥, ¢®§¢à é ¥¬®¥
\ FILE-POSITION à ¢­® §­ ç¥­¨î, ¢®§¢à é ¥¬®¬ã FILE-SIZE ¤«ï ä ©« 
\ ¨¤¥­â¨ä¨æ¨à㥬®£® fileid, ior ¨ u2 ­ã«¨.
\ …᫨ ¢®§­¨ª«  ¨áª«îç¨â¥«ì­ ï á¨âã æ¨ï, â® ior - ®¯à¥¤¥«¥­­ë© ॠ«¨§ æ¨¥©
\ ª®¤ १ã«ìâ â  ¢¢®¤ /¢ë¢®¤ , ¨ u2 - ª®«¨ç¥á⢮ ­®à¬ «ì­® ¯¥à¥¤ ­­ëå ¢
\ c-addr ᨬ¢®«®¢.
\ <20>¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ ®¯¥à æ¨ï ¢ë¯®«­ï¥âáï, ª®£¤ 
\ §­ ç¥­¨¥, ¢®§¢à é ¥¬®¥ FILE-POSITION ¡®«ìè¥ ç¥¬ §­ ç¥­¨¥, ¢®§¢à é ¥¬®¥
\ FILE-SIZE ¤«ï ä ©« , ¨¤¥­â¨ä¨æ¨à㥬®£® fileid, ¨«¨ âॡ㥬 ï ®¯¥à æ¨ï
\ ¯ëâ ¥âáï ¯à®ç¥áâì ­¥§ ¯¨á ­­ãî ç áâì ä ©« .
\ <20>®á«¥ § ¢¥à襭¨ï ®¯¥à æ¨¨ FILE-POSITION ¢®§¢à â¨â á«¥¤ãîéãî ¯®§¨æ¨î
\ ¢ ä ©«¥ ¯®á«¥ ¯®á«¥¤­¥£® ¯à®ç¨â ­­®£® ᨬ¢®« .
DUP >R .CODE 0!
R@ .SIZE !
R@ .DATA !
R@ 70 SYS2
EBX@ SWAP
DUP 6 = IF DROP 0 THEN
DUP 0=
IF R@ .FIRST D@
R@ .SIZE @ 0 D+
R@ .FIRST D!
THEN
RDROP
;
22 CONSTANT MAX_OPEN_FILES
CREATE FILE_STR_BUF FILE_STR 1+ MAX_OPEN_FILES * ALLOT
: FALLOC ( -- 0|fid )
FILE_STR_BUF FILE_STR MAX_OPEN_FILES * BOUNDS
BEGIN DUP .NAME @ 0=
IF NIP EXIT THEN
FILE_STR + 2DUP U<
UNTIL 2DROP 0
;
: OPEN-FILE ( c-addr u fam -- fileid ior )
\ Žâªàëâì ä ©« á ¨¬¥­¥¬, § ¤ ­­ë¬ áâப®© c-addr u, á ¬¥â®¤®¬ ¤®áâ㯠 fam.
\ ‘¬ëá« §­ ç¥­¨ï fam ®¯à¥¤¥«¥­ ॠ«¨§ æ¨¥©.
\ …᫨ ä ©« ãᯥ譮 ®âªàëâ, ior ­®«ì, fileid ¥£® ¨¤¥­â¨ä¨ª â®à, ¨ ä ©«
\ ¯®§¨æ¨®­¨à®¢ ­ ­  ­ ç «®.
\ ˆ­ ç¥ ior - ®¯à¥¤¥«¥­­ë© ॠ«¨§ æ¨¥© ª®¤ १ã«ìâ â  ¢¢®¤ /¢ë¢®¤ ,
\ ¨ fileid ­¥®¯à¥¤¥«¥­.
DROP
\ FILE_STR
FALLOC DUP
IF
>R
R@ FILE_STR ERASE
R@ .NAME SWAP MOVE
R> 0 EXIT
THEN -1
;
: CLOSE-FILE ( fileid -- ior ) \ 94 FILE
\ ‡ ªàëâì ä ©«, § ¤ ­­ë© fileid.
.NAME 0! 0
;
USER _fp1
USER _fp2
USER _addr
: READ-LINE ( c-addr u1 fileid -- u2 flag ior ) \ 94 FILE
\ <20>à®ç¥áâì á«¥¤ãîéãî áâப㠨§ ä ©« , § ¤ ­­®£® fileid, ¢ ¯ ¬ïâì
\ ¯®  ¤à¥áã c-addr. —¨â ¥âáï ­¥ ¡®«ìè¥ u1 ᨬ¢®«®¢. „® ¤¢ãå
\ ®¯à¥¤¥«¥­­ëå ॠ«¨§ æ¨¥© ᨬ¢®«®¢ "ª®­¥æ áâப¨" ¬®£ãâ ¡ëâì
\ ¯à®ç¨â ­ë ¢ ¯ ¬ïâì §  ª®­æ®¬ áâப¨, ­® ­¥ ¢ª«îç¥­ë ¢ áç¥â稪 u2.
\ <20>ãä¥à áâப¨ c-addr ¤®«¦¥­ ¨¬¥âì à §¬¥à ª ª ¬¨­¨¬ã¬ u1+2 ᨬ¢®« .
\ …᫨ ®¯¥à æ¨ï ãᯥ譠, flag "¨á⨭ " ¨ ior ­®«ì. …᫨ ª®­¥æ áâப¨
\ ¯®«ã祭 ¤® ⮣® ª ª ¯à®ç¨â ­ë u1 ᨬ¢®«®¢, â® u2 - ç¨á«® ॠ«ì­®
\ ¯à®ç¨â ­­ëå ᨬ¢®«®¢ (0<=u2<=u1), ­¥ áç¨â ï ᨬ¢®«®¢ "ª®­¥æ áâப¨".
\ Š®£¤  u1=u2 ª®­¥æ áâப¨ 㦥 ¯®«ã祭.
\ …᫨ ®¯¥à æ¨ï ¯à®¨§¢®¤¨âáï, ª®£¤  §­ ç¥­¨¥, ¢®§¢à é ¥¬®¥
\ FILE-POSITION à ¢­® §­ ç¥­¨î, ¢®§¢à é ¥¬®¬ã FILE-SIZE ¤«ï ä ©« ,
\ ¨¤¥­â¨ä¨æ¨à㥬®£® fileid, flag "«®¦ì", ior ­®«ì, ¨ u2 ­®«ì.
\ …᫨ ior ­¥ ­®«ì, â® ¯à®¨§®è«  ¨áª«îç¨â¥«ì­ ï á¨âã æ¨ï ¨ ior -
\ ®¯à¥¤¥«¥­­ë© ॠ«¨§ æ¨¥© ª®¤ १ã«ìâ â  ¢¢®¤ -¢ë¢®¤ .
\ <20>¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ ®¯¥à æ¨ï ¢ë¯®«­ï¥âáï, ª®£¤ 
\ §­ ç¥­¨¥, ¢®§¢à é ¥¬®¥ FILE-POSITION ¡®«ìè¥ ç¥¬ §­ ç¥­¨¥, ¢®§¢à é ¥¬®¥
\ FILE-SIZE ¤«ï ä ©« , ¨¤¥­â¨ä¨æ¨à㥬®£® fileid, ¨«¨ âॡ㥬 ï ®¯¥à æ¨ï
\ ¯ëâ ¥âáï ¯à®ç¥áâì ­¥§ ¯¨á ­­ãî ç áâì ä ©« .
\ <20>®á«¥ § ¢¥à襭¨ï ®¯¥à æ¨¨ FILE-POSITION ¢®§¢à â¨â á«¥¤ãîéãî ¯®§¨æ¨î
\ ¢ ä ©«¥ ¯®á«¥ ¯®á«¥¤­¥£® ¯à®ç¨â ­­®£® ᨬ¢®« .
DUP >R
FILE-POSITION IF 2DROP 0 0 THEN _fp1 ! _fp2 !
1+
OVER _addr !
R@ READ-FILE ?DUP IF NIP RDROP 0 0 ROT EXIT THEN
DUP >R 0= IF RDROP RDROP 0 0 0 EXIT THEN \ ¡ë«¨ ¢ ª®­æ¥ ä ©« 
_addr @ R@ LT 1+ 1 SEARCH
IF \ ­ ©¤¥­ à §¤¥«¨â¥«ì áâப
DROP _addr @ -
DUP 1+ S>D _fp2 @ _fp1 @ D+ RDROP R> REPOSITION-FILE DROP
DUP _addr @ + 1- C@ 0xD = IF 1- THEN
ELSE \ ­¥ ­ ©¤¥­ à §¤¥«¨â¥«ì áâப
2DROP
R> RDROP \ ¥á«¨ áâப  ¯à®ç¨â ­  ­¥ ¯®«­®áâìî - ¡ã¤¥â ࠧ१ ­ 
THEN
TRUE 0
;
: FILE-POSITION ( fileid -- ud ior ) \ 94 FILE
\ ud - ⥪ãé ï ¯®§¨æ¨ï ¢ ä ©«¥, ¨¤¥­â¨ä¨æ¨à㥬®¬ fileid.
.FIRST D@ 0
;
: REPOSITION-FILE ( ud fileid -- ior ) \ 94 FILE
\ <20>¥à¥¯®§¨æ¨®­¨à®¢ âì ä ©«, ¨¤¥­â¨ä¨æ¨àã¥¬ë© fileid, ­  ud.
.FIRST D! 0
;

66
programs/develop/SPForth/src/KOL/spf_kol_memory.f Normal file
View File

@ -0,0 +1,66 @@
( “¯à ¢«¥­¨¥ ¯ ¬ïâìî.
Windows-§ ¢¨á¨¬ë¥ á«®¢ .
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
<20>¥¢¨§¨ï - ᥭâï¡àì 1999
)
\ 94 MEMORY
USER THREAD-HEAP \ åí­¤« 娯  ⥪ã饣® ¯®â®ª 
\ VARIABLE USER-OFFS \ ᬥ饭¨¥ ¢ ®¡« á⨠¤ ­­ëå ¯®â®ª ,
\ £¤¥ ᮧ¤ îâáï ­®¢ë¥ ¯¥à¥¬¥­­ë¥
: ERR
\ IF 0 ELSE DUP GetLastError THEN
;
: USER-ALLOT ( n -- )
USER-OFFS +!
\ ¢ë஢­ï¥¬ ¢ USER-CREATE ~day
\ USER-OFFS @ + \ á ­ ç «  ¯à¨¡ ¢«ï¥¬
\ CELL 1- + [ CELL NEGATE ] LITERAL AND \ ¯®â®¬ ¢ëà ¢­¨¢ ¥¬
\ USER-OFFS !
;
: USER-HERE ( -- n )
USER-OFFS @
;
: ALLOCATE ( u -- a-addr ior ) \ 94 MEMORY
\ <20> á¯à¥¤¥«¨âì u ¡ ©â ­¥¯à¥à뢭®£® ¯à®áâà ­á⢠ ¤ ­­ëå. “ª § â¥«ì ¯à®áâà ­á⢠
\ ¤ ­­ëå ­¥ ¨§¬¥­ï¥âáï í⮩ ®¯¥à æ¨¥©. <20>¥à¢®­ ç «ì­®¥ ᮤ¥à¦¨¬®¥ ¢ë¤¥«¥­­®£®
\ ãç á⪠ ¯ ¬ï⨠­¥®¯à¥¤¥«¥­®.
\ …᫨ à á¯à¥¤¥«¥­¨¥ ãᯥ譮, a-addr - ¢ë஢­¥­­ë©  ¤à¥á ­ ç «  à á¯à¥¤¥«¥­­®©
\ ®¡« á⨠¨ ior ­®«ì.
\ …᫨ ®¯¥à æ¨ï ­¥ ¯à®è« , a-addr ­¥ ¯à¥¤áâ ¢«ï¥â ¯à ¢¨«ì­ë©  ¤à¥á ¨ ior -
\ § ¢¨áï騩 ®â ॠ«¨§ æ¨¨ ª®¤ ¢¢®¤ -¢ë¢®¤ .
5 68 SYS3 0 ;
: FREE ( a-addr -- ior ) \ 94 MEMORY
\ ‚¥à­ãâì ­¥¯à¥à뢭ãî ®¡« áâì ¯à®áâà ­á⢠ ¤ ­­ëå, ¨­¤¨æ¨à㥬ãî a-addr, á¨á⥬¥
\ ¤«ï ¤ «ì­¥©è¥£® à á¯à¥¤¥«¥­¨ï. a-addr ¤®«¦¥­ ¨­¤¨æ¨à®¢ âì ®¡« áâì
\ ¯à®áâà ­á⢠ ¤ ­­ëå, ª®â®à ï à ­¥¥ ¡ë«  ¯®«ã祭  ¯® ALLOCATE ¨«¨ RESIZE.
\ “ª § â¥«ì ¯à®áâà ­á⢠ ¤ ­­ëå ­¥ ¨§¬¥­ï¥âáï ¤ ­­®© ®¯¥à æ¨¥©.
\ …᫨ ®¯¥à æ¨ï ãᯥ譠, ior ­®«ì. …᫨ ®¯¥à æ¨ï ­¥ ¯à®è« , ior - § ¢¨áï騩 ®â
\ ॠ«¨§ æ¨¨ ª®¤ ¢¢®¤ -¢ë¢®¤ .
5 68 SYS3 DROP 0 ;
: RESIZE ( a-addr1 u -- a-addr2 ior ) \ 94 MEMORY
\ ˆ§¬¥­¨âì à á¯à¥¤¥«¥­¨¥ ­¥¯à¥à뢭®£® ¯à®áâà ­á⢠ ¤ ­­ëå, ­ ç¨­ î饣®áï á
\  ¤à¥á  a-addr1, à ­¥¥ à á¯à¥¤¥«¥­­®£® ¯® ALLOCATE ¨«¨ RESIZE, ­  u ¡ ©â.
\ u ¬®¦¥â ¡ëâì ¡®«ìè¥ ¨«¨ ¬¥­ìè¥, 祬 ⥪ã騩 à §¬¥à ®¡« áâ¨.
\ “ª § â¥«ì ¯à®áâà ­á⢠ ¤ ­­ëå ­¥ ¨§¬¥­ï¥âáï ¤ ­­®© ®¯¥à æ¨¥©.
\ …᫨ ®¯¥à æ¨ï ãᯥ譠, a-addr2 - ¢ë஢­¥­­ë©  ¤à¥á ­ ç «  u ¡ ©â
\ à á¯à¥¤¥«¥­­®© ¯ ¬ï⨠¨ ior ­®«ì. a-addr2 ¬®¦¥â, ­® ­¥ ¤®«¦¥­, ¡ëâì ⥬ ¦¥
\ á ¬ë¬, çâ® ¨ a-addr1. …᫨ ®­¨ ­¥®¤¨­ ª®¢ë, §­ ç¥­¨ï, ᮤ¥à¦ é¨¥áï ¢ ®¡« áâ¨
\ a-addr1, ª®¯¨àãîâáï ¢ a-addr2 ¢ ª®«¨ç¥á⢥ ¬¨­¨¬ «ì­®£® ¨§ à §¬¥à®¢ íâ¨å
\ ¤¢ãå ®¡« á⥩. …᫨ ®­¨ ®¤¨­ ª®¢ë, §­ ç¥­¨ï, ᮤ¥à¦ é¨¥áï ¢ ®¡« áâ¨,
\ á®åà ­ïîâáï ¤® ¬¨­¨¬ «ì­®£® ¨§ u ¨«¨ ¯¥à¢®­ ç «ì­®£® à §¬¥à . …᫨ a-addr2 ­¥
\ â®â ¦¥, çâ® ¨ a-addr1, ®¡« áâì ¯ ¬ï⨠¯® a-addr1 ¢®§¢à é ¥âáï á¨á⥬¥
\ ᮣ« á­® ®¯¥à æ¨¨ FREE.
\ …᫨ ®¯¥à æ¨ï ­¥ ¯à®è« , a-addr2 à ¢¥­ a-addr1, ®¡« áâì ¯ ¬ï⨠a-addr1 ­¥
\ ¨§¬¥­ï¥âáï, ¨ ior - § ¢¨áï騩 ®â ॠ«¨§ æ¨¨ ª®¤ ¢¢®¤ -¢ë¢®¤ .
THROW ABORT" RESIZE is't in system"
;

40
programs/develop/SPForth/src/KOL/spf_kol_module.f Normal file
View File

@ -0,0 +1,40 @@
: is_path_delimiter ( c -- flag )
DUP [CHAR] \ = SWAP [CHAR] / = OR
;
: CUT-PATH ( a u -- a u1 )
\ èç ñòðîêè "path\name" âûäåëèòü ñòðîêó "path\"
OVER +
BEGIN 2DUP <> WHILE DUP C@ is_path_delimiter 0= WHILE 1- REPEAT 1+ THEN
\ DUP 0! \ ~ruv (to anfilat): íå äÎëæíî òóò çàòèðàòü ïîäàííûé áóôåð!
OVER -
;
: ModuleName ( -- addr u )
ABORT
;
: ModuleDirName ( -- addr u )
ModuleName CUT-PATH
;
: +ModuleDirName ( addr u -- addr2 u2 )
2>R
ModuleDirName 2DUP +
2R> DUP >R ROT SWAP 1+ MOVE
R> +
;
: +LibraryDirName ( addr u -- addr2 u2 )
\ Äîáàâèòü addr u ê ïîëíûé_ïóòü_ïðèëîæåíèÿ+devel\
2>R
ModuleDirName 2DUP +
S" devel\" ROT SWAP MOVE
6 + 2DUP +
2R> DUP >R ROT SWAP 1+ MOVE
R> +
;
: SOURCE-NAME ( -- a u )
CURFILE @ DUP IF ASCIIZ> ELSE 0 THEN
;

159
programs/develop/SPForth/src/KOL/spf_kol_module.f_L Normal file
View File

@ -0,0 +1,159 @@
ZZ=D4
: is_path_delimiter ( c -- flag )
5A380F 30 38 5A 00 00 11 69 73 5F 70 61 74 68 5F 64 65 08Z...is_path_de
5A381F 6C 69 6D 69 74 65 72 75 37 5A 00 00 00 00 00 00 limiteru7Z......
5A382F 00 .
DUP [CHAR] \ = SWAP [CHAR] / = OR
5A3830 89 45 FC 89 45 F8 B8 5C 00 00 00 33 45 F8 83 E8 ‰Eü‰Eø¸\...3Eøƒè
5A3840 01 1B C0 8B 55 FC 89 45 FC 89 55 F8 B8 2F 00 00 ..À‹Uü‰Eü‰Uø¸/..
5A3850 00 33 45 F8 83 E8 01 1B C0 0B 45 FC .3Eøƒè..À.Eü
;
5A385C C3 Ã
: CUT-PATH ( a u -- a u1 )
5A385D 70 38 5A 00 00 08 43 55 54 2D 50 41 54 48 14 38 p8Z...CUT-PATH.8
5A386D 5A 00 00 Z..
\ èç ñòðîêè "path\name" âûäåëèòü ñòðîêó "path\"
OVER +
5A3870 89 45 FC 8B 45 00 03 45 FC ‰Eü‹E..Eü
BEGIN 2DUP <> WHILE DUP C@ is_path_delimiter 0= WHILE 1- REPEAT 1+ THEN
5A3879 90 90 90 8B 55 00 89 45 FC 89 55 F8 33 45 F8 8B <20><><EFBFBD>‹U.‰Eü‰Uø3Eø‹
5A3889 45 FC 0F 84 24 00 00 00 89 45 FC 0F B6 00 8D 6D Eü.„$...‰Eü.¶.<2E>m
5A3899 FC E8 91 FF FF FF 0B C0 8B 45 00 8D 6D 04 0F 85 üè‘ÿÿÿ.À‹E.<2E>m..…
5A38A9 05 00 00 00 8D 40 FF EB CA 8D 40 01 ....<2E>@ÿëÊ<C3AB>@.
\ DUP 0! \ ~ruv (to anfilat): íå äÎëæíî òóò çàòèðàòü ïîäàííûé áóôåð!
OVER -
5A38B5 89 45 FC 8B 45 00 F7 D8 03 45 FC ‰Eü‹E.÷Ø.Eü
;
5A38C0 C3 Ã
: ModuleName ( -- addr u )
5A38C1 E0 38 5A 00 00 0A 4D 6F 64 75 6C 65 4E 61 6D 65 à8Z...ModuleName
5A38D1 62 38 5A 00 00 00 00 00 00 00 00 00 00 00 00 b8Z............
ABORT
5A38E0 E8 7B F6 FF FF è{öÿÿ
;
5A38E5 C3 Ã
: ModuleDirName ( -- addr u )
5A38E6 00 39 5A 00 00 0D 4D 6F 64 75 6C 65 44 69 72 4E .9Z...ModuleDirN
5A38F6 61 6D 65 C6 38 5A 00 00 00 00 ameÆ8Z....
ModuleName CUT-PATH
5A3900 E8 DB FF FF FF E8 66 FF FF FF èÛÿÿÿèfÿÿÿ
;
5A390A C3 Ã
: +ModuleDirName ( addr u -- addr2 u2 )
5A390B 30 39 5A 00 00 0E 2B 4D 6F 64 75 6C 65 44 69 72 09Z...+ModuleDir
5A391B 4E 61 6D 65 EB 38 5A 00 00 00 00 00 00 00 00 00 Nameë8Z.........
5A392B 00 00 00 00 00 .....
2>R
5A3930 E8 CB 94 FF FF èË”ÿÿ
ModuleDirName 2DUP +
5A3935 E8 C6 FF FF FF 8B 55 00 89 45 FC 89 55 F8 03 45 èÆÿÿÿ‹U.‰Eü‰Uø.E
5A3945 F8 8D 6D FC ø<>mü
2R> DUP >R ROT SWAP 1+ MOVE
5A3949 E8 D2 94 FF FF 89 45 FC 50 8B 45 FC 8B 55 00 89 èÒ”ÿÿ‰EüP‹Eü‹U.‰
5A3959 45 00 8B 45 04 89 55 04 8B 55 00 89 45 00 8B C2 E.‹E.‰U.‹U.‰E.‹Â
5A3969 8D 40 01 E8 AF A4 FF FF <20>@.诤ÿÿ
R> +
5A3971 89 45 FC 58 03 45 FC ‰EüX.Eü
;
5A3978 C3 Ã
: +LibraryDirName ( addr u -- addr2 u2 )
5A3979 A0 39 5A 00 00 0F 2B 4C 69 62 72 61 72 79 44 69  9Z...+LibraryDi
5A3989 72 4E 61 6D 65 10 39 5A 00 00 00 00 00 00 00 00 rName.9Z........
5A3999 00 00 00 00 00 00 00 .......
\ Äîáàâèòü addr u ê ïîëíûé_ïóòü_ïðèëîæåíèÿ+devel\
2>R
5A39A0 E8 5B 94 FF FF è[”ÿÿ
ModuleDirName 2DUP +
5A39A5 E8 56 FF FF FF 8B 55 00 89 45 FC 89 55 F8 03 45 èVÿÿÿ‹U.‰Eü‰Uø.E
5A39B5 F8 8D 6D FC ø<>mü
S" devel\" ROT SWAP MOVE
5A39B9 E8 9E E7 F9 FF 06 64 65 76 65 6C 5C 00 8B 55 00 èžçùÿ.devel\.‹U.
5A39C9 89 45 00 8B 45 04 89 55 04 8B 55 00 89 45 00 8B ‰E.‹E.‰U.‹U.‰E.‹
5A39D9 C2 E8 41 A4 FF FF ÂèA¤ÿÿ
6 + 2DUP +
5A39DF 89 45 FC B8 06 00 00 00 03 45 FC 8B 55 00 89 45 ‰Eü¸.....Eü‹U.‰E
5A39EF FC 89 55 F8 03 45 F8 8D 6D FC ü‰Uø.Eø<45>mü
2R> DUP >R ROT SWAP 1+ MOVE
5A39F9 E8 22 94 FF FF 89 45 FC 50 8B 45 FC 8B 55 00 89 è"”ÿÿ‰EüP‹Eü‹U.‰
5A3A09 45 00 8B 45 04 89 55 04 8B 55 00 89 45 00 8B C2 E.‹E.‰U.‹U.‰E.‹Â
5A3A19 8D 40 01 E8 FF A3 FF FF <20>@.èÿ£ÿÿ
R> +
5A3A21 89 45 FC 58 03 45 FC ‰EüX.Eü
;
5A3A28 C3 Ã
: SOURCE-NAME ( -- a u )
5A3A29 40 3A 5A 00 00 0B 53 4F 55 52 43 45 2D 4E 41 4D @:Z...SOURCE-NAM
5A3A39 45 7E 39 5A 00 00 00 E~9Z...
CURFILE @ DUP IF ASCIIZ> ELSE 0 THEN
5A3A40 E8 4F 2B FA FF 8B 00 0B C0 74 07 E8 D0 A6 FF FF èO+úÿ‹..Àt.èЦÿÿ
5A3A50 EB 08 89 45 FC 33 C0 8D 6D FC ë.‰Eü3À<33>mü
;
5A3A5A C3 Ã
ZZ=D4

173
programs/develop/SPForth/src/KOL/spf_kol_sys.f Normal file
View File

@ -0,0 +1,173 @@
(
)
Code SYS1 ;( n -- n1 )
INT 40H
RET
EndCode
Code SYS2 ;( n n1 -- n2 )
MOV EBX, [EBP]
INT 40H
LEA EBP, [EBP+4]
RET
EndCode
Code SYS3 ;( n n1 n2 -- n3 )
MOV ECX, [EBP+4]
MOV EBX, [EBP]
INT 40H
LEA EBP, [EBP+8]
RET
EndCode
Code SYS4 ;( n n1 n2 n3 -- n4 )
MOV EDX, [EBP+8]
MOV ECX, [EBP+4]
MOV EBX, [EBP]
INT 40H
LEA EBP, [EBP+0CH]
RET
EndCode
Code SYS5 ;( n n1 n2 n3 n4 -- n5 )
MOV ESI, [EBP+0CH]
MOV EDX, [EBP+8]
MOV ECX, [EBP+4]
MOV EBX, [EBP]
INT 40H
LEA EBP, [EBP+10H]
RET
EndCode
Code SYS6 ;( n n1 n2 n3 n4 n5 -- n6 )
PUSH EDI
MOV EDI, [EBP+10H]
MOV ESI, [EBP+0CH]
MOV EDX, [EBP+8]
MOV ECX, [EBP+4]
MOV EBX, [EBP]
INT 40H
LEA EBP, [EBP+14H]
POP EDI
RET
EndCode
VARIABLE reg_struc
Code SYSV ;( -- n )
LEA EBP, [EBP-4]
MOV [EBP], EAX
MOV EAX, { ' reg_struc }
PUSH EDI
MOV EDI, [EAX+14H]
MOV ESI, [EAX+10H]
MOV EDX, [EAX+0CH]
MOV ECX, [EAX+8]
MOV EBX, [EAX+4]
MOV EAX, [EAX]
INT 40H
POP EDI
RET
EndCode
80 VALUE SCR_WIDTH
60 VALUE SCR_WIDTH-S
25 VALUE SCR_HEIGHT
CREATE &AT-XY 0 , 0 ,
CREATE &KEY 0 ,
CREATE &ATRIB 0x0000FFFF ,
0x0011000D VALUE >PIC
CREATE SCR_BUF SCR_WIDTH SCR_HEIGHT 1+ * ALLOT
: AT-XY ( X Y -- )
SWAP 16 LSHIFT + &AT-XY ! ;
: AT-XY? ( -- X Y )
&AT-XY 2+ W@ &AT-XY W@ ;
: __PAGE-UP
SCR_BUF SCR_WIDTH + SCR_BUF SCR_WIDTH SCR_HEIGHT * CMOVE
SCR_BUF SCR_WIDTH SCR_HEIGHT 1- * + SCR_WIDTH BLANK
AT-XY? 1- 0 MAX AT-XY ;
VECT PAGE-UP
: ?PAGE-UP ( n -- )
&AT-XY 2+ W@ + SCR_WIDTH /MOD SWAP &AT-XY 2+ W!
&AT-XY W@ + SCR_HEIGHT /MOD
IF PAGE-UP DROP SCR_HEIGHT 1- THEN &AT-XY W! ;
: SCR_CR
&AT-XY @ 0xFFFF AND 1+ &AT-XY ! 0 ?PAGE-UP ;
: SCR_TYPE ( addr len -- )
TUCK SWAP
&ATRIB @
&AT-XY 2+ W@ 0x60000 *
&AT-XY W@ 0xD * +
0x00060018 +
4 SYS5 DROP
\ &AT-XY 2+ +!
?PAGE-UP
;
: DRAW_LINS
['] PAGE-UP >BODY @
['] NOOP TO PAGE-UP
AT-XY?
0 0 AT-XY
SCR_BUF SCR_WIDTH SCR_HEIGHT * BOUNDS
DO I SCR_WIDTH SCR_TYPE \ SCR_CR
SCR_WIDTH
+LOOP
AT-XY
TO PAGE-UP ;
: _PAGE-UP
draw_window __PAGE-UP
DRAW_LINS
;
' _PAGE-UP TO PAGE-UP
CREATE LAST_CUR 0 , 0 ,
: CORSOR_DROW
0 LAST_CUR 2@ 38 SYS4 DROP
0x00FF00FF
&AT-XY W@ 0xD * 0x21 + DUP 16 LSHIFT +
&AT-XY 2+ W@ 0x6 * 6 + DUP 6 + 16 LSHIFT +
2DUP LAST_CUR 2!
38 SYS4 DROP
;
: REDRAW
draw_window
DRAW_LINS CORSOR_DROW ;
: EVENT-CASE
11 SYS1
DUP 1 = IF DROP REDRAW EXIT THEN
DUP 2 = IF DROP 2 SYS1 8 RSHIFT &KEY C! EXIT THEN
3 = IF -1 SYS1 EXIT THEN ;
0
CELL FIELD .CODE
2 CELLS FIELD .FIRST \ ¯®§¨æ¨ï ¢ ä ©«¥ (¢ ¡ ©â å)
CELL FIELD .SIZE \ ᪮«ìª® ¡ ©â R/W
CELL FIELD .DATA \ 㪠§ â¥«ì ­  ¤ ­­ë¥
222 FIELD .NAME \ ASCIIZ-¨¬ï ä ©« 
CONSTANT FILE_STR
: WINDOW
draw_window CC_LINES ;

752
programs/develop/SPForth/src/KOL/spf_kol_sys.f_L Normal file
View File

@ -0,0 +1,752 @@
ZZ=D4 (
)
Code SYS1 ;( n -- n1 )
59E2C9 E0 E2 59 00 00 04 53 59 53 31 AE E2 59 00 00 00 àâY...SYS1®âY...
59E2D9 00 00 00 00 00 00 00 .......
INT 40H
59E2E0 CD 40 Í@
RET
59E2E2 C3 Ã
EndCode
Code SYS2 ;( n n1 -- n2 )
59E2E3 00 E3 59 00 00 04 53 59 53 32 CE E2 59 00 00 00 .ãY...SYS2ÎâY...
59E2F3 00 00 00 00 00 00 00 00 00 00 00 00 00 .............
MOV EBX, [EBP]
59E300 8B 5D 00 ‹].
INT 40H
59E303 CD 40 Í@
LEA EBP, [EBP+4]
59E305 8D 6D 04 <20>m.
RET
59E308 C3 Ã
EndCode
Code SYS3 ;( n n1 n2 -- n3 )
59E309 20 E3 59 00 00 04 53 59 53 33 E8 E2 59 00 00 00 ãY...SYS3èâY...
59E319 00 00 00 00 00 00 00 .......
MOV ECX, [EBP+4]
59E320 8B 4D 04 ‹M.
MOV EBX, [EBP]
59E323 8B 5D 00 ‹].
INT 40H
59E326 CD 40 Í@
LEA EBP, [EBP+8]
59E328 8D 6D 08 <20>m.
RET
59E32B C3 Ã
EndCode
Code SYS4 ;( n n1 n2 n3 -- n4 )
59E32C 40 E3 59 00 00 04 53 59 53 34 0E E3 59 00 00 00 @ãY...SYS4.ãY...
59E33C 00 00 00 00 ....
MOV EDX, [EBP+8]
59E340 8B 55 08 ‹U.
MOV ECX, [EBP+4]
59E343 8B 4D 04 ‹M.
MOV EBX, [EBP]
59E346 8B 5D 00 ‹].
INT 40H
59E349 CD 40 Í@
LEA EBP, [EBP+0CH]
59E34B 8D 6D 0C <20>m.
RET
59E34E C3 Ã
EndCode
Code SYS5 ;( n n1 n2 n3 n4 -- n5 )
59E34F 60 E3 59 00 00 04 53 59 53 35 31 E3 59 00 00 00 `ãY...SYS51ãY...
59E35F 00 .
MOV ESI, [EBP+0CH]
59E360 8B 75 0C ‹u.
MOV EDX, [EBP+8]
59E363 8B 55 08 ‹U.
MOV ECX, [EBP+4]
59E366 8B 4D 04 ‹M.
MOV EBX, [EBP]
59E369 8B 5D 00 ‹].
INT 40H
59E36C CD 40 Í@
LEA EBP, [EBP+10H]
59E36E 8D 6D 10 <20>m.
RET
59E371 C3 Ã
EndCode
Code SYS6 ;( n n1 n2 n3 n4 n5 -- n6 )
59E372 80 E3 59 00 00 04 53 59 53 36 54 E3 59 00 €ãY...SYS6TãY.
PUSH EDI
59E380 57 W
MOV EDI, [EBP+10H]
59E381 8B 7D 10 ‹}.
MOV ESI, [EBP+0CH]
59E384 8B 75 0C ‹u.
MOV EDX, [EBP+8]
59E387 8B 55 08 ‹U.
MOV ECX, [EBP+4]
59E38A 8B 4D 04 ‹M.
MOV EBX, [EBP]
59E38D 8B 5D 00 ‹].
INT 40H
59E390 CD 40 Í@
LEA EBP, [EBP+14H]
59E392 8D 6D 14 <20>m.
POP EDI
59E395 5F _
RET
59E396 C3 Ã
EndCode
VARIABLE reg_struc
59E397 AB E3 59 00 00 09 72 65 67 5F 73 74 72 75 63 77 «ãY...reg_strucw
59E3A7 E3 59 00 00 E8 6C 3C FA FF 00 00 00 00 ãY..èl<úÿ....
Code SYSV ;( -- n )
59E3B4 D0 E3 59 00 00 04 53 59 53 56 9C E3 59 00 00 00 ÐãY...SYSVœãY...
59E3C4 00 00 00 00 00 00 00 00 00 00 00 00 ............
LEA EBP, [EBP-4]
59E3D0 8D 6D FC <20>mü
MOV [EBP], EAX
59E3D3 89 45 00 ‰E.
MOV EAX, { ' reg_struc }
59E3D6 B8 AB E3 59 00 ¸«ãY.
PUSH EDI
59E3DB 57 W
MOV EDI, [EAX+14H]
59E3DC 8B 78 14 ‹x.
MOV ESI, [EAX+10H]
59E3DF 8B 70 10 ‹p.
MOV EDX, [EAX+0CH]
59E3E2 8B 50 0C ‹P.
MOV ECX, [EAX+8]
59E3E5 8B 48 08 ‹H.
MOV EBX, [EAX+4]
59E3E8 8B 58 04 ‹X.
MOV EAX, [EAX]
59E3EB 8B 00 ‹.
INT 40H
59E3ED CD 40 Í@
POP EDI
59E3EF 5F _
RET
59E3F0 C3 Ã
EndCode
80 VALUE SCR_WIDTH
59E3F1 10 E4 59 00 00 09 53 43 52 5F 57 49 44 54 48 B9 .äY...SCR_WIDTH¹
59E401 E3 59 00 00 00 00 00 00 00 00 00 00 00 00 00 E8 ãY.............è
59E411 27 3C FA FF 50 00 00 00 E8 E6 3C FA FF '<úÿP...èæ<úÿ
60 VALUE SCR_WIDTH-S
59E41E 40 E4 59 00 00 0B 53 43 52 5F 57 49 44 54 48 2D @äY...SCR_WIDTH-
59E42E 53 F6 E3 59 00 00 00 00 00 00 00 00 00 00 00 00 SöãY............
59E43E 00 00 E8 F7 3B FA FF 3C 00 00 00 E8 B6 3C FA FF ..è÷;úÿ<...è¶<úÿ
25 VALUE SCR_HEIGHT
59E44E 70 E4 59 00 00 0A 53 43 52 5F 48 45 49 47 48 54 päY...SCR_HEIGHT
59E45E 23 E4 59 00 00 00 00 00 00 00 00 00 00 00 00 00 #äY.............
59E46E 00 00 E8 C7 3B FA FF 19 00 00 00 E8 86 3C FA FF ..èÇ;úÿ....è†<úÿ
CREATE &AT-XY 0 , 0 ,
59E47E 8F E4 59 00 00 06 26 41 54 2D 58 59 53 E4 59 00 <20>äY...&AT-XYSäY.
59E48E 00 E8 88 3B FA FF 00 00 00 00 00 00 00 00 .èˆ;úÿ........
CREATE &KEY 0 ,
59E49C AB E4 59 00 00 04 26 4B 45 59 83 E4 59 00 00 E8 «äY...&KEYƒäY..è
59E4AC 6C 3B FA FF 00 00 00 00 l;úÿ....
CREATE &ATRIB 0x0000FFFF ,
59E4B4 C7 E4 59 00 00 06 26 41 54 52 49 42 A1 E4 59 00 ÇäY...&ATRIB¡äY.
59E4C4 00 00 00 E8 50 3B FA FF FF FF 00 00 ...èP;úÿÿÿ..
0x0011000D VALUE >PIC
59E4D0 E0 E4 59 00 00 04 3E 50 49 43 B9 E4 59 00 00 00 àäY...>PIC¹äY...
59E4E0 E8 57 3B FA FF 0D 00 11 00 E8 16 3C FA FF èW;úÿ....è.<úÿ
CREATE SCR_BUF SCR_WIDTH SCR_HEIGHT 1+ * ALLOT
59E4EE FF E4 59 00 00 07 53 43 52 5F 42 55 46 D5 E4 59 ÿäY...SCR_BUFÕäY
59E4FE 00 E8 18 3B FA FF 00 00 00 00 00 00 00 00 00 00 .è.;úÿ..........
59E50E 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................
59E51E 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................
59E52E 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................
59ED24 7E6 bytes
: AT-XY ( X Y -- )
59ED24 40 ED 59 00 00 05 41 54 2D 58 59 F3 E4 59 00 00 @íY...AT-XYóäY..
59ED34 00 00 00 00 00 00 00 00 00 00 00 00 ............
SWAP 16 LSHIFT + &AT-XY ! ;
MOV EDX , [EBP ]
MOV [EBP ], EAX
MOV [EBP -4], EDX
MOV EAX , $10
MOV ECX , EAX
MOV EAX , [EBP -4]
SHL EAX , CL
ADD EAX , [EBP ]
LEA EBP , [EBP +4]
CALL @@&AT-XY
MOV EDX , [EBP ]
MOV [EAX ], EDX
MOV EAX , [EBP +4]
LEA EBP , [EBP +8]
RET
: AT-XY? ( -- X Y )
59ED6C 80 ED 59 00 00 06 41 54 2D 58 59 3F 29 ED 59 00 €íY...AT-XY?)íY.
59ED7C 00 00 00 00 ....
&AT-XY 2+ W@ &AT-XY W@ ;
CALL @@&AT-XY
LEA EAX , [EAX +2]
MOVZX EAX , WORD PTR [EAX ]
CALL @@&AT-XY
MOVZX EAX , WORD PTR [EAX ]
RET
: __PAGE-UP
59ED94 B0 ED 59 00 00 09 5F 5F 50 41 47 45 2D 55 50 71 °íY...__PAGE-UPq
59EDA4 ED 59 00 00 00 00 00 00 00 00 00 00 íY..........
SCR_BUF SCR_WIDTH + SCR_BUF SCR_WIDTH SCR_HEIGHT * CMOVE
CALL @@SCR_BUF
CALL @@SCR_WIDTH
ADD EAX , [EBP ]
LEA EBP , [EBP +4]
CALL @@SCR_BUF
CALL @@SCR_WIDTH
CALL @@SCR_HEIGHT
IMUL [EBP ]
LEA EBP , [EBP +4]
CALL @@CMOVE
SCR_BUF SCR_WIDTH SCR_HEIGHT 1- * + SCR_WIDTH BLANK
CALL @@SCR_BUF
CALL @@SCR_WIDTH
CALL @@SCR_HEIGHT
LEA EAX , [EAX -1]
IMUL [EBP ]
ADD EAX , [EBP +4]
LEA EBP , [EBP +8]
CALL @@SCR_WIDTH
CALL @@BLANK
AT-XY? 1- 0 MAX AT-XY ;
CALL @@AT-XY?
LEA EAX , [EAX -1]
MOV [EBP -4], EAX
XOR EAX , EAX
LEA EBP , [EBP -4]
CALL @@MAX
CALL @@AT-XY
RET
VECT PAGE-UP
59EE1A 30 EE 59 00 00 07 50 41 47 45 2D 55 50 99 ED 59 0îY...PAGE-UP™íY
59EE2A 00 00 00 00 00 00 E8 B3 32 FA FF 60 F0 59 00 E8 ......è³2úÿ`ðY.è
59EE3A C6 32 FA FF Æ2úÿ
: ?PAGE-UP ( n -- )
59EE3E 50 EE 59 00 00 08 3F 50 41 47 45 2D 55 50 1F EE PîY...?PAGE-UP.î
59EE4E 59 00 Y.
&AT-XY 2+ W@ + SCR_WIDTH /MOD SWAP &AT-XY 2+ W!
CALL @@&AT-XY
LEA EAX , [EAX +2]
MOVZX EAX , WORD PTR [EAX ]
ADD EAX , [EBP ]
LEA EBP , [EBP +4]
CALL @@SCR_WIDTH
MOV ECX , EAX
MOV EAX , [EBP ]
CDQ
IDIV ECX
MOV [EBP ], EDX
MOV EDX , [EBP ]
MOV [EBP ], EAX
MOV EAX , EDX
CALL @@&AT-XY
LEA EAX , [EAX +2]
CALL @@W!
&AT-XY W@ + SCR_HEIGHT /MOD
CALL @@&AT-XY
MOVZX EAX , WORD PTR [EAX ]
ADD EAX , [EBP ]
LEA EBP , [EBP +4]
CALL @@SCR_HEIGHT
MOV ECX , EAX
MOV EAX , [EBP ]
CDQ
IDIV ECX
MOV [EBP ], EDX
IF PAGE-UP DROP SCR_HEIGHT 1- THEN &AT-XY W! ;
OR EAX , EAX
MOV EAX , [EBP ]
LEA EBP , [EBP +4]
JE [OFFSET ?PAGE-UP]
CALL @@PAGE-UP
MOV EAX , [EBP ]
LEA EBP , [EBP +4]
CALL @@SCR_HEIGHT
LEA EAX , [EAX -1]
@59EEC1: CALL @@&AT-XY
CALL @@W!
RET
: SCR_CR
59EECC E0 EE 59 00 00 06 53 43 52 5F 43 52 43 EE 59 00 àîY...SCR_CRCîY.
59EEDC 00 00 00 00 ....
&AT-XY @ 0xFFFF AND 1+ &AT-XY ! 0 ?PAGE-UP ;
CALL @@&AT-XY
MOV EAX , [EAX ]
MOV [EBP -4], EAX
MOV EAX , $FFFF
AND EAX , [EBP -4]
LEA EAX , [EAX +1]
CALL @@&AT-XY
MOV EDX , [EBP ]
MOV [EAX ], EDX
XOR EAX , EAX
LEA EBP , [EBP +4]
CALL @@?PAGE-UP
RET
: SCR_TYPE ( addr len -- )
59EF0A 20 EF 59 00 00 08 53 43 52 5F 54 59 50 45 D1 EE ïY...SCR_TYPEÑî
59EF1A 59 00 00 00 00 00 Y.....
TUCK SWAP
MOV EDX , [EBP ]
MOV [EBP -4], EDX
MOV [EBP ], EAX
MOV EDX , [EBP -4]
MOV [EBP -4], EAX
MOV EAX , EDX
LEA EBP , [EBP -4]
&ATRIB @
CALL @@&ATRIB
MOV EAX , [EAX ]
&AT-XY 2+ W@ 0x60000 *
CALL @@&AT-XY
MOVZX EAX , WORD PTR [EAX +2]
MOV [EBP -4], EAX
MOV EAX , $60000
IMUL [EBP -4]
&AT-XY W@ 0xD * +
CALL @@&AT-XY
MOVZX EAX , WORD PTR [EAX ]
MOV [EBP -4], EAX
MOV EAX , $D
IMUL [EBP -4]
ADD EAX , [EBP ]
LEA EAX , [$60018][EAX ]
0x00060018 +
MOV [EBP ], EAX
MOV EAX , $4
4 SYS5 DROP
CALL @@SYS5
MOV EAX , [EBP ]
LEA EBP , [EBP +4]
\ &AT-XY 2+ +!
?PAGE-UP
CALL @@?PAGE-UP
;
RET
: DRAW_LINS
59EF84 A0 EF 59 00 00 09 44 52 41 57 5F 4C 49 4E 53 0F  ïY...DRAW_LINS.
59EF94 EF 59 00 00 00 00 00 00 00 00 00 00 ïY..........
['] PAGE-UP >BODY @
MOV [EBP -4], EAX
MOV EAX , $59EE30
MOV EAX , [EAX +5]
MOV [EBP -8], EAX
MOV EAX , $59D240
['] NOOP TO PAGE-UP
LEA EBP , [EBP -8]
CALL [OFFSET PAGE-UP]
AT-XY?
CALL @@AT-XY?
0 0 AT-XY
MOV [EBP -4], EAX
MOV [EBP -8], $0
XOR EAX , EAX
LEA EBP , [EBP -8]
CALL @@AT-XY
SCR_BUF SCR_WIDTH SCR_HEIGHT * BOUNDS
CALL @@SCR_BUF
CALL @@SCR_WIDTH
CALL @@SCR_HEIGHT
IMUL [EBP ]
ADD EAX , [EBP +4]
MOV EDX , [EBP +4]
MOV [EBP +4], EAX
MOV EAX , EDX
MOV EDX , $80000000
DO I SCR_WIDTH SCR_TYPE \ SCR_CR
SUB EDX , [EBP +4]
LEA EBX , [EDX ][EAX ]
MOV EAX , [EBP +8]
LEA EBP , [EBP +12]
PUSH , $59F037
PUSH EDX
PUSH EBX
XCHG EAX, EAX
XCHG EAX, EAX
XCHG EAX, EAX
MOV [EBP -4]EAX
MOV EAX , [ESP ]
SUB EAX , [ESP +4]
LEA EBP , [EBP -4]
CALL @@SCR_WIDTH
CALL @@SCR_TYPE
SCR_WIDTH
CALL @@SCR_WIDTH
+LOOP
ADD [ESP ], EAX
MOV EAX , [EBP ]
LEA EBP , [EBP +4]
JNO [OFFSET DRAW_LINS]
LEA ESP , [ESP +12]
AT-XY
CALL @@AT-XY
TO PAGE-UP ;
CALL [OFFSET PAGE-UP]
RET
: _PAGE-UP
59F042 60 F0 59 00 00 08 5F 50 41 47 45 2D 55 50 89 EF `ðY..._PAGE-UP‰ï
59F052 59 00 00 00 00 00 00 00 00 00 00 00 00 00 Y.............
draw_window __PAGE-UP
CALL @@draw_window
CALL @@__PAGE-UP
DRAW_LINS
CALL @@DRAW_LINS
;
RET
' _PAGE-UP TO PAGE-UP
CREATE LAST_CUR 0 , 0 ,
59F070 83 F0 59 00 00 08 4C 41 53 54 5F 43 55 52 47 F0 ƒðY...LAST_CURGð
59F080 59 00 00 E8 94 2F FA FF 00 00 00 00 00 00 00 00 Y..è”/úÿ........
: CORSOR_DROW
59F090 B0 F0 59 00 00 0B 43 4F 52 53 4F 52 5F 44 52 4F °ðY...CORSOR_DRO
59F0A0 57 75 F0 59 00 00 00 00 00 00 00 00 00 00 00 00 WuðY............
0 LAST_CUR 2@ 38 SYS4 DROP
MOV [EBP -4], EAX
XOR EAX , EAX
LEA EBP , [EBP -4]
CALL @@LAST_CUR
MOV EDX , [EAX +4]
MOV [EBP -4], EDX
MOV EAX , [EAX ]
MOV [EBP -8], EAX
MOV EAX , $26
MOV EDX , [EBP ]
MOV ECX , [EBP -4]
MOV EBX , [EBP -8]
INT $40
MOV EAX , $FF00FF
LEA EBP , [EBP +4]
0x00FF00FF
&AT-XY W@ 0xD * 0x21 + DUP 16 LSHIFT +
CALL @@&AT-XY
MOVZX EAX , WORD PTR [EAX ]
MOV [EBP -4], EAX
MOV EAX , $D
IMUL [EBP -4]
MOV [EBP -4], EAX
MOV EAX , $21
ADD EAX , [EBP -4]
MOV [EBP -4], EAX
MOV [EBP -8], EAX
MOV EAX , $10
MOV ECX , EAX
MOV EAX , [EBP -8]
SHL EAX , CL
ADD EAX , [EBP -4]
&AT-XY 2+ W@ 0x6 * 6 + DUP 6 + 16 LSHIFT +
CALL @@&AT-XY
MOVZX EAX , WORD PTR [EAX +2]
MOV [EBP -4], EAX
MOV EAX , $6
IMUL [EBP -4]
MOV [EBP -4], EAX
MOV EAX , $6
ADD EAX , [EBP -4]
MOV [EBP -4], EAX
LEA EAX , [EAX +6]
MOV [EBP -8], EAX
MOV EAX , $10
MOV ECX , EAX
MOV EAX , [EBP -8]
SHL EAX , CL
ADD EAX , [EBP -4]
2DUP LAST_CUR 2!
MOV EDX , [EBP ]
MOV [EBP -4], EAX
MOV [EBP -8], EDX
LEA EBP , [EBP -8]
CALL @@LAST_CUR
CALL @@2!
38 SYS4 DROP
MOV [EBP -4], EAX
MOV EAX , $26
MOV EDX , [EBP +4]
MOV ECX , [EBP ]
MOV EBX , [EBP -4]
INT $40
MOV EAX , [EBP +8]
LEA EBP , [EBP +12]
;
RET
: REDRAW
59F17A 90 F1 59 00 00 06 52 45 44 52 41 57 95 F0 59 00 <20>ñY...REDRAW•ðY.
59F18A 00 00 00 00 00 00 ......
draw_window
CALL @@draw_window
DRAW_LINS CORSOR_DROW ;
CALL @@DRAW_LINS
CALL @@CORSOR_DROW
RET
: EVENT-CASE
59F1A0 C0 F1 59 00 00 0A 45 56 45 4E 54 2D 43 41 53 45 ÀñY...EVENT-CASE
59F1B0 7F F1 59 00 00 00 00 00 00 00 00 00 00 00 00 00 ñY.............
11 SYS1
MOV [EBP -4], EAX
MOV EAX , $B
INT $40
MOV [EBP -8], EAX
DUP 1 = IF DROP REDRAW EXIT THEN
CMP EAX , $1
MOV EAX , [EBP -8]
LEA EBP , [EBP -4]
JNE [OFFSET EVENT-CASE]
MOV EAX , [EBP ]
LEA EBP , [EBP +4]
CALL @@REDRAW
RET
DUP 2 = IF DROP 2 SYS1 8 RSHIFT &KEY C! EXIT THEN
@59F1E6: MOV [EBP -4], EAX
CMP EAX , $2
MOV EAX , [EBP -4]
JNE [OFFSET EVENT-CASE]
MOV EAX , $2
INT $40
MOV [EBP -4], EAX
MOV EAX , $8
MOV ECX , EAX
MOV EAX , [EBP -4]
SHR EAX , CL
CALL @@&KEY
MOV EDX , [EBP ]
MOV [EAX ], DL
MOV EAX , [EBP +4]
LEA EBP , [EBP +8]
RET
3 = IF -1 SYS1 EXIT THEN ;
@59F21A: CMP EAX , $3
MOV EAX , [EBP ]
LEA EBP , [EBP +4]
JNE [OFFSET EVENT-CASE]
MOV [EBP -4], EAX
MOV EAX , $FFFFFFFF
INT $40
LEA EBP , [EBP -4]
RET
@59F235: RET
0
CELL FIELD .CODE
59F236 50 F2 59 00 00 05 2E 43 4F 44 45 A5 F1 59 00 00 PòY....CODE¥ñY..
59F246 00 00 00 00 00 00 00 00 00 00 C3 ..........Ã
2 CELLS FIELD .FIRST \ ¯®§¨æ¨ï ¢ ä ©«¥ (¢ ¡ ©â å)
59F251 70 F2 59 00 00 06 2E 46 49 52 53 54 3B F2 59 00 pòY....FIRST;òY.
59F261 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 89 ...............‰
59F271 45 FC B8 04 00 00 00 03 45 FC C3 Eü¸.....EüÃ
CELL FIELD .SIZE \ ᪮«ìª® ¡ ©â R/W
59F27C 90 F2 59 00 00 05 2E 53 49 5A 45 56 F2 59 00 00 <20>òY....SIZEVòY..
59F28C 00 00 00 00 89 45 FC B8 0C 00 00 00 03 45 FC C3 ....‰Eü¸.....EüÃ
CELL FIELD .DATA \ 㪠§ â¥«ì ­  ¤ ­­ë¥
59F29C B0 F2 59 00 00 05 2E 44 41 54 41 81 F2 59 00 00 °òY....DATA<54>òY..
59F2AC 00 00 00 00 89 45 FC B8 10 00 00 00 03 45 FC C3 ....‰Eü¸.....EüÃ
222 FIELD .NAME \ ASCIIZ-¨¬ï ä ©« 
59F2BC D0 F2 59 00 00 05 2E 4E 41 4D 45 A1 F2 59 00 00 ÐòY....NAME¡òY..
59F2CC 00 00 00 00 89 45 FC B8 14 00 00 00 03 45 FC C3 ....‰Eü¸.....EüÃ
CONSTANT FILE_STR
59F2DC F0 F2 59 00 00 08 46 49 4C 45 5F 53 54 52 C1 F2 ðòY...FILE_STRÁò
59F2EC 59 00 00 00 E8 47 2D FA FF F2 00 00 00 Y...èG-úÿò...
: WINDOW
59F2F9 10 F3 59 00 00 06 57 49 4E 44 4F 57 E1 F2 59 00 .óY...WINDOWáòY.
59F309 00 00 00 00 00 00 00 .......
draw_window CC_LINES ;
CALL @@draw_window
CALL @@CC_LINES
RET
ZZ=D4

2
programs/develop/SPForth/src/MEFORTH.F Normal file
View File

@ -0,0 +1,2 @@
: $" POSTPONE C" ; IMMEDIATE
: .S DEPTH .SN ;

154
programs/develop/SPForth/src/compiler/spf_compile.f Normal file
View File

@ -0,0 +1,154 @@
( Компиляция чисел и строк в словарь.
ОС-независимые определения.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
Преобразование из 16-разрядного в 32-разрядный код - 1995-96гг
Ревизия - сентябрь 1999, март 2000
)
HEX
: HERE ( -- addr ) \ 94
\ addr - указатель пространства данных.
DP @
DUP TO :-SET
DUP TO J-SET
;
: _COMPILE, \ 94 CORE EXT
\ Интерпретация: семантика не определена.
\ Выполнение: ( xt -- )
\ Добавить семантику выполнения определения, представленого xt, к
\ семантике выполнения текущего определения.
?SET
SetOP
0E8 C, \ машинная команда CALL
DP @ CELL+ - ,
DP @ TO LAST-HERE
;
: COMPILE, \ 94 CORE EXT
\ Интерпретация: семантика не определена.
\ Выполнение: ( xt -- )
\ Добавить семантику выполнения определения, представленого xt, к
\ семантике выполнения текущего определения.
CON>LIT
IF INLINE?
IF INLINE,
ELSE _COMPILE,
THEN
THEN
;
: BRANCH, ( ADDR -> ) \ скомпилировать инструкцию ADDR JMP
?SET SetOP SetJP E9 C,
DUP IF DP @ CELL+ - THEN , DP @ TO LAST-HERE
;
: RET, ( -> ) \ скомпилировать инструкцию RET
?SET SetOP 0xC3 C, OPT OPT_CLOSE
;
: LIT, ( W -> )
['] DUP INLINE,
OPT_INIT
SetOP 0B8 C, , OPT \ MOV EAX, #
OPT_CLOSE
;
: DLIT, ( D -> )
SWAP LIT, LIT,
;
: RLIT, ( u -- )
\ Скомпилировать следующую семантику:
\ Положить на стек возвратов литерал u
68 C, , \ push dword #
;
: ?BRANCH, ( ADDR -> ) \ скомпилировать инструкцию ADDR ?BRANCH
?SET
084 TO J_COD
???BR-OPT
SetJP SetOP
J_COD \ JX без 0x0F
0x0F \ кусок от JX
C, C,
DUP IF DP @ CELL+ - THEN , DP @ TO LAST-HERE
;
DECIMAL
: S, ( addr u -- )
\ Зарезервировать u байт пространства данных
\ и поместить туда содержимое u байт из addr.
DP @ SWAP DUP ALLOT CMOVE
;
: S", ( addr u -- )
\ Разместить в пространстве данных строку, заданную addr u,
\ в виде строки со счетчиком.
DUP C, S,
;
: SLIT, ( a u -- )
\ Скомпилировать строку, заданную addr u.
SLITERAL-CODE COMPILE, S", 0 C,
;
: CLIT, ( a -- )
COUNT PAD $!
CLITERAL-CODE _COMPILE, PAD COUNT S", 0 C, ;
: ", ( A -> )
\ разместить в пространстве данных строку, заданную адресом A,
\ в виде строки со счетчиком
COUNT S",
;
\ orig - a, 1 (short) или a, 2 (near)
\ dest - a, 3
: >MARK ( -> A )
DP @ DUP TO :-SET 4 -
;
: <MARK ( -> A )
HERE
;
: >ORESOLVE1 ( A -> )
?SET
DUP
DP @ DUP TO :-SET
OVER - 4 -
SWAP !
RESOLVE_OPT
;
: >ORESOLVE ( A, N -- )
DUP 1 = IF DROP >ORESOLVE1
ELSE 2 <> IF -2007 THROW THEN \ ABORT" Conditionals not paired"
>ORESOLVE1
THEN
;
: >RESOLVE1 ( A -> )
HERE OVER - 4 -
SWAP !
;
: >RESOLVE ( A, N -- )
DUP 1 = IF DROP >RESOLVE1
ELSE 2 <> IF -2007 THROW THEN \ ABORT" Conditionals not paired"
>RESOLVE1
THEN
;
: r> ['] C-R> INLINE, ; IMMEDIATE
: >r ['] C->R INLINE, ; IMMEDIATE

60
programs/develop/SPForth/src/compiler/spf_compile0.f Normal file
View File

@ -0,0 +1,60 @@
( Компиляция чисел словарь.
ОС-независимые определения.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
Преобразование из 16-разрядного в 32-разрядный код - 1995-96гг
Ревизия - сентябрь 1999, март 2000
)
: RDROP ['] C-RDROP INLINE, ; IMMEDIATE
: 2RDROP ['] C-2RDROP INLINE, ; IMMEDIATE
: 3RDROP ['] C-3RDROP INLINE, ; IMMEDIATE
5 CONSTANT CFL \ длина кода, компилируемого CREATE в сегмент CS.
\ USER DOES>A \ временная переменная - адрес для DOES>
: SET-CURRENT ( wid -- ) \ 94 SEARCH
\ Установить список компиляции на список, идентифицируемый wid.
CURRENT !
;
: GET-CURRENT ( -- wid ) \ 94 SEARCH
\ Возвращает wid - идентификатор списка компиляции.
CURRENT @
;
: IS-TEMP-WL ( -- flag )
\ проверяет, является ли текущий словарь компиляции временным (внешним)
GET-CURRENT CELL- @ -1 =
;
0 [IF]
: DP ( -- addr ) \ переменная, содержащая HERE сегмента данных
IS-TEMP-WL
IF GET-CURRENT 6 CELLS + ELSE (DP) THEN
;
[THEN]
: ALLOT ( n -- ) \ 94
\ Если n больше нуля, зарезервировать n байт пространства данных. Если n меньше
\ нуля - освободить |n| байт пространства данных. Если n ноль, оставить
\ указатель пространства данных неизменным.
\ Если перед выполнением ALLOT указатель пространства данных выровнен и n
\ кратно размеру ячейки, он остается выровненным и после ALLOT.
\ Если перед выполнением ALLOT указатель пространства данных выровнен на
\ границу символа и n кратно размеру символа, он остается выровненным на
\ границу символа и после ALLOT.
DP +!
;
: , ( x -- ) \ 94
\ Зарезервировать одну ячейку в области данных и поместить x в эту ячейку.
DP @ 4 ALLOT !
;
: C, ( char -- ) \ 94
\ Зарезервировать место для символа в области данных и поместить туда char.
DP @ 1 ALLOT C!
;
: W, ( word -- )
\ Зарезервировать место для word в области данных и поместить туда char.
DP @ 2 ALLOT W!
;

206
programs/develop/SPForth/src/compiler/spf_defwords.f Normal file
View File

@ -0,0 +1,206 @@
( Ž¯à¥¤¥«ïî騥 á«®¢ , ᮧ¤ î騥 á«®¢ à­ë¥ áâ âì¨ ¢ á«®¢ à¥.
Ž‘-­¥§ ¢¨á¨¬ë¥ ®¯à¥¤¥«¥­¨ï.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
<20>८¡à §®¢ ­¨¥ ¨§ 16-à §à來®£® ¢ 32-à §àï¤­ë© ª®¤ - 1995-96££
<20>¥¢¨§¨ï - ᥭâï¡àì 1999
)
USER LAST-CFA
USER-VALUE LAST-NON
: REVEAL ( --- )
\ Add the last created definition to the CURRENT wordlist.
LAST @ CURRENT @ ! ;
: SHEADER ( addr u -- )
_SHEADER REVEAL
;
: _SHEADER ( addr u -- )
0 C, ( flags )
HERE 0 , ( cfa )
DUP LAST-CFA !
-ROT WARNING @
IF 2DUP GET-CURRENT SEARCH-WORDLIST
IF DROP 2DUP TYPE ." isn't unique" CR THEN
THEN
CURRENT @ SWORD,
ALIGN
HERE SWAP ! ( § ¯®«­¨«¨ cfa )
;
: HEADER ( "name" -- ) PARSE-WORD SHEADER ;
: CREATED ( addr u -- )
\ ‘®§¤ âì ®¯à¥¤¥«¥­¨¥ ¤«ï c-addr u á ᥬ ­â¨ª®© ¢ë¯®«­¥­¨ï, ®¯¨á ­­®© ­¨¦¥.
\ …᫨ 㪠§ â¥«ì ¯à®áâà ­á⢠ ¤ ­­ëå ­¥ ¢ë஢­¥­, § à¥§¥à¢¨à®¢ âì ¬¥áâ®
\ ¤«ï ¢ëà ¢­¨¢ ­¨ï. <20>®¢ë© 㪠§ â¥«ì ¯à®áâà ­á⢠ ¤ ­­ëå ®¯à¥¤¥«ï¥â
\ ¯®«¥ ¤ ­­ëå name. CREATE ­¥ १¥à¢¨àã¥â ¬¥áâ® ¢ ¯®«¥ ¤ ­­ëå name.
\ name ‚믮«­¥­¨¥: ( -- a-addr )
\ a-addr -  ¤à¥á ¯®«ï ¤ ­­ëå name. ‘¥¬ ­â¨ª  ¢ë¯®«­¥­¨ï name ¬®¦¥â
\ ¡ëâì à áè¨à¥­  á ¯®¬®éìî DOES>.
SHEADER
HERE DOES>A ! ( ¤«ï DOES )
CREATE-CODE COMPILE,
;
: CREATE ( "<spaces>name" -- ) \ 94
PARSE-WORD CREATED
;
: (DOES1) \ â  ç áâì, ª®â®à ï à ¡®â ¥â ®¤­®¢à¥¬¥­­® á CREATE (®¡ëç­®)
R> DOES>A @ CFL + -
DOES>A @ 1+ ! ;
Code (DOES2)
SUB EBP, 4
MOV [EBP], EAX
POP EBX
POP EAX
PUSH EBX
RET
EndCODE
: DOES> \ 94
\ ˆ­â¥à¯à¥â æ¨ï: ᥬ ­â¨ª  ­¥®¯à¥¤¥«¥­ .
\ Š®¬¯¨«ïæ¨ï: ( C: clon-sys1 -- colon-sys2 )
\ „®¡ ¢¨âì ᥬ ­â¨ªã ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï, ¤ ­­ãî ­¨¦¥, ª ⥪ã饬ã
\ ®¯à¥¤¥«¥­¨î. <20>㤥⠨«¨ ­¥â ⥪ã饥 ®¯à¥¤¥«¥­¨¥ ᤥ« ­® ¢¨¤¨¬®
\ ¤«ï ¯®¨áª  ¢ á«®¢ à¥ ¯à¨ ª®¬¯¨«ï樨 DOES>, § ¢¨á¨â ®â ॠ«¨§ æ¨¨.
\ <20>®£«®é ¥â colon-sys1 ¨ ¯à®¨§¢®¤¨â colon-sys2. „®¡ ¢«ï¥â ᥬ ­â¨ªã
\ ¨­¨æ¨ «¨§ æ¨¨, ¤ ­­ãî ­¨¦¥, ª ⥪ã饬㠮¯à¥¤¥«¥­¨î.
\ ‚à¥¬ï ¢ë¯®«­¥­¨ï: ( -- ) ( R: nest-sys1 -- )
\ ‡ ¬¥­¨âì ᥬ ­â¨ªã ¢ë¯®«­¥­¨ï ¯®á«¥¤­¥£® ®¯à¥¤¥«¥­¨ï name, ­  ᥬ ­â¨ªã
\ ¢ë¯®«­¥­¨ï name, ¤ ­­ãî ­¨¦¥. ‚®§¢à â¨âì ã¯à ¢«¥­¨¥ ¢ ¢ë§ë¢ î饥 ®¯à¥¤¥-
\ «¥­¨¥, § ¤ ­­®¥ nest-sys1. <EFBFBD>¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ name
\ ­¥ ¡ë«® ®¯à¥¤¥«¥­® ç¥à¥§ CREATE ¨«¨ ®¯à¥¤¥«¥­­®¥ ¯®«ì§®¢ â¥«¥¬ á«®¢®,
\ ¢ë§ë¢ î饥 CREATE.
\ ˆ­¨æ¨ «¨§ æ¨ï: ( i*x -- i*x a-addr ) ( R: -- nest-sys2 )
\ ‘®åà ­¨âì § ¢¨áïéãî ®â ॠ«¨§ æ¨¨ ¨­ä®à¬ æ¨î nest-sys2 ® ¢ë§ë¢ î饬
\ ®¯à¥¤¥«¥­¨¨. <20>®«®¦¨âì  ¤à¥á ¯®«ï ¤ ­­ëå name ­  á⥪. <20>«¥¬¥­âë á⥪ 
\ i*x ¯à¥¤áâ ¢«ïîâ  à£ã¬¥­âë name.
\ name ‚믮«­¥­¨¥: ( i*x -- j*x )
\ ‚믮«­¨âì ç áâì ®¯à¥¤¥«¥­¨ï, ª®â®à ï ­ ç¨­ ¥âáï á ᥬ ­â¨ª¨ ¨­¨æ¨ «¨§ æ¨¨,
\ ¤®¡ ¢«¥­­®© DOES>, ª®â®à®¥ ¬®¤¨ä¨æ¨à®¢ «® name. <20>«¥¬¥­âë á⥪  i*x ¨ j*x
\ ¯à¥¤áâ ¢«ïîâ  à£ã¬¥­âë ¨ १ã«ìâ âë á«®¢  name, ᮮ⢥âá⢥­­®.
['] (DOES1) COMPILE,
['] (DOES2) COMPILE, \ ['] C-R> MACRO,
; IMMEDIATE
: VOCABULARY ( "<spaces>name" -- )
\ ‘®§¤ âì ᯨ᮪ á«®¢ á ¨¬¥­¥¬ name. ‚믮«­¥­¨¥ name § ¬¥­¨â ¯¥à¢ë© ᯨ᮪
\ ¢ ¯®à浪¥ ¯®¨áª  ­  ᯨ᮪ á ¨¬¥­¥¬ name.
WORDLIST DUP
CREATE
,
LATEST OVER CELL+ ! ( áá뫪  ­  ¨¬ï á«®¢ àï )
GET-CURRENT SWAP PAR! ( á«®¢ àì-¯à¥¤®ª )
\ FORTH-WORDLIST SWAP CLASS! ( ª« áá )
VOC
( DOES> ­¥ à ¡®â ¥â ¢ í⮬ –Š)
(DOES1) (DOES2) \ â ª ᤥ« « ¡ë DOES>, ®¯à¥¤¥«¥­­ë© ¢ëè¥
@ CONTEXT !
;
: VARIABLE ( "<spaces>name" -- ) \ 94
\ <20>யãáâ¨âì ¢¥¤ã騥 ¯à®¡¥«ë. ‚뤥«¨âì name, ®£à ­¨ç¥­­®¥ ¯à®¡¥«®¬.
\ ‘®§¤ âì ®¯à¥¤¥«¥­¨¥ ¤«ï name á ᥬ ­â¨ª®© ¢ë¯®«­¥­¨ï, ¤ ­­®© ­¨¦¥.
\ ‡ à¥§¥à¢¨à®¢ âì ®¤­ã ï祩ªã ¯à®áâà ­á⢠ ¤ ­­ëå á ¢ë஢­¥­­ë¬  ¤à¥á®¬.
\ name ¨á¯®«ì§ã¥âáï ª ª "¯¥à¥¬¥­­ ï".
\ name ‚믮«­¥­¨¥: ( -- a-addr )
\ a-addr -  ¤à¥á § à¥§¥à¢¨à®¢ ­­®© ï祩ª¨. ‡  ¨­¨æ¨ «¨§ æ¨î ï祩ª¨ ®â¢¥ç ¥â
\ ¯à®£à ¬¬ 
CREATE
0 ,
;
: CONSTANT ( x "<spaces>name" -- ) \ 94
\ <20>யãáâ¨âì ¢¥¤ã騥 ¯à®¡¥«ë. ‚뤥«¨âì name, ®£à ­¨ç¥­­®¥ ¯à®¡¥«®¬.
\ ‘®§¤ âì ®¯à¥¤¥«¥­¨¥ ¤«ï name á ᥬ ­â¨ª®© ¢ë¯®«­¥­¨ï, ¤ ­­®© ­¨¦¥.
\ name ¨á¯®«ì§ã¥âáï ª ª "ª®­áâ ­â ".
\ name ‚믮«­¥­¨¥: ( -- x )
\ <20>®«®¦¨âì x ­  á⥪.
HEADER
CONSTANT-CODE COMPILE, ,
;
: VALUE ( x "<spaces>name" -- ) \ 94 CORE EXT
\ <20>யãáâ¨âì ¢¥¤ã騥 ¯à®¡¥«ë. ‚뤥«¨âì name, ®£à ­¨ç¥­­®¥ ¯à®¡¥«®¬. ‘®§¤ âì
\ ®¯à¥¤¥«¥­¨¥ ¤«ï name á ᥬ ­â¨ª®© ¢ë¯®«­¥­¨ï, ®¯à¥¤¥«¥­­®© ­¨¦¥, á ­ ç «ì­ë¬
\ §­ ç¥­¨¥¬ à ¢­ë¬ x.
\ name ¨á¯®«ì§ã¥âáï ª ª "§­ ç¥­¨¥".
\ ‚믮«­¥­¨¥: ( -- x )
\ <20>®«®¦¨âì x ­  á⥪. ‡­ ç¥­¨¥ x - â®, ª®â®à®¥ ¡ë«® ¤ ­®, ª®£¤  ¨¬ï ᮧ¤ ¢ «®áì,
\ ¯®ª  ­¥ ¨á¯®«­¨âáï äà §  x TO name, § ¤ ¢ ­®¢®¥ §­ ç¥­¨¥ x,
\  áá®æ¨¨à®¢ ­­®¥ á name.
HEADER
CONSTANT-CODE COMPILE, ,
TOVALUE-CODE COMPILE,
;
: VECT ( -> )
( ᮧ¤ âì á«®¢®, ᥬ ­â¨ªã ¢ë¯®«­¥­¨ï ª®â®à®£® ¬®¦­® ¬¥­ïâì,
§ ¯¨áë¢ ï ¢ ­¥£® ­®¢ë© xt ¯® TO)
HEADER
VECT-CODE COMPILE, ['] NOOP ,
TOVALUE-CODE COMPILE,
;
: ->VARIABLE ( x "<spaces>name" -- ) \ 94
HEADER
CREATE-CODE COMPILE,
,
;
: USER-ALIGNED ( -- a-addr n )
USER-HERE 3 + 2 RSHIFT ( 4 / ) 4 * DUP
USER-HERE -
;
: USER-CREATE ( "<spaces>name" -- )
HEADER
HERE DOES>A ! ( ¤«ï DOES )
USER-CODE COMPILE,
USER-ALIGNED
USER-ALLOT ,
;
: USER ( "<spaces>name" -- ) \ «®ª «ì­ë¥ ¯¥à¥¬¥­­ë¥ ¯®â®ª 
USER-CREATE
4 USER-ALLOT
;
' _TOUSER-VALUE-CODE TO TOUSER-VALUE-CODE
: USER-VALUE ( "<spaces>name" -- ) \ 94 CORE EXT
HEADER
USER-VALUE-CODE COMPILE,
USER-ALIGNED SWAP ,
CELL+ USER-ALLOT
TOUSER-VALUE-CODE COMPILE,
;
: ->VECT ( x -> )
HEADER
VECT-CODE COMPILE, ,
TOVALUE-CODE COMPILE,
;
: : _: ;
: _: ( C: "<spaces>name" -- colon-sys ) \ 94
\ <20>யãáâ¨âì ¢¥¤ã騥 à §¤¥«¨â¥«¨. ‚뤥«¨âì ¨¬ï, ®£à ­¨ç¥­­®¥ ¯à®¡¥«®¬.
\ ‘®§¤ âì ®¯à¥¤¥«¥­¨¥ ¤«ï ¨¬¥­¨, ­ §ë¢ ¥¬®¥ "®¯à¥¤¥«¥­¨¥ ç¥à¥§ ¤¢®¥â®ç¨¥".
\ “áâ ­®¢¨âì á®áâ®ï­¨¥ ª®¬¯¨«ï樨 ¨ ­ ç âì ⥪ã饥 ®¯à¥¤¥«¥­¨¥, ¯®«ã稢
\ colon-sys. „®¡ ¢¨âì ᥬ ­â¨ªã ¨­¨æ¨ «¨§ æ¨¨, ®¯¨á ­­ãî ­¨¦¥, ¢ ⥪ã饥
\ ®¯à¥¤¥«¥­¨¥. ‘¥¬ ­â¨ª  ¢ë¯®«­¥­¨ï ¡ã¤¥â ®¯à¥¤¥«¥­  á«®¢ ¬¨, ᪮¬¯¨«¨à®-
\ ¢ ­­ë¬¨ ¢ ⥫® ®¯à¥¤¥«¥­¨ï. ’¥ªã饥 ®¯à¥¤¥«¥­¨¥ ¤®«¦­® ¡ëâì ­¥¢¨¤¨¬®
\ ¯à¨ ¯®¨áª¥ ¢ á«®¢ à¥ ¤® â¥å ¯®à, ¯®ª  ­¥ ¡ã¤¥â § ¢¥à襭®.
\ ˆ­¨æ¨ «¨§ æ¨ï: ( i*x -- i*x ) ( R: -- nest-sys )
\ ‘®åà ­¨âì ¨­ä®à¬ æ¨î nest-sys ® ¢ë§®¢¥ ®¯à¥¤¥«¥­¨ï. ‘®áâ®ï­¨¥ á⥪ 
\ i*x ¯à¥¤áâ ¢«ï¥â  à£ã¬¥­âë ¨¬¥­¨.
\ ˆ¬ï ‚믮«­¥­¨¥: ( i*x -- j*x )
\ ‚믮«­¨âì ®¯à¥¤¥«¥­¨¥ ¨¬¥­¨. ‘®áâ®ï­¨ï á⥪  i*x ¨ j*x ¯à¥¤áâ ¢«ïîâ
\  à£ã¬¥­âë ¨ १ã«ìâ âë ¨¬¥­¨ ᮮ⢥âá⢥­­®.
PARSE-WORD _SHEADER ]
HERE TO :-SET
;
\ S" ~mak\CompIF.f" INCLUDED

34
programs/develop/SPForth/src/compiler/spf_error.f Normal file
View File

@ -0,0 +1,34 @@
( Îáðàáîòêà îøèáîê.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
Ðåâèçèÿ: Cåíòÿáðü 1999
)
VECT ERROR \ îáðàáîò÷èê îøèáîê (ABORT)
VECT (ABORT")
: (ABORT1") ( flag c-addr -- )
SWAP IF COUNT ER-U ! ER-A ! -2 THROW ELSE DROP THEN
;
CREATE ERRTIB C/L 1+ ALLOT
CREATE ERRFILE C/L 1+ ALLOT
VARIABLE ER>IN
VARIABLE SAVEERR?
VARIABLE >IN_WORD
: SAVEERR
DUP SAVEERR? @ AND
IF SOURCE ERRTIB $! >IN_WORD @ ER>IN ! SAVEERR? OFF
SOURCE-ID 999 HERE WITHIN
IF SOURCE-ID .NAME ZCOUNT C/L UMIN ERRFILE $!
THEN
THEN ;
: ERROR_DO
SAVEERR
CR ERRFILE COUNT TYPE
CR ERRTIB COUNT TYPE
CR ER>IN @ BEGIN SPACE 1- DUP 0 MAX 0= UNTIL ." ^" DROP
CR ." ERR=" .
CR S0 @ SP! STATE 0!
;

149
programs/develop/SPForth/src/compiler/spf_find.f Normal file
View File

@ -0,0 +1,149 @@
( <20>®¨áª á«®¢ ¢ á«®¢ àïå ¨ ã¯à ¢«¥­¨¥ ¯®à浪®¬ ¯®¨áª .
Ž‘-­¥§ ¢¨á¨¬ë¥ ®¯à¥¤¥«¥­¨ï.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
<20>८¡à §®¢ ­¨¥ ¨§ 16-à §à來®£® ¢ 32-à §àï¤­ë© ª®¤ - 1995-96££
<20>¥¢¨§¨ï - ᥭâï¡àì 1999
Œ®¤¨ä¨æ¨à®¢ ­­® Œ ªá¨¬®¢ë¬ Œ.Ž.
email:mak@mail.rtc.neva.ru
http://informer.rtc.neva.ru/
â ¤ {812}105-92-03
â à {812}552-47-64
)
VECT FIND
0x10 CELLS CONSTANT CONTEXT_SIZE
CREATE SEARCH-BUFF 0x81 ALLOT
Code ZSEARCH-WORDLIST ;( z-addr wid -- 0 | xt 1 | xt -1 ) \ 94 SEARCH
; <20> ©â¨ ®¯à¥¤¥«¥­¨¥, § ¤ ­­®¥ áâப®© c-addr u ¢ ᯨ᪥ á«®¢, ¨¤¥­â¨ä¨æ¨à㥬®¬
; wid. …᫨ ®¯à¥¤¥«¥­¨¥ ­¥ ­ ©¤¥­®, ¢¥à­ãâì ­®«ì.
; …᫨ ®¯à¥¤¥«¥­¨¥ ­ ©¤¥­®, ¢¥à­ãâì ¢ë¯®«­¨¬ë© ⮪¥­ xt ¨ ¥¤¨­¨æã (1), ¥á«¨
; ®¯à¥¤¥«¥­¨¥ ­¥¬¥¤«¥­­®£® ¨á¯®«­¥­¨ï, ¨­ ç¥ ¬¨­ãá ¥¤¨­¨æã (-1).
; PUSH WORD PTR [EBP]
MOV EDX, [EBP]
PUSH EDX
MOV EAX, [EAX]
PUSH EAX
LEA EBP, [EBP+4]
CALL {' GETPR}
test eax, eax
JZ END
LEA EBP, [EBP-4]
mov [ebp],eax
MOVZX EAX, BYTE PTR [EDX-9]
DEC EAX
OR EAX,1
END: RET
EndCode
: SEARCH-WORDLIST ( c-addr u wid -- 0 | xt 1 | xt -1 )
>R 0x7F AND SEARCH-BUFF ASCII-Z
R> ZSEARCH-WORDLIST
;
: SFIND ( addr len --- addr len 0| xt 1|xt -1 )
\ Search all word lists in the search order for the name in the
\ counted string at c-addr. If not found return the name address and 0.
\ If found return the execution token xt and -1 if the word is non-immediate
\ and 1 if the word is immediate.
CONTEXT
BEGIN DUP @
WHILE >R
2DUP R@ @ SEARCH-WORDLIST ?DUP
IF RDROP 2NIP EXIT \ Exit if found.
THEN
R> CELL+
REPEAT @
;
: FIND1 ( c-addr -- c-addr 0 | xt 1 | xt -1 ) \ 94 SEARCH
\ <20> áè¨à¨âì ᥬ ­â¨ªã CORE FIND á«¥¤ãî騬:
\ ˆáª âì ®¯à¥¤¥«¥­¨¥ á ¨¬¥­¥¬, § ¤ ­­ë¬ áâப®© á® áç¥â稪®¬ c-addr.
\ …᫨ ®¯à¥¤¥«¥­¨¥ ­¥ ­ ©¤¥­® ¯®á«¥ ¯à®á¬®âà  ¢á¥å ᯨ᪮¢ ¢ ¯®à浪¥ ¯®¨áª ,
\ ¢®§¢à â¨âì c-addr ¨ ­®«ì. …᫨ ®¯à¥¤¥«¥­¨¥ ­ ©¤¥­®, ¢®§¢à â¨âì xt.
\ …᫨ ®¯à¥¤¥«¥­¨¥ ­¥¬¥¤«¥­­®£® ¨á¯®«­¥­¨ï, ¢¥à­ãâì â ª¦¥ ¥¤¨­¨æã (1);
\ ¨­ ç¥ â ª¦¥ ¢¥à­ãâì ¬¨­ãá ¥¤¨­¨æã (-1). „«ï ¤ ­­®© áâப¨, §­ ç¥­¨ï,
\ ¢®§¢à é ¥¬ë¥ FIND ¢® ¢à¥¬ï ª®¬¯¨«ï樨, ¬®£ã⠮⫨ç âìáï ®â §­ ç¥­¨©,
\ ¢®§¢à é ¥¬ëå ­¥ ¢ ०¨¬¥ ª®¬¯¨«ï樨.
COUNT SFIND
DUP 0= IF 2DROP 1- 0 THEN ;
: DEFINITIONS ( -- ) \ 94 SEARCH
\ ‘¤¥« âì ᯨ᪮¬ ª®¬¯¨«ï樨 â®â ¦¥ ᯨ᮪ á«®¢, çâ® ¨ ¯¥à¢ë© ᯨ᮪ ¢ ¯®à浪¥
\ ¯®¨áª . ˆ¬¥­  ¯®á«¥¤ãîé¨å ®¯à¥¤¥«¥­¨© ¡ã¤ãâ ¯®¬¥é âìáï ¢ ᯨ᮪ ª®¬¯¨«ï樨.
\ <20>®á«¥¤ãî騥 ¨§¬¥­¥­¨ï ¯®à浪  ¯®¨áª  ­¥ ¢«¨ïîâ ­  ᯨ᮪ ª®¬¯¨«ï樨.
CONTEXT @ SET-CURRENT
;
: GET-ORDER_DROP ( CONTEXT -- widn .. wid1 )
DUP @ DUP IF >R CELL+ RECURSE R> EXIT THEN 2DROP ;
: GET-ORDER ( -- widn .. wid1 n )
DEPTH >R
CONTEXT GET-ORDER_DROP
DEPTH R> - ;
: SET-ORDER ( widn .. wid1 n -- )
DUP 0<
IF DROP ONLY
ELSE CONTEXT CONTEXT_SIZE ERASE
0
?DO CONTEXT I CELLS+ !
LOOP
THEN ;
: FORTH ( -- ) \ 94 SEARCH EXT
\ <20>८¡à §®¢ âì ¯®à冷ª ¯®¨áª , á®áâ®ï騩 ¨§ widn, ...wid2, wid1 (£¤¥ wid1
\ ¯à®á¬ âਢ ¥âáï ¯¥à¢ë¬) ¢ widn,... wid2, widFORTH-WORDLIST.
FORTH-WORDLIST CONTEXT !
;
: ONLY ( -- ) \ 94 SEARCH EXT
\ “áâ ­®¢¨âì ᯨ᮪ ¯®¨áª  ­  § ¢¨áï騩 ®â ॠ«¨§ æ¨¨ ¬¨­¨¬ «ì­ë© ᯨ᮪ ¯®¨áª .
\ Œ¨­¨¬ «ì­ë© ᯨ᮪ ¯®¨áª  ¤®«¦¥­ ¢ª«îç âì á«®¢  FORTH-WORDLIST ¨ SET-ORDER.
CONTEXT CELL+ 0!
FORTH
;
: ALSO ( -- ) \ 94 SEARCH EXT
\ <20>८¡à §®¢ âì ¯®à冷ª ¯®¨áª , á®áâ®ï騩 ¨§ widn, ...wid2, wid1 (£¤¥ wid1
\ ¯à®á¬ âਢ ¥âáï ¯¥à¢ë¬) ¢ widn,... wid2, wid1, wid1. <20>¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï
\ ¢®§­¨ª ¥â, ¥á«¨ ¢ ¯®à浪¥ ¯®¨áª  ᫨誮¬ ¬­®£® ᯨ᪮¢.
CONTEXT CONTEXT CELL+ CONTEXT_SIZE CMOVE> ;
: PREVIOUS ( -- ) \ 94 SEARCH EXT
\ <20>८¡à §®¢ âì ¯®à冷ª ¯®¨áª , á®áâ®ï騩 ¨§ widn, ...wid2, wid1 (£¤¥ wid1
\ ¯à®á¬ âਢ ¥âáï ¯¥à¢ë¬) ¢ widn,... wid2. <20>¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï ¢®§­¨ª ¥â,
\ ¥á«¨ ¯®à冷ª ¯®¨áª  ¡ë« ¯ãáâ ¯¥à¥¤ ¢ë¯®«­¥­¨¥¬ PREVIOUS.
_PREVIOUS ;
: _PREVIOUS ( -- ) \ 94 SEARCH EXT
CONTEXT CELL+ CONTEXT CONTEXT_SIZE CMOVE ;
: VOC-NAME. ( wid -- ) \ ­ ¯¥ç â âì ¨¬ï ᯨ᪠ á«®¢, ¥á«¨ ®­ ¨¬¥­®¢ ­
DUP FORTH-WORDLIST = IF DROP ." FORTH" EXIT THEN
\ DUP KERNEL-WORDLIST = IF DROP ." KERNEL" EXIT THEN
DUP CELL+ @ DUP IF ID. DROP ELSE DROP ." <NONAME>:" U. THEN
;
: ORDER ( -- ) \ 94 SEARCH EXT
\ <20>®ª § âì ᯨ᪨ ¢ ¯®à浪¥ ¯®¨áª , ®â ¯¥à¢®£® ¯à®á¬ âਢ ¥¬®£® ᯨ᪠ ¤®
\ ¯®á«¥¤­¥£®. ’ ª¦¥ ¯®ª § âì ᯨ᮪ á«®¢, ªã¤  ¯®¬¥é îâáï ­®¢ë¥ ®¯à¥¤¥«¥­¨ï.
\ ”®à¬ â ¨§®¡à ¦¥­¨ï § ¢¨á¨â ®â ॠ«¨§ æ¨¨.
\ ORDER ¬®¦¥â ¡ëâì ॠ«¨§®¢ ­ á ¨á¯®«ì§®¢ ­¨¥¬ á«®¢ ä®à¬ â­®£® ¯à¥®¡à §®¢ ­¨ï
\ ç¨á¥«. ‘«¥¤®¢ â¥«ì­® ®­ ¬®¦¥â à §àãè¨âì ¯¥à¥¬¥é ¥¬ãî ®¡« áâì,
\ ¨¤¥­â¨ä¨æ¨à㥬ãî #>.
GET-ORDER ." Context: "
0 ?DO ( DUP .) VOC-NAME. SPACE LOOP CR
." Current: " GET-CURRENT VOC-NAME. CR
;
: LATEST ( -> NFA )
CURRENT @ @
;

428
programs/develop/SPForth/src/compiler/spf_find.f_L Normal file
View File

@ -0,0 +1,428 @@
ZZ=D0 ( <20>®¨áª á«®¢ ¢ á«®¢ àïå ¨ ã¯à ¢«¥­¨¥ ¯®à浪®¬ ¯®¨áª .
Ž‘-­¥§ ¢¨á¨¬ë¥ ®¯à¥¤¥«¥­¨ï.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
<20>८¡à §®¢ ­¨¥ ¨§ 16-à §à來®£® ¢ 32-à §àï¤­ë© ª®¤ - 1995-96££
<20>¥¢¨§¨ï - ᥭâï¡àì 1999
Œ®¤¨ä¨æ¨à®¢ ­­® Œ ªá¨¬®¢ë¬ Œ.Ž.
email:mak@mail.rtc.neva.ru
http://informer.rtc.neva.ru/
â ¤ {812}105-92-03
â à {812}552-47-64
)
VECT FIND
5A1F35 50 1F 5A 00 00 04 46 49 4E 44 A3 1E 5A 00 00 00 P.Z...FIND£.Z...
5A1F45 00 00 00 00 00 00 00 00 00 00 00 E8 93 01 FA FF ...........è“.úÿ
5A1F55 40 D2 59 00 E8 A6 01 FA FF @ÒY.è¦.úÿ
0x10 CELLS CONSTANT CONTEXT_SIZE
5A1F5E 80 1F 5A 00 00 0C 43 4F 4E 54 45 58 54 5F 53 49 €.Z...CONTEXT_SI
5A1F6E 5A 45 3A 1F 5A 00 00 00 00 00 00 00 00 00 00 00 ZE:.Z...........
5A1F7E 00 00 E8 B7 00 FA FF 40 00 00 00 ..è·.úÿ@...
CREATE SEARCH-BUFF 0x81 ALLOT
5A1F89 A0 1F 5A 00 00 0B 53 45 41 52 43 48 2D 42 55 46  .Z...SEARCH-BUF
5A1F99 46 63 1F 5A 00 00 00 E8 77 00 FA FF 00 00 00 00 Fc.Z...èw.úÿ....
5A1FA9 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................
5A1FB9 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................
5A1FC9 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................
5A2026 4D bytes
Code ZSEARCH-WORDLIST ;( z-addr wid -- 0 | xt 1 | xt -1 ) \ 94 SEARCH
5A2026 40 20 5A 00 00 10 5A 53 45 41 52 43 48 2D 57 4F @ Z...ZSEARCH-WO
5A2036 52 44 4C 49 53 54 8E 1F 5A 00 RDLISTŽ.Z.
; <20> ©â¨ ®¯à¥¤¥«¥­¨¥, § ¤ ­­®¥ áâப®© c-addr u ¢ ᯨ᪥ á«®¢, ¨¤¥­â¨ä¨æ¨à㥬®¬
; wid. …᫨ ®¯à¥¤¥«¥­¨¥ ­¥ ­ ©¤¥­®, ¢¥à­ãâì ­®«ì.
; …᫨ ®¯à¥¤¥«¥­¨¥ ­ ©¤¥­®, ¢¥à­ãâì ¢ë¯®«­¨¬ë© ⮪¥­ xt ¨ ¥¤¨­¨æã (1), ¥á«¨
; ®¯à¥¤¥«¥­¨¥ ­¥¬¥¤«¥­­®£® ¨á¯®«­¥­¨ï, ¨­ ç¥ ¬¨­ãá ¥¤¨­¨æã (-1).
; PUSH WORD PTR [EBP]
MOV EDX, [EBP]
5A2040 8B 55 00 ‹U.
PUSH EDX
5A2043 52 R
MOV EAX, [EAX]
5A2044 8B 00 ‹.
PUSH EAX
5A2046 50 P
LEA EBP, [EBP+4]
5A2047 8D 6D 04 <20>m.
CALL {' GETPR}
5A204A E8 31 9E FC FF è1žüÿ
TEST EAX, EAX
5A204F 85 C0 …À
JZ m1
5A2051 0F 84 0E 00 00 00 .„....
LEA EBP, [EBP-4]
5A2057 8D 6D FC <20>mü
MOV [EBP], EAX
5A205A 89 45 00 ‰E.
MOVZX EAX, BYTE PTR [EDX-9]
5A205D 0F B6 42 F7 .¶B÷
DEC EAX
5A2061 48 H
OR EAX, 1
5A2062 83 C8 01 ƒÈ.
m1: RET
5A2065 C3 Ã
EndCode
: SEARCH-WORDLIST ( c-addr u wid -- 0 | xt 1 | xt -1 )
5A2066 80 20 5A 00 00 0F 53 45 41 52 43 48 2D 57 4F 52 € Z...SEARCH-WOR
5A2076 44 4C 49 53 54 2B 20 5A 00 00 DLIST+ Z..
>R 0x7F AND SEARCH-BUFF ASCII-Z
5A2080 50 B8 7F 00 00 00 23 45 00 8D 6D 04 E8 0F FF FF P¸...#E.<2E>m.è.ÿÿ
5A2090 FF E8 2A C0 FF FF ÿè*Àÿÿ
R> ZSEARCH-WORDLIST
5A2096 89 45 FC 58 8D 6D FC E8 9E FF FF FF ‰EüX<C3BC>müèžÿÿÿ
;
5A20A2 C3 Ã
: SFIND ( addr len --- addr len 0| xt 1|xt -1 )
5A20A3 C0 20 5A 00 00 05 53 46 49 4E 44 6B 20 5A 00 00 À Z...SFINDk Z..
5A20B3 00 00 00 00 00 00 00 00 00 00 00 00 00 .............
\ Search all word lists in the search order for the name in the
\ counted string at c-addr. If not found return the name address and 0.
\ If found return the execution token xt and -1 if the word is non-immediate
\ and 1 if the word is immediate.
CONTEXT
5A20C0 E8 23 07 FB FF è#.ûÿ
BEGIN DUP @
5A20C5 90 90 90 89 45 FC 8B 00 0B C0 8B <20><><EFBFBD>‰Eü‹..À‹
WHILE >R
5A20D0 45 FC 0F 84 41 00 00 00 50 8B 45 00 8B 55 04 Eü.„A...P‹E.‹U.
2DUP R@ @ SEARCH-WORDLIST ?DUP
5A20DF 89 45 00 89 55 FC 89 45 F8 8B 04 24 8B 00 8D 6D ‰E.‰Uü‰Eø‹.$‹.<2E>m
5A20EF F8 E8 8B FF FF FF E8 96 AA FF FF øè‹ÿÿÿè–ªÿÿ
IF RDROP 2NIP EXIT \ Exit if found.
5A20FA 0B C0 8B 45 00 8D 6D 04 74 09 83 C4 04 E8 04 C1 .À‹E.<2E>m.t.ƒÄ.è.Á
5A210A FF FF C3 ÿÿÃ
THEN
R> CELL+
5A210D 89 45 FC 58 8D 40 04 8D 6D FC ‰EüX<C3BC>@.<2E>mü
REPEAT @
5A2117 EB AF 8B 00 믋.
;
5A211B C3 Ã
: FIND1 ( c-addr -- c-addr 0 | xt 1 | xt -1 ) \ 94 SEARCH
5A211C 30 21 5A 00 00 05 46 49 4E 44 31 A8 20 5A 00 00 0!Z...FIND1¨ Z..
5A212C 00 00 00 00 ....
\ <20> áè¨à¨âì ᥬ ­â¨ªã CORE FIND á«¥¤ãî騬:
\ ˆáª âì ®¯à¥¤¥«¥­¨¥ á ¨¬¥­¥¬, § ¤ ­­ë¬ áâப®© á® áç¥â稪®¬ c-addr.
\ …᫨ ®¯à¥¤¥«¥­¨¥ ­¥ ­ ©¤¥­® ¯®á«¥ ¯à®á¬®âà  ¢á¥å ᯨ᪮¢ ¢ ¯®à浪¥ ¯®¨áª ,
\ ¢®§¢à â¨âì c-addr ¨ ­®«ì. …᫨ ®¯à¥¤¥«¥­¨¥ ­ ©¤¥­®, ¢®§¢à â¨âì xt.
\ …᫨ ®¯à¥¤¥«¥­¨¥ ­¥¬¥¤«¥­­®£® ¨á¯®«­¥­¨ï, ¢¥à­ãâì â ª¦¥ ¥¤¨­¨æã (1);
\ ¨­ ç¥ â ª¦¥ ¢¥à­ãâì ¬¨­ãá ¥¤¨­¨æã (-1). „«ï ¤ ­­®© áâப¨, §­ ç¥­¨ï,
\ ¢®§¢à é ¥¬ë¥ FIND ¢® ¢à¥¬ï ª®¬¯¨«ï樨, ¬®£ã⠮⫨ç âìáï ®â §­ ç¥­¨©,
\ ¢®§¢à é ¥¬ëå ­¥ ¢ ०¨¬¥ ª®¬¯¨«ï樨.
COUNT SFIND
5A2130 8D 50 01 89 55 FC 0F B6 00 8D 6D FC E8 7F FF FF <20>P.‰Uü.¶.<2E>müèÿÿ
5A2140 FF ÿ
DUP 0= IF 2DROP 1- 0 THEN ;
5A2141 0B C0 75 0E 8B 45 04 8D 40 FF 89 45 04 33 C0 8D .Àu.‹E.<2E>@ÿ‰E.3À<EFBFBD>
5A2151 6D 04 C3 m.Ã
: DEFINITIONS ( -- ) \ 94 SEARCH
5A2154 70 21 5A 00 00 0B 44 45 46 49 4E 49 54 49 4F 4E p!Z...DEFINITION
5A2164 53 21 21 5A 00 00 00 00 00 00 00 00 S!!Z........
\ ‘¤¥« âì ᯨ᪮¬ ª®¬¯¨«ï樨 â®â ¦¥ ᯨ᮪ á«®¢, çâ® ¨ ¯¥à¢ë© ᯨ᮪ ¢ ¯®à浪¥
\ ¯®¨áª . ˆ¬¥­  ¯®á«¥¤ãîé¨å ®¯à¥¤¥«¥­¨© ¡ã¤ãâ ¯®¬¥é âìáï ¢ ᯨ᮪ ª®¬¯¨«ï樨.
\ <20>®á«¥¤ãî騥 ¨§¬¥­¥­¨ï ¯®à浪  ¯®¨áª  ­¥ ¢«¨ïîâ ­  ᯨ᮪ ª®¬¯¨«ï樨.
CONTEXT @ SET-CURRENT
5A2170 E8 73 06 FB FF 8B 00 E8 C0 4E FA FF ès.ûÿ‹.èÀNúÿ
;
5A217C C3 Ã
: GET-ORDER_DROP ( CONTEXT -- widn .. wid1 )
5A217D A0 21 5A 00 00 0E 47 45 54 2D 4F 52 44 45 52 5F  !Z...GET-ORDER_
5A218D 44 52 4F 50 59 21 5A 00 00 00 00 00 00 00 00 00 DROPY!Z.........
5A219D 00 00 00 ...
DUP @ DUP IF >R CELL+ RECURSE R> EXIT THEN 2DROP ;
5A21A0 89 45 FC 8B 00 8D 6D FC 0B C0 74 17 50 8B 45 00 ‰Eü‹.<2E>mü.Àt.P‹E.
5A21B0 8D 40 04 8D 6D 04 E8 E5 FF FF FF 89 45 FC 58 8D <20>@.<2E>m.èåÿÿÿ‰EüX<C3BC>
5A21C0 6D FC C3 8B 45 04 8D 6D 08 C3 müËE.<2E>m.Ã
: GET-ORDER ( -- widn .. wid1 n )
5A21CA E0 21 5A 00 00 09 47 45 54 2D 4F 52 44 45 52 82 à!Z...GET-ORDER‚
5A21DA 21 5A 00 00 00 00 !Z....
DEPTH >R
5A21E0 E8 EB E4 FF FF 50 8B 45 00 8D 6D 04 èëäÿÿP‹E.<2E>m.
CONTEXT GET-ORDER_DROP
5A21EC E8 F7 05 FB FF E8 AA FF FF FF è÷.ûÿèªÿÿÿ
DEPTH R> - ;
5A21F6 E8 D5 E4 FF FF 89 45 FC 58 F7 D8 03 45 FC C3 èÕäÿÿ‰EüX÷Ø.EüÃ
: SET-ORDER ( widn .. wid1 n -- )
5A2205 20 22 5A 00 00 09 53 45 54 2D 4F 52 44 45 52 CF "Z...SET-ORDERÏ
5A2215 21 5A 00 00 00 00 00 00 00 00 00 !Z.........
DUP 0<
5A2220 0B C0 7D 10 8B 45 00 8D 6D .À}.‹E.<2E>m
IF DROP ONLY
5A2229 04 E8 A9 07 FB FF E9 63 00 00 .è©.ûÿéc..
ELSE CONTEXT CONTEXT_SIZE ERASE
5A2233 00 E8 AF 05 FB FF E8 42 FD FF FF E8 5D BC FF FF .è¯.ûÿèBýÿÿè]¼ÿÿ
0
5A2243 89 45 FC 33 C0 8D 6D 04 ‰Eü3À<33>m.
?DO CONTEXT I CELLS+ !
5A224B BB 97 22 5A 00 3B 45 F8 75 05 8B 45 FC FF E3 53 »—"Z.;Eøu.‹EüÿãS
5A225B BB 00 00 00 80 2B 5D F8 53 03 D8 53 8B 45 FC E8 »...€+]øS.ØS‹Eüè
5A226B 79 05 FB FF 89 45 FC 8B 04 24 2B 44 24 04 8D 04 y.ûÿ‰Eü‹.$+D$.<2E>.
5A227B 85 00 00 00 00 03 45 FC 8B 55 00 89 10 8B 45 04 ….....Eü‹U.‰.‹E.
5A228B 8D 6D 08 <20>m.
LOOP
5A228E FF 04 24 71 D7 8D 64 24 0C ÿ.$q×<71>d$.
THEN ;
5A2297 C3 Ã
: FORTH ( -- ) \ 94 SEARCH EXT
5A2298 B0 22 5A 00 00 05 46 4F 52 54 48 0A 22 5A 00 00 °"Z...FORTH."Z..
5A22A8 00 00 00 00 00 00 00 00 ........
\ <20>८¡à §®¢ âì ¯®à冷ª ¯®¨áª , á®áâ®ï騩 ¨§ widn, ...wid2, wid1 (£¤¥ wid1
\ ¯à®á¬ âਢ ¥âáï ¯¥à¢ë¬) ¢ widn,... wid2, widFORTH-WORDLIST.
FORTH-WORDLIST CONTEXT !
5A22B0 E8 3F FF FA FF E8 2E 05 FB FF 8B 55 00 89 10 8B è?ÿúÿè..ûÿ‹U.‰.‹
5A22C0 45 04 8D 6D 08 E.<2E>m.
;
5A22C5 C3 Ã
: ONLY ( -- ) \ 94 SEARCH EXT
5A22C6 E0 22 5A 00 00 04 4F 4E 4C 59 9D 22 5A 00 00 00 à"Z...ONLY<4C>"Z...
5A22D6 00 00 00 00 00 00 00 00 00 00 ..........
\ “áâ ­®¢¨âì ᯨ᮪ ¯®¨áª  ­  § ¢¨áï騩 ®â ॠ«¨§ æ¨¨ ¬¨­¨¬ «ì­ë© ᯨ᮪ ¯®¨áª .
\ Œ¨­¨¬ «ì­ë© ᯨ᮪ ¯®¨áª  ¤®«¦¥­ ¢ª«îç âì á«®¢  FORTH-WORDLIST ¨ SET-ORDER.
CONTEXT CELL+ 0!
5A22E0 E8 03 05 FB FF 8D 40 04 C7 00 00 00 00 00 8B 45 è..ûÿ<C3BB>@.Ç.....‹E
5A22F0 00 8D 6D 04 .<2E>m.
FORTH
5A22F4 E8 B7 FF FF FF è·ÿÿÿ
;
5A22F9 C3 Ã
: ALSO ( -- ) \ 94 SEARCH EXT
5A22FA 10 23 5A 00 00 04 41 4C 53 4F CB 22 5A 00 00 00 .#Z...ALSOË"Z...
5A230A 00 00 00 00 00 00 ......
\ <20>८¡à §®¢ âì ¯®à冷ª ¯®¨áª , á®áâ®ï騩 ¨§ widn, ...wid2, wid1 (£¤¥ wid1
\ ¯à®á¬ âਢ ¥âáï ¯¥à¢ë¬) ¢ widn,... wid2, wid1, wid1. <20>¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï
\ ¢®§­¨ª ¥â, ¥á«¨ ¢ ¯®à浪¥ ¯®¨áª  ᫨誮¬ ¬­®£® ᯨ᪮¢.
CONTEXT CONTEXT CELL+ CONTEXT_SIZE CMOVE> ;
5A2310 E8 D3 04 FB FF E8 CE 04 FB FF 8D 40 04 E8 5E FC èÓ.ûÿèÎ.ûÿ<C3BB>@.è^ü
5A2320 FF FF E8 E9 B4 FF FF C3 ÿÿèé´ÿÿÃ
: PREVIOUS ( -- ) \ 94 SEARCH EXT
5A2328 40 23 5A 00 00 08 50 52 45 56 49 4F 55 53 FF 22 @#Z...PREVIOUSÿ"
5A2338 5A 00 00 00 00 00 00 00 Z.......
\ <20>८¡à §®¢ âì ¯®à冷ª ¯®¨áª , á®áâ®ï騩 ¨§ widn, ...wid2, wid1 (£¤¥ wid1
\ ¯à®á¬ âਢ ¥âáï ¯¥à¢ë¬) ¢ widn,... wid2. <20>¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï ¢®§­¨ª ¥â,
\ ¥á«¨ ¯®à冷ª ¯®¨áª  ¡ë« ¯ãáâ ¯¥à¥¤ ¢ë¯®«­¥­¨¥¬ PREVIOUS.
_PREVIOUS ;
5A2340 E8 9B 9D FC FF C3 è›<C3A8>üÿÃ
: _PREVIOUS ( -- ) \ 94 SEARCH EXT
5A2346 60 23 5A 00 00 09 5F 50 52 45 56 49 4F 55 53 2D `#Z..._PREVIOUS-
5A2356 23 5A 00 00 00 00 00 00 00 00 #Z........
CONTEXT CELL+ CONTEXT CONTEXT_SIZE CMOVE ;
5A2360 E8 83 04 FB FF 8D 40 04 E8 7B 04 FB FF E8 0E FC èƒ.ûÿ<C3BB>@.è{.ûÿè.ü
5A2370 FF FF E8 49 B4 FF FF C3 ÿÿèI´ÿÿÃ
: VOC-NAME. ( wid -- ) \ ­ ¯¥ç â âì ¨¬ï ᯨ᪠ á«®¢, ¥á«¨ ®­ ¨¬¥­®¢ ­
5A2378 90 23 5A 00 00 09 56 4F 43 2D 4E 41 4D 45 2E 4B <20>#Z...VOC-NAME.K
5A2388 23 5A 00 00 00 00 00 00 #Z......
DUP FORTH-WORDLIST = IF DROP ." FORTH" EXIT THEN
5A2390 89 45 FC 8D 6D FC E8 59 FE FA FF 33 45 00 8B 45 ‰Eü<45>müèYþúÿ3E.‹E
5A23A0 04 8D 6D 08 0F 85 18 00 00 00 8B 45 00 8D 6D 04 .<2E>m..…....‹E.<2E>m.
5A23B0 E8 A7 FD F9 FF 05 46 4F 52 54 48 00 E8 2F 9A FC è§ýùÿ.FORTH.è/šü
5A23C0 FF C3 ÿÃ
\ DUP KERNEL-WORDLIST = IF DROP ." KERNEL" EXIT THEN
DUP CELL+ @ DUP IF ID. DROP ELSE DROP ." <NONAME>:" U. THEN
5A23C2 89 45 FC 8B 40 04 8D 6D FC 0B C0 74 10 E8 CC F7 ‰Eü‹@.<2E>mü.Àt.èÌ÷
5A23D2 FF FF 8B 45 00 8D 6D 04 E9 20 00 00 00 8B 45 00 ÿÿ‹E.<2E>m.é ...‹E.
5A23E2 8D 6D 04 E8 72 FD F9 FF 09 3C 4E 4F 4E 41 4D 45 <20>m.èrýùÿ.<NONAME
5A23F2 3E 3A 00 E8 F6 99 FC FF E8 09 3D FA FF >:.èö™üÿè.=úÿ
;
5A23FF C3 Ã
: ORDER ( -- ) \ 94 SEARCH EXT
5A2400 10 24 5A 00 00 05 4F 52 44 45 52 7D 23 5A 00 00 .$Z...ORDER}#Z..
\ <20>®ª § âì ᯨ᪨ ¢ ¯®à浪¥ ¯®¨áª , ®â ¯¥à¢®£® ¯à®á¬ âਢ ¥¬®£® ᯨ᪠ ¤®
\ ¯®á«¥¤­¥£®. ’ ª¦¥ ¯®ª § âì ᯨ᮪ á«®¢, ªã¤  ¯®¬¥é îâáï ­®¢ë¥ ®¯à¥¤¥«¥­¨ï.
\ ”®à¬ â ¨§®¡à ¦¥­¨ï § ¢¨á¨â ®â ॠ«¨§ æ¨¨.
\ ORDER ¬®¦¥â ¡ëâì ॠ«¨§®¢ ­ á ¨á¯®«ì§®¢ ­¨¥¬ á«®¢ ä®à¬ â­®£® ¯à¥®¡à §®¢ ­¨ï
\ ç¨á¥«. ‘«¥¤®¢ â¥«ì­® ®­ ¬®¦¥â à §àãè¨âì ¯¥à¥¬¥é ¥¬ãî ®¡« áâì,
\ ¨¤¥­â¨ä¨æ¨à㥬ãî #>.
GET-ORDER ." Context: "
5A2410 E8 CB FD FF FF E8 42 FD F9 FF 09 43 6F 6E 74 65 èËýÿÿèBýùÿ.Conte
5A2420 78 74 3A 20 00 E8 C6 99 FC FF xt: .èÆ™üÿ
0 ?DO ( DUP .) VOC-NAME. SPACE LOOP CR
5A242A 89 45 FC 33 C0 8D 6D 04 BB 64 24 5A 00 3B 45 F8 ‰Eü3À<33>m.»d$Z.;Eø
5A243A 75 05 8B 45 FC FF E3 53 BB 00 00 00 80 2B 5D F8 u.‹EüÿãS»...€+]ø
5A244A 53 03 D8 53 8B 45 FC E8 3A FF FF FF E8 9D 38 FA S.ØS‹Eüè:ÿÿÿè<C3BF>8ú
5A245A FF FF 04 24 71 F1 8D 64 24 0C E8 7F 36 FA FF ÿÿ.$qñ<71>d$.è6úÿ
." Current: " GET-CURRENT VOC-NAME. CR
5A2469 E8 EE FC F9 FF 09 43 75 72 72 65 6E 74 3A 20 00 èîüùÿ.Current: .
5A2479 E8 72 99 FC FF 89 45 FC 8B 87 58 18 00 00 8D 6D èr™üÿ‰Eü‹‡X...<2E>m
5A2489 FC E8 01 FF FF FF E8 54 36 FA FF üè.ÿÿÿèT6úÿ
;
5A2494 C3 Ã
: LATEST ( -> NFA )
5A2495 B0 24 5A 00 00 06 4C 41 54 45 53 54 05 24 5A 00 °$Z...LATEST.$Z.
5A24A5 00 00 00 00 00 00 00 00 00 00 00 ...........
CURRENT @ @
5A24B0 E8 1B 4B FA FF 8B 00 8B 00 è.Kúÿ‹.‹.
;
5A24B9 C3 Ã
ZZ=D0

132
programs/develop/SPForth/src/compiler/spf_immed_control.f Normal file
View File

@ -0,0 +1,132 @@
( Слова немедленного выполнения, используемые при компиляции
структур управления в теле высокоуровневого определения.
ОС-независимые определения.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
Преобразование из 16-разрядного в 32-разрядный код - 1995-96гг
Ревизия - сентябрь 1999
)
: IF \ 94
\ Интерпретация: семантика неопределена.
\ Компиляция: ( C: -- orig )
\ Положить на управляющий стек позицию новой неразрешенной ссылки вперед orig.
\ Добавить семантику времени выполнения, данную ниже, к текущему определению.
\ Семантика незавершена, пока orig не разрешится, например, по THEN или ELSE.
\ Время выполнения: ( x -- )
\ Если все биты x нулевые, продолжать выполнение с позиции, заданной
\ разрешением orig.
?COMP DP @ ?BRANCH, >MARK 1
; IMMEDIATE
: ELSE \ 94
\ Интерпретация: семантика неопределена.
\ Компиляция: ( C: orig1 -- orig2 )
\ Положить на управляющий стек позицию новой неразрешенной ссылки вперед orig2.
\ Добавить семантику времени выполнения, данную ниже, к текущему определению.
\ Семантика незавершена, пока orig2 не разрешится (например, по THEN).
\ Разрешить ссылку вперед orig1, используя позицию следующей добавленной
\ семантики выполнения.
\ Время выполнения: ( -- )
\ Продолжить выполнение с позиции, заданной разрешением orig2.
?COMP DP @ BRANCH,
>ORESOLVE
>MARK 2
; IMMEDIATE
: THEN \ 94
\ Интерпретация: семантика неопределена.
\ Компиляция: ( C: orig -- )
\ Разрешить ссылку вперед orig, используя позицию семантики выполнения.
\ Добавить семантику времени выполнения, данную ниже, к текущему определению.
\ Время выполнения: ( -- )
\ Продолжить выполнение.
?COMP \ HERE TO :-SET
>ORESOLVE
; IMMEDIATE
: BREAK
POSTPONE EXIT POSTPONE THEN ; IMMEDIATE
: BEGIN \ 94
\ Интерпретация: семантика неопределена.
\ Компиляция: ( C: -- dest )
\ Положить следующую позицию передачи управления, dest, на управляющий стек.
\ Добавить семантику времени выполнения, данную ниже, к текущему определению.
\ Время выполнения: ( -- )
\ Продолжить выполнение.
?COMP
4 ALIGN-NOP
\ HERE TO :-SET
<MARK 3
; IMMEDIATE
: UNTIL \ 94
\ Интерпретация: семантика неопределена.
\ Компиляция: ( C: dest -- )
\ Добавить семантику времени выполнения, данную ниже, к текущему определению.
\ Разрешить ссылку назад dest.
\ Время выполнения: ( x -- )
\ Если все биты x нулевые, продолжать выполнение с позиции, заданной dest.
?COMP 3 <> IF -2004 THROW THEN \ ABORT" UNTIL без BEGIN !"
?BRANCH,
0xFFFFFF80 DP @ 4 - @ U<
IF DP @ 5 - W@ 0x3F0 + DP @ 6 - W! -4 ALLOT
THEN
; IMMEDIATE
: WHILE \ 94
\ Интерпретация: семантика неопределена.
\ Компиляция: ( C: dest -- orig dest )
\ Положить позицию новой неразрешенной ссылки вперед orig на управляющий стек
\ под имеющимся dest. Добавить семантику времени выполнения, данную ниже, к
\ текущему определению. Семантика незавершена, пока orig и dest не разрешатся
\ (например, по REPEAT).
\ Время выполнения: ( x -- )
\ Если все биты x нулевые, продолжать выполнение с позиции, заданной
\ разрешением orig.
?COMP [COMPILE] IF
2SWAP
; IMMEDIATE
: REPEAT \ 94
\ Интерпретация: семантика неопределена.
\ Компиляция: ( C: orig dest -- )
\ Добавить семантику времени выполнения, данную ниже, к текущему определению,
\ разрешив ссылку назад dest. Разрешить ссылку вперед orig, используя
\ позицию добавленной семантики выполнения.
\ Время выполнения: ( -- )
\ Продолжить выполнение с позиции, заданной dest.
?COMP
3 <> IF -2005 THROW THEN \ ABORT" REPEAT без BEGIN !"
DUP DP @ 2+ - DUP
SHORT?
IF SetJP 0xEB C, C, DROP
ELSE DROP BRANCH, THEN
>ORESOLVE
; IMMEDIATE
: AGAIN \ 94 CORE EXT
\ Интерпретация: семантика неопределена.
\ Компиляция: ( C: dest -- )
\ Добавить семантику времени выполнения, данную ниже, к текущему определению,
\ разрешив ссылку назад dest.
\ Время выполнения: ( -- )
\ Продолжить выполнение с позиции, заданной dest. Если другие управляющие слова
\ не используются, то любой программный код после AGAIN не будет выполняться.
?COMP 3 <> IF -2006 THROW THEN \ ABORT" AGAIN без BEGIN !"
DUP DP @ 2+ - DUP
SHORT?
IF SetJP 0xEB C, C, DROP
ELSE DROP BRANCH, THEN DP @ TO :-SET
; IMMEDIATE
: RECURSE \ 94
\ Итерпретация: семантика не определена.
\ Компиляция: ( -- )
\ Добавить семантику выполнения текущего определения в текущее определение.
\ Неоднозначная ситуация возникает, если RECURSE используется после DOES>.
?COMP
LAST-NON DUP 0=
IF DROP LATEST NAME> THEN _COMPILE,
; IMMEDIATE

147
programs/develop/SPForth/src/compiler/spf_immed_lit.f Normal file
View File

@ -0,0 +1,147 @@
( Слова немедленного выполнения, используемые при компиляции
числовых и строчных литералов в тело высокоуровневого определения.
ОС-независимые определения.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
Преобразование из 16-разрядного в 32-разрядный код - 1995-96гг
Ревизия - сентябрь 1999
Модифицированно Максимовым М.О.
email:mak@mail.rtc.neva.ru
http://informer.rtc.neva.ru/
т д {812}105-92-03
т р {812}552-47-64
)
: [LIT], DUP
[ 0x058D W, ' DUP , ] INLINE,
0x058D W, , ;
\ 0 [IF]
: ['] \ 94
\ Интерпретация: семантика неопределена.
\ Компиляция: ( "<spaces>name" -- )
\ Пропустить ведущие пробелы. Выделить name, ограниченное пробелом. Найти name.
\ Добавить семантику времени выполнения, данную ниже, к текущему определению.
\ Неопределенная ситуация возникает, если name не найдено.
\ Добавить семантику времени выполнения, данную ниже, к текущему определению,
\ Время выполнения: ( -- xt )
\ Положить выполнимый токен имени xt на стек. Выполнимый токен, возвращаемый
\ скомпилированной фразой "['] X" является тем же значением, что и возвращаемое
\ "' X" вне состояния компиляции.
?COMP ' [LIT],
; IMMEDIATE
\ [THEN]
: LITERAL \ 94 CORE
\ Интерпретация: семантика неопределена.
\ Компиляция: ( x -- )
\ Добавить семантику времени выполнения, данную ниже, к текущему определению.
\ Время выполнения: ( -- x )
\ Положить x на стек.
STATE @ IF LIT, THEN
; IMMEDIATE
: 2LITERAL \ 94 DOUBLE
\ Интерпретация: семантика неопределена.
\ Компиляция: ( x1 x2 -- )
\ Добавить семантику времени выполнения, данную ниже, к текущему определению.
\ Время выполнения: ( -- x1 x2 )
\ Положить пару ячеек x1 x2 на стек.
STATE @ IF DLIT, THEN
; IMMEDIATE
: SLITERAL \ 94 STRING
PSLITERAL ; IMMEDIATE
: PSLITERAL
\ Интерпретация: семантика не определена.
\ Компиляция: ( c-addr1 u -- )
\ Добавить семантику времени выполнения, данную ниже, к текущему определению.
\ Время выполнения: ( -- c-addr2 u )
\ Возвратить c-addr2 u, описывающие строку, состоящую из символов, заданных
\ c-addr1 u во время компиляции. Программа не может менять возвращенную
\ строку.
STATE @ IF SLIT, \ ELSE 2DUP + 0 SWAP C!
THEN
;
: S" \ 94+FILE
\ Интерпретация: ( "ccc<quote>" -- c-addr u )
\ Выделить ccc, ограниченные " (двойными кавычками). Записать полученную
\ строку c-addr u во временный буфер. Максимальная длина временного
\ буфера зависит от реализации, но не может быть меньше 80 символов.
\ Следующее использование S" может переписать временный буфер.
\ Обеспечивается как минимум один такой буфер.
\ Компиляция: ( "ccc<quote>" -- )
\ Выделить ccc, ограниченные " (двойными кавычками). Добавить семантику
\ времени выполнения, описанную ниже, к текущему определению.
\ Время выполнения: ( -- c-addr u )
\ Вернуть c-addr и u, которые описывают строку, состоящую из символов ccc.
[CHAR] " PARSE [COMPILE] SLITERAL
; IMMEDIATE
: C" \ 94 CORE EXT
\ Интерпретация: семантика не определена.
\ Компиляция: ( "ccc<quote>" -- )
\ Выделить ccc, ограниченные " (двойными кавычками) и добавить
\ семантику времени выполнения, данную ниже, к текущему определению.
\ Время выполнения: ( -- c-addr )
\ Возвратить c-addr, строку со счетчиком, состоящую из символов ccc.
\ Программа не должна менять возвращенную строку.
[CHAR] " WORD [COMPILE] CLITERAL
; IMMEDIATE
: CLITERAL ( addr -- )
STATE @ IF CLIT, THEN
; IMMEDIATE
: ." \ 94
\ Интерпретация: семантика неопределена.
\ Компиляция: ( "ccc<quote>" -- )
\ Выделить ccc, ограниченное " (двойными кавычками). Добавить семантику времени
\ выполнения, данную ниже, к текущему определению.
\ Время выполнения: ( -- )
\ Вывести ccc на экран.
?COMP
[COMPILE] S"
['] TYPE COMPILE,
; IMMEDIATE
: [CHAR] \ 94
\ Интерпретация: семантика неопределена.
\ Компиляция: ( "<spaces>name" -- )
\ Пропустить ведущие пробелы. Выделить name, ограниченное пробелами. Добавить
\ семантику времени выполнения, данную ниже, к текущему определению.
\ Время выполнения: ( -- char )
\ Положить char, значение первого символа name, на стек.
?COMP
PARSE-WORD DROP C@ [COMPILE] LITERAL
; IMMEDIATE
: ABORT" \ 94
\ Интерпретация: семантика не определена.
\ Компиляция: ( "ccc<quote>" -- )
\ Выделить ccc, ограниченные " (двойными кавычками). Добавить описанную
\ ниже семантику времени выполнения в текущее определение.
\ Выполнение: ( i*x x1 -- | i*x )
\ Убрать x1 со стека. Если любой бит x1 ненулевой, вывести на экран ccc и
\ выполнить зависящие от реализации действия, включающие ABORT.
\ : ABORT" \ 94 EXCEPTION EXT
\ Расширить семантику CORE ABORT" чтобы было:
\ Интерпретация: семантика не определена.
\ Компиляция: ( "ccc<quote>" -- )
\ Выделить ccc, ограниченные " (двойными кавычками). Добавить семантику
\ времени выполнения, данную ниже, к текущему определению.
\ Время выполнения: ( i*x x1 -- | i*x ) ( R: j*x -- | j*x )
\ Убрать x1 со стека. Если любой бит x1 ненулевой, выполнить функцию
\ -2 THROW, выводя ccc, если на стеке исключений нет кадра исключений.
?COMP
?COMP [COMPILE] C"
['] (ABORT") COMPILE,
; IMMEDIATE

133
programs/develop/SPForth/src/compiler/spf_immed_loop.f Normal file
View File

@ -0,0 +1,133 @@
( ‘«®¢  ­¥¬¥¤«¥­­®£® ¢ë¯®«­¥­¨ï, ¨á¯®«ì§ã¥¬ë¥ ¯à¨ ª®¬¯¨«ï樨
横«®¢ ¢ ⥫¥ ¢ë᮪®ã஢­¥¢®£® ®¯à¥¤¥«¥­¨ï.
Ž‘-­¥§ ¢¨á¨¬ë¥ ®¯à¥¤¥«¥­¨ï.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
<20>८¡à §®¢ ­¨¥ ¨§ 16-à §à來®£® ¢ 32-à §àï¤­ë© ª®¤ - 1995-96££
<20>¥¢¨§¨ï - ᥭâï¡àì 1999
)
HEX
: DO \ 94
\ ˆ­â¥à¯à¥â æ¨ï: ᥬ ­â¨ª  ­¥®¯à¥¤¥«¥­ .
\ Š®¬¯¨«ïæ¨ï: ( C: -- do-sys )
\ <20>®«®¦¨âì do-sys ­  á⥪ ã¯à ¢«¥­¨ï. „®¡ ¢¨âì ᥬ ­â¨ªã ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï,
\ ¤ ­­ãî ­¨¦¥, ª ⥪ã饬㠮¯à¥¤¥«¥­¨î. ‘¥¬ ­â¨ª  ­¥§ ¢¥à襭  ¤® à §à¥è¥­¨ï
\ ¯®âॡ¨â¥«¥¬ do-sys, â ª¨¬ ª ª LOOP.
\ ‚à¥¬ï ¢ë¯®«­¥­¨ï: ( n1|u1 n2|u2 -- ) ( R: -- loop-sys )
\ “áâ ­®¢¨âì ¯ à ¬¥âàë 横«  ­  ¨­¤¥ªá n2|u2 ¨ ¯à¥¤¥« n1|u1. <20>¥®¯à¥¤¥«¥­­ ï
\ á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ n1|u1 ¨ n2|u2 ­¥ ®¤­®£® ⨯ . ‚á¥, ç⮠㦥
\ ­ å®¤¨«®áì ­  á⥪¥ ¢®§¢à â®¢, áâ ­®¢¨âáï ­¥¤®áâã¯­ë¬ ¤® â¥å ¯®à, ¯®ª  ­¥
\ ¡ã¤ãâ ã¡à ­ë ¯ à ¬¥âàë 横« .
?COMP
['] C-DO INLINE,
SetOP 0x68 C, DP @ 4 ALLOT
SetOP 0x52 C, \ PUSH EDX
SetOP 0x53 C, \ PUSH EBX
4 ALIGN-NOP
DP @ DUP TO :-SET
; IMMEDIATE
: ?DO \ 94 CORE EXT
\ ˆ­â¥à¯à¥â æ¨ï: ᥬ ­â¨ª  ­¥®¯à¥¤¥«¥­ .
\ Š®¬¯¨«ïæ¨ï: ( C: -- do-sys )
\ <20>®«®¦¨âì do-sys ­  á⥪ ã¯à ¢«¥­¨ï. „®¡ ¢¨âì ᥬ ­â¨ªã ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï,
\ ¤ ­­ãî ­¨¦¥, ª ⥪ã饬㠮¯à¥¤¥«¥­¨î. ‘¥¬ ­â¨ª  ­¥§ ¢¥à襭  ¤® à §à¥è¥­¨ï
\ ¯®âॡ¨â¥«¥¬ do-sys, â ª¨¬ ª ª LOOP.
\ ‚à¥¬ï ¢ë¯®«­¥­¨ï: ( n1|u1 n2|u2 -- ) ( R: -- | loop-sys )
\ …᫨ n1|u1 à ¢­® n2|u2, ¯à®¤®«¦¨âì ¢ë¯®«­¥­¨¥ á ¬¥áâ , ¤ ­­®£® ¯®âॡ¨â¥«¥¬
\ do-sys. ˆ­ ç¥ ãáâ ­®¢¨âì ¯ à ¬¥âàë 横«  ­  ¨­¤¥ªá n2|u2 ¨ ¯à¥¤¥« n1|u1
\ ¨ ¯à®¤®«¦¨âì ¢ë¯®«­¥­¨¥ áࠧ㠧  ?DO. <20>¥®¯à¥¤¥«¥­­ ï
\ á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ n1|u1 ¨ n2|u2 ­¥ ®¤­®£® ⨯ . ‚á¥, ç⮠㦥
\ ­ å®¤¨«®áì ­  á⥪¥ ¢®§¢à â®¢, áâ ­®¢¨âáï ­¥¤®áâã¯­ë¬ ¤® â¥å ¯®à, ¯®ª  ­¥
\ ¡ã¤ãâ ã¡à ­ë ¯ à ¬¥âàë 横« .
?COMP
OP0 @ :-SET UMAX TO :-SET
['] NIP DUP INLINE, INLINE,
0xBB C, HERE 4 ALLOT
['] C-?DO INLINE,
DP @ DUP TO :-SET
; IMMEDIATE
: LOOP \ 94
\ ˆ­â¥à¯à¥â æ¨ï: ( C: do-sys -- )
\ „®¡ ¢¨âì ᥬ ­â¨ªã ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï, ¤ ­­ãî ­¨¦¥, ª ⥪ã饬㠮¯à¥¤¥«¥­¨î.
\ <20> §à¥è¨âì ¢á¥ ¯®ï¢«¥­¨ï LEAVE ¬¥¦¤ã ¯®§¨æ¨¥©, ¤ ­­®© do-sys ¨ á«¥¤ãî饩
\ ¯®§¨æ¨¥© ¯¥à¥¤ ç¨ ã¯à ¢«¥­¨ï ¤«ï ¢ë¯®«­¥­¨ï á«®¢ §  LOOP.
\ ‚à¥¬ï ¢ë¯®«­¥­¨ï: ( -- ) ( R: loop-sys1 -- | loop-sys2 )
\ <20>¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ ¯ à ¬¥âàë 横«  ­¥¤®áâ㯭ë.
\ <20>ਡ ¢¨âì ¥¤¨­¨æã ª ¨­¤¥ªáã 横« . …᫨ ¨­¤¥ªá 横«  áâ « à ¢­ë¬ ¯à¥¤¥«ã,
\ ã¡à âì ¯ à ¬¥âàë 横«  ¨ ¯à®¤®«¦¨âì ¢ë¯®«­¥­¨¥ áࠧ㠧  横«®¬. ˆ­ ç¥
\ ¯à®¤®«¦¨âì ¢ë¯®«­¥­¨¥ á ­ ç «  横« .
?COMP
24 04FF W, C, \ inc dword [esp]
HERE 2+ - DUP SHORT? SetOP SetJP
IF
71 C, C, \ jno short
ELSE
4 - 0F C, 81 C, , \ jno near
THEN SetOP
0C24648D , \ lea esp, 0c [esp]
DP @ SWAP !
; IMMEDIATE
: +LOOP \ 94
\ ˆ­â¥à¯à¥â æ¨ï: ( C: do-sys -- )
\ „®¡ ¢¨âì ᥬ ­â¨ªã ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï, ¤ ­­ãî ­¨¦¥, ª ⥪ã饬㠮¯à¥¤¥«¥­¨î.
\ <20> §à¥è¨âì ¢á¥ ¯®ï¢«¥­¨ï LEAVE ¬¥¦¤ã ¯®§¨æ¨¥©, ¤ ­­®© do-sys ¨ á«¥¤ãî饩
\ ¯®§¨æ¨¥© ¯¥à¥¤ ç¨ ã¯à ¢«¥­¨ï ¤«ï ¢ë¯®«­¥­¨ï á«®¢ §  LOOP.
\ ‚à¥¬ï ¢ë¯®«­¥­¨ï: ( n -- ) ( R: loop-sys1 -- | loop-sys2 )
\ <20>¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ ¯ à ¬¥âàë 横«  ­¥¤®áâ㯭ë.
\ <20>ਡ ¢¨âì n ª ¨­¤¥ªáã 横« . …᫨ ¨­¤¥ªá 横«  ­¥ ¯¥à¥á¥ª £à ­¨æã ¬¥¦¤ã
\ ¯à¥¤¥«®¬ 横«  ¬¨­ãá ¥¤¨­¨æ  ¨ ¯à¥¤¥«®¬ 横« , ¯à®¤®«¦¨âì ¢ë¯®«­¥­¨¥ á
\ ­ ç «  横« . ˆ­ ç¥ ã¡à âì ¯ à ¬¥âàë 横«  ¨ ¯à®¤®«¦¨âì ¢ë¯®«­¥­¨¥ áà §ã
\ §  横«®¬.
?COMP
['] ADD[ESP],EAX INLINE,
['] DROP INLINE,
HERE 2+ - DUP SHORT? SetOP SetJP
IF
71 C, C, \ jno short
ELSE
4 - 0F C, 81 C, , \ jno near
THEN SetOP
0C24648D , \ lea esp, 0c [esp]
DP @ SWAP !
; IMMEDIATE
: I \ 94
\ ˆ­â¥à¯à¥â æ¨ï: ᥬ ­â¨ª  ­¥®¯à¥¤¥«¥­ .
\ ‚믮«­¥­¨¥: ( -- n|u ) ( R: loop-sys -- loop-sys )
\ n|u - ª®¯¨ï ⥪ã饣® (¢­ãâ७­¥£®) ¨­¤¥ªá  横« . <20>¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï
\ ¢®§­¨ª ¥â, ¥á«¨ ¯ à¬¥âàë 横«  ­¥¤®áâ㯭ë.
?COMP ['] C-I INLINE,
; IMMEDIATE
: J \ 94
?COMP ['] C-J INLINE,
; IMMEDIATE
: LEAVE \ 94
\ ˆ­â¥à¯à¥â æ¨ï: ᥬ ­â¨ª  ­¥®¯à¥¤¥«¥­ .
\ ‚믮«­¥­¨¥: ( -- ) ( R: loop-sys -- )
\ “¡à âì ⥪ã騥 ¯ à ¬¥âàë 横« . <20>¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨
\ ®­¨ ­¥¤®áâ㯭ë. <EFBFBD>த®«¦¨âì ¢ë¯®«­¥­¨¥ áࠧ㠧  ᠬ묨 ¢­ãâ७­¨¬¨ DO ... LOOP
\ ¨«¨ DO ... +LOOP.
?COMP
SetOP 0824648D , \ lea esp, 08 [esp]
SetOP C3 C, \ ret
; IMMEDIATE
: UNLOOP \ 94
\ ˆ­â¥à¯à¥â æ¨ï: ᥬ ­â¨ª  ­¥®¯à¥¤¥«¥­ .
\ ‚믮«­¥­¨¥: ( -- ) ( R: loop-sys -- )
\ “¡à âì ¯ à ¬¥âàë 横«  ⥪ã饣® ã஢­ï. UNLOOP âॡã¥âáï ¤«ï ª ¦¤®£®
\ ã஢­ï ¢«®¦¥­¨ï 横«®¢ ¯¥à¥¤ ¢ë室®¬ ¨§ ®¯à¥¤¥«¥­¨ï ¯® EXIT.
\ <20>¥®¤­®§­ ç­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ ¯ à ¬¥âàë 横«  ­¥¤®áâ㯭ë.
?COMP
SetOP 0C24648D , \ lea esp, 0c [esp]
; IMMEDIATE
DECIMAL

120
programs/develop/SPForth/src/compiler/spf_immed_transl.f Normal file
View File

@ -0,0 +1,120 @@
( ‘«®¢  ­¥¬¥¤«¥­­®£® ¢ë¯®«­¥­¨ï, ¨á¯®«ì§ã¥¬ë¥ ¢ ०¨¬¥ ª®¬¯¨«ï樨.
Ž‘-­¥§ ¢¨á¨¬ë¥ ®¯à¥¤¥«¥­¨ï.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
<20>८¡à §®¢ ­¨¥ ¨§ 16-à §à來®£® ¢ 32-à §àï¤­ë© ª®¤ - 1995-96££
<20>¥¢¨§¨ï - ᥭâï¡àì 1999
Œ®¤¨ä¨æ¨à®¢ ­­® Œ ªá¨¬®¢ë¬ Œ.Ž.
email:mak@mail.rtc.neva.ru
http://informer.rtc.neva.ru/
â ¤ {812}105-92-03
â à {812}552-47-64
)
: TO \ 94 CORE EXT
\ ˆ­â¥à¯à¥â æ¨ï: ( x "<spaces>name" -- )
\ <20>யãáâ¨âì ¢¥¤ã騥 ¯à®¡¥«ë ¨ ¢ë¤¥«¨âì name, ®£à ­¨ç¥­­®¥ ¯à®¡¥«®¬.
\ ‡ ¯¨á âì x ¢ name. <20>¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ name ­¥
\ ®¯à¥¤¥«¥­® ç¥à¥§ VALUE.
\ Š®¬¯¨«ïæ¨ï: ( "<spaces>name" -- )
\ <20>யãáâ¨âì ¢¥¤ã騥 ¯à®¡¥«ë ¨ ¢ë¤¥«¨âì name, ®£à ­¨ç¥­­®¥ ¯à®¡¥«®¬.
\ „®¡ ¢¨âì ᥬ ­â¨ªã ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï, ¤ ­­ãî ­¨¦¥, ª ⥪ã饬㠮¯à¥¤¥«¥­¨î.
\ <20>¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ name ­¥ ®¯à¥¤¥«¥­® ç¥à¥§ VALUE.
\ ‚à¥¬ï ¢ë¯®«­¥­¨ï: ( x -- )
\ ‡ ¯¨á âì x ¢ name.
\ <20>ਬ¥ç ­¨¥: <20>¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ POSTPONE ¨«¨ [COMPILE]
\ ¯à¨¬¥­ïîâáï ª TO.
'
>BODY CELL+ STATE @
IF COMPILE, ELSE EXECUTE THEN
; IMMEDIATE
: COMPILE,_M COMPILE, ;
: POSTPONE \ 94
\ ˆ­â¥à¯à¥â æ¨ï: ᥬ ­â¨ª  ­¥ ®¯à¥¤¥«¥­ .
\ Š®¬¯¨«ïæ¨ï: ( "<spaces>name" -- )
\ <20>யãáâ¨âì ¢¥¤ã騥 à §¤¥«¨â¥«¨. ‚뤥«¨âì ¨¬ï, ®£à ­¨ç¥­­®¥ ¯à®¡¥« ¬¨.
\ <20> ©â¨ ¨¬ï. „®¡ ¢¨âì ᥬ ­â¨ªã ª®¬¯¨«ï樨 ¨¬¥­¨ ¢ ⥪ã饥 ®¯à¥¤¥«¥­¨¥.
?COMP
PARSE-WORD SFIND DUP
0= IF -321 THROW THEN
1 = IF COMPILE,
ELSE LIT, ['] COMPILE,_M COMPILE, THEN
; IMMEDIATE
: \ \ 94 CORE EXT
\ Š®¬¯¨«ïæ¨ï: ‚믮«­¨âì ᥬ ­â¨ªã ¢ë¯®«­¥­¨ï, ¤ ­­ãî ­¨¦¥.
\ ‚믮«­¥­¨¥: ( "ccc<eol>" -- )
\ ‚뤥«¨âì ¨ ®â¡à®á¨âì ®áâ â®ª à §¡¨à ¥¬®© ®¡« áâ¨.
\ \ - á«®¢® ­¥¬¥¤«¥­­®£® ¨á¯®«­¥­¨ï.
1 PARSE 2DROP
; IMMEDIATE
: .( \ 94 CORE EXT
\ Š®¬¯¨«ïæ¨ï: ‚믮«­¨âì ᥬ ­â¨ªã ¢ë¯®«­¥­¨ï, ¤ ­­ãî ­¨¦¥.
\ ‚믮«­¥­¨¥: ( "ccc<paren>" -- )
\ ‚뤥«¨âì ¨ ¢ë¢¥á⨠­  ¤¨á¯«¥© ccc, ®£à ­¨ç¥­­ë¥ ¯à ¢®© ᪮¡ª®© ")".
\ .( - á«®¢® ­¥¬¥¤«¥­­®£® ¨á¯®«­¥­¨ï.
[CHAR] ) PARSE TYPE
; IMMEDIATE
: ( ( "ccc<paren>" -- ) \ 94 FILE
\ <20> áè¨à¨âì ᥬ ­â¨ªã CORE (, ¢ª«î稢:
\ Š®£¤  à §¡¨à ¥âáï ⥪áâ®¢ë© ä ©«, ¥á«¨ ª®­¥æ à §¡¨à ¥¬®© ®¡« á⨠¤®á⨣­ãâ
\ à ­ìè¥, 祬 ­ ©¤¥­  ¯à ¢ ï ᪮¡ª , á­®¢  § ¯®«­¨âì ¢å®¤­®© ¡ãä¥à á«¥¤ãî饩
\ áâப®© ¨§ ä ©« , ãáâ ­®¢¨âì >IN ¢ ­®«ì ¨ ¯à®¤®«¦ âì à §¡®à, ¯®¢â®àïï
\ íâ®â ¯à®æ¥áá ¤® â¥å ¯®à, ¯®ª  ­¥ ¡ã¤¥â ­ ©¤¥­  ¯à ¢ ï ᪮¡ª  ¨«¨ ­¥
\ ¡ã¤¥â ¤®á⨣­ãâ ª®­¥æ ä ©« .
BEGIN
[CHAR] ) DUP PARSE + C@ = 0=
WHILE
REFILL 0= IF EXIT THEN
REPEAT
; IMMEDIATE
: [COMPILE] \ 94 CORE EXT
\ ˆ­â¥à¯à¥â æ¨ï: ᥬ ­â¨ª  ­¥®¯à¥¤¥«¥­ .
\ Š®¬¯¨«ïæ¨ï: ( "<spaces>name" -- )
\ <20>யãáâ¨âì ¢¥¤ã騥 ¯à®¡¥«ë. ‚뤥«¨âì name, ®£à ­¨ç¥­­®¥ ¯à®¡¥« ¬¨.
\ <20> ©â¨ name. …᫨ ¨¬ï ¨¬¥¥â ¨­ãî ᥬ ­â¨ªã ª®¬¯¨«ï樨, 祬 "¯®-㬮«ç ­¨î",
\ ¤®¡ ¢¨âì ¥¥ ¢ ⥪ã饥 ®¯à¥¤¥«¥­¨¥; ¨­ ç¥ ¤®¡ ¢¨âì ᥬ ­â¨ªã ¢ë¯®«­¥­¨ï name.
\ <20>¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ name ­¥ ­ ©¤¥­®.
?COMP
'
COMPILE,
; IMMEDIATE
: ; [;] ; IMMEDIATE
: [;] ( -- )
RET, [COMPILE] [ REVEAL
ClearJpBuff
0 TO LAST-NON
;
: EXIT
RET,
; IMMEDIATE
: \EOF ( -- )
\ ‡ ª ­ç¨¢ ¥â âà ­á«ïæ¨î ⥪ã饣® ¯®â®ª 
BEGIN REFILL 0= UNTIL
POSTPONE \
;
: FIELD ( offset size "new-name< >" -- offset+size )
: OVER
DUP IF DUP LIT, ['] + COMPILE,
THEN DROP
POSTPONE ;
+ ;
0 [IF]
: --
CREATE OVER , +
(DOES1) (DOES2) @ +
;
[ELSE]
: -- FIELD ;
[THEN]

80
programs/develop/SPForth/src/compiler/spf_literal Normal file
View File

@ -0,0 +1,80 @@
( <20>८¡à §®¢ ­¨¥ ç¨á«®¢ëå «¨â¥à «®¢ ¯à¨ ¨­â¥à¯à¥â æ¨¨.
Ž‘-­¥§ ¢¨á¨¬ë¥ ®¯à¥¤¥«¥­¨ï.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
<20>८¡à §®¢ ­¨¥ ¨§ 16-à §à來®£® ¢ 32-à §àï¤­ë© ª®¤ - 1995-96££
<20>¥¢¨§¨ï - ᥭâï¡àì 1999
)
: ?LITERAL1 ( T -> ... )
\ ¯à¥®¡à §®¢ âì áâப㠢 ç¨á«®
0 0 ROT COUNT
OVER C@ [CHAR] - = IF 1- SWAP 1+ SWAP TRUE ELSE FALSE THEN >R
>NUMBER ." N{" 2DUP TYPE ." }"
DUP 1 > IF -2001 THROW THEN \ ABORT" -?"
IF C@ [CHAR] . <> IF -2002 THROW THEN \ ABORT" -??"
R> IF DNEGATE THEN
[COMPILE] 2LITERAL
ELSE DROP D>S
R> IF NEGATE THEN
[COMPILE] LITERAL
THEN
;
: ?SLITERAL1 ( c-addr u -> ... )
\ ¯à¥®¡à §®¢ âì áâப㠢 ç¨á«®
0 0 2SWAP
OVER C@ [CHAR] - = IF 1- SWAP 1+ SWAP TRUE ELSE FALSE THEN >R
>NUMBER
DUP 1 > IF -2001 THROW THEN \ ABORT" -?"
IF C@ [CHAR] . <> IF -2002 THROW THEN \ ABORT" -??"
R> IF DNEGATE THEN
[COMPILE] 2LITERAL
ELSE DROP D>S
R> IF NEGATE THEN
[COMPILE] LITERAL
THEN
;
: HEX-LITERAL ( T -> ... )
BASE @ >R HEX
0 0 ROT COUNT 2- SWAP 2+ SWAP >NUMBER 2DROP D>S [COMPILE] LITERAL
R> BASE !
;
: HEX-SLITERAL ( T -> ... )
BASE @ >R HEX
0 0 2SWAP 2- SWAP 2+ SWAP >NUMBER 2DROP D>S [COMPILE] LITERAL
R> BASE !
;
: ?LITERAL2 ( c-addr -- ... )
( à áè¨à¥­­ë© ¢ à¨ ­â ?LITERAL1:
¥á«¨ áâப  - ­¥ ç¨á«®, â® ¯ëâ ¥¬áï âࠪ⮢ âì ¥ñ
ª ª ¨¬ï ä ©«  ¤«ï  ¢â®-INCLUDED)
DUP COUNT 2 MIN S" 0x" COMPARE 0=
IF HEX-LITERAL EXIT THEN
DUP >R ['] ?LITERAL1 CATCH
IF DROP R> COUNT
OVER C@ [CHAR] " = IF 2 - SWAP 1+ SWAP THEN ( ã¡à « ª ¢ë窨, ¥á«¨ ¥áâì)
2DUP + 0 SWAP C!
['] INCLUDED CATCH
DUP 2 = OVER 3 = OR ( ä ©« ­¥ ­ ©¤¥­ ¨«¨ ¯ãâì ­¥ ­ ©¤¥­ )
IF -2003 THROW \ ABORT" -???"
ELSE THROW THEN
ELSE RDROP
THEN
;
: ?SLITERAL2 ( c-addr u -- ... )
( à áè¨à¥­­ë© ¢ à¨ ­â ?SLITERAL1:
¥á«¨ áâப  - ­¥ ç¨á«®, â® ¯ëâ ¥¬áï âࠪ⮢ âì ¥ñ
ª ª ¨¬ï ä ©«  ¤«ï  ¢â®-INCLUDED)
2DUP 2 MIN S" 0x" COMPARE 0=
IF HEX-SLITERAL EXIT THEN
2DUP 2>R ['] ?SLITERAL1 CATCH
IF 2DROP 2R>
OVER C@ [CHAR] " = IF 2 - SWAP 1+ SWAP THEN ( ã¡à « ª ¢ë窨, ¥á«¨ ¥áâì)
2DUP + 0 SWAP C!
['] INCLUDED CATCH
DUP 2 = OVER 3 = OR ( ä ©« ­¥ ­ ©¤¥­ ¨«¨ ¯ãâì ­¥ ­ ©¤¥­ )
IF -2003 THROW \ ABORT" -???"
ELSE THROW THEN
ELSE 2R> 2DROP
THEN
;

64
programs/develop/SPForth/src/compiler/spf_literal.f Normal file
View File

@ -0,0 +1,64 @@
( <20>८¡à §®¢ ­¨¥ ç¨á«®¢ëå «¨â¥à «®¢ ¯à¨ ¨­â¥à¯à¥â æ¨¨.
Ž‘-­¥§ ¢¨á¨¬ë¥ ®¯à¥¤¥«¥­¨ï.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
<20>८¡à §®¢ ­¨¥ ¨§ 16-à §à來®£® ¢ 32-à §àï¤­ë© ª®¤ - 1995-96££
<20>¥¢¨§¨ï - ᥭâï¡àì 1999
)
: ?SLITERAL1 ( c-addr u -> ... )
\ ¯à¥®¡à §®¢ âì áâப㠢 ç¨á«®
0 0 2SWAP
OVER C@ [CHAR] - = IF 1- SWAP 1+ SWAP TRUE ELSE FALSE THEN >R
>NUMBER
DUP 1 > IF ." -?" -2001 THROW THEN \ ABORT" -?"
IF C@ [CHAR] . <> IF -2002 THROW THEN \ ABORT" -??"
R> IF DNEGATE THEN
[COMPILE] 2LITERAL
ELSE DROP D>S
R> IF NEGATE THEN
[COMPILE] LITERAL
THEN
;
: ?LITERAL1 ( T -> ... )
\ ¯à¥®¡à §®¢ âì áâப㠢 ç¨á«®
COUNT ?SLITERAL1
;
: HEX-SLITERAL ( addr u -> flag )
BASE @ >R HEX
0 0 2SWAP 2- SWAP 2+ SWAP >NUMBER
?DUP IF
1 = SWAP C@ [CHAR] L = AND 0= IF 2DROP FALSE R> BASE ! EXIT THEN
ELSE DROP THEN
D>S POSTPONE LITERAL TRUE
R> BASE !
;
: INCLUDED_S -2003 THROW
INCLUDED ;
: ?SLITERAL2 ( c-addr u -- ... )
( à áè¨à¥­­ë© ¢ à¨ ­â ?SLITERAL1:
¥á«¨ áâப  - ­¥ ç¨á«®, â® ¯ëâ ¥¬áï âࠪ⮢ âì ¥ñ
ª ª ¨¬ï ä ©«  ¤«ï  ¢â®-INCLUDED)
DUP 1 > IF OVER W@ 0x7830 ( 0x) =
IF 2DUP 2>R HEX-SLITERAL IF RDROP RDROP EXIT ELSE 2R> THEN THEN
THEN
2DUP 2>R ['] ?SLITERAL1 CATCH
IF 2DROP 2R>
OVER C@ [CHAR] " = OVER 2 > AND
IF 2 - SWAP 1+ SWAP THEN ( ã¡à « ª ¢ë窨, ¥á«¨ ¥áâì)
2DUP + 0 SWAP C!
['] INCLUDED_S CATCH
DUP 2 = OVER 3 = OR OVER 161 = OR ( ä ©« ­¥ ­ ©¤¥­ ¨«¨ ¯ãâì ­¥ ­ ©¤¥­,
¨«¨ ­¥à §à¥è¥­­®¥ ¨¬ï ä ©« )
IF -2003 THROW \ ABORT" -???"
ELSE THROW THEN
ELSE RDROP RDROP
THEN
;
: ?LITERAL2 ( c-addr -- ... )
( à áè¨à¥­­ë© ¢ à¨ ­â ?LITERAL1:
¥á«¨ áâப  - ­¥ ç¨á«®, â® ¯ëâ ¥¬áï âࠪ⮢ âì ¥ñ
ª ª ¨¬ï ä ©«  ¤«ï  ¢â®-INCLUDED)
COUNT ?SLITERAL2
;

37
programs/develop/SPForth/src/compiler/spf_modules.f Normal file
View File

@ -0,0 +1,37 @@
( Working with forth modules
Copyright [C] 2000 D.Yakimov day@forth.org.ru
)
: MODULE: ( "name" -- old-current )
\ start a forth module
\ åÓÌÉ ÔÁËÏÊ ÍÏÄÕÌØ ÕÖÅ ÓÕÝÅÓÔ×ÕÅÔ, ÐÒÏÄÏÌÖÉÔØ ËÏÍÐÉÌÑÃÉÀ × ÎÅÇÏ
>IN @ ['] ' CATCH
IF >IN ! VOCABULARY GET-CURRENT
ALSO LATEST NAME> EXECUTE DEFINITIONS
ELSE
NIP GET-CURRENT SWAP ALSO EXECUTE DEFINITIONS
THEN
;
: EXPORT ( old-current -- old-current )
\ export some module definitions
DUP SET-CURRENT
;
: ;MODULE ( old-current -- )
\ finish the module
SET-CURRENT PREVIOUS
;
: {{ ( "name" -- )
\ ëÌÁÄÅÔ × ORDER wordlist, Ë-ÙÊ ÄÁÓÔ "name"
\ ÉÌÉ vocabulary ÅÓÌÉ "name" - vocabulary
DEPTH >R
ALSO ' EXECUTE
DEPTH R> <> IF \ wid on the stack?
CONTEXT ! THEN
; IMMEDIATE
: }}
PREVIOUS
; IMMEDIATE

128
programs/develop/SPForth/src/compiler/spf_parser.f Normal file
View File

@ -0,0 +1,128 @@
( <20> àá¥à áâப¨ á ¨á室­ë¬ ⥪á⮬ ¯à®£à ¬¬ë ­  ”®àâ¥.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
‘¥­âï¡àì 1999: PARSE ¨ SKIP ¯à¥®¡à §®¢ ­ë ¨§ CODE
¢ ¢ë᮪®ã஢­¥¢ë¥ ®¯à¥¤¥«¥­¨ï. <20>¥à¥¬¥­­ë¥ ¯à¥®¡à §®¢ ­ë ¢ USER.
)
512 VALUE C/L \ ¬ ªá¨¬ «ì­ë© à §¬¥à áâப¨, ª®â®àãî ¬®¦­® ¢¢¥á⨠¢ TIB
: SOURCE ( -- c-addr u ) \ 94
\ c-addr -  ¤à¥á ¢å®¤­®£® ¡ãä¥à . u - ª®«¨ç¥á⢮ ᨬ¢®«®¢ ¢ ­¥¬.
TIB #TIB @
;
: SOURCE! ( c-addr u -- )
\ ãáâ ­®¢¨âì c-addr u ¢å®¤­ë¬ ¡ãä¥à®¬ (â®ç­¥¥, ®¡« áâìî à §¡®à  - PARSE-AREA)
#TIB ! TO TIB >IN 0! ;
: EndOfChunk ( -- flag )
>IN @ SOURCE NIP < 0= \ >IN ­¥ ¬¥­ìè¥, 祬 ¤«¨­  ç ­ª 
;
: CharAddr ( -- c-addr )
SOURCE DROP >IN @
\ CR ." CA=" DEPTH .SN
+
;
: PeekChar ( -- char )
CharAddr C@ \ ᨬ¢®« ¨§ ⥪ã饣® §­ ç¥­¨ï >IN
;
: IsDelimiter ( char -- flag )
BL 1+ <
;
: GetChar ( -- char flag )
EndOfChunk
IF 0 FALSE
ELSE PeekChar TRUE THEN
;
: OnDelimiter ( -- flag )
GetChar SWAP IsDelimiter AND
;
: SkipDelimiters ( -- ) \ ¯à®¯ãáâ¨âì ¯à®¡¥«ì­ë¥ ᨬ¢®«ë
BEGIN
OnDelimiter
WHILE
>IN 1+!
REPEAT >IN @ >IN_WORD ! ;
: OnNotDelimiter ( -- flag )
GetChar SWAP IsDelimiter 0= AND
;
: SkipWord ( -- ) \ ¯à®¯ãáâ¨âì ­¥¯à®¡¥«ì­ë¥ ᨬ¢®«ë
BEGIN
OnNotDelimiter
WHILE
>IN 1+!
REPEAT
;
: SkipUpTo ( char -- ) \ ¯à®¯ãáâ¨âì ¤® ᨬ¢®«  char
BEGIN
DUP GetChar \ ." SC=" DUP M.
>R <> R> AND
WHILE
>IN 1+!
REPEAT DROP
;
: ParseWord ( -- c-addr u )
CharAddr \ CR ." P=" DUP 9 TYPE
>IN @
\ CR ." XZ=" DEPTH .SN
SkipWord >IN @
\ CR ." X1=" DEPTH .SN
- NEGATE
\ CR ." X2=" DEPTH .SN
\ CR ." PZ=" 2DUP TYPE
;
CREATE UPPER_SCR 31 ALLOT
: UPC ( c -- c' )
DUP [CHAR] Z U>
IF 0xDF AND
THEN ;
: UPPER ( ADDR LEN -- )
0 ?DO COUNT UPC OVER 1- C! LOOP DROP ;
: UPPER_NW ( ADDR LEN -- ADDR' LEN )
UPPER_SCR PLACE
UPPER_SCR COUNT 2DUP UPPER ;
: PARSE-WORD ( "name" -- c-addr u )
\ http://www.complang.tuwien.ac.at/forth/ansforth/parse-word.html
\ íâ® á«®¢® ⥯¥àì ¡ã¤¥¬ ¨á¯®«ì§®¢ âì ¢ INTERPRET
\ - 㤮¡­¥¥: ­¥ ¨á¯®«ì§ã¥â WORD ¨, ᮮ⢥âá⢥­­®, ­¥ ¬ãá®à¨â ¢ HERE;
\ ¨ à §¤¥«¨â¥«ï¬¨ áç¨â ¥â ¢á¥ çâ® <=BL, ¢ ⮬ ç¨á«¥ TAB ¨ CRLF
SkipDelimiters ParseWord
>IN 1+! \ ¯à®¯ãá⨫¨ à §¤¥«¨â¥«ì §  á«®¢®¬
\ UPPER_V @ EXECUTE
;
: NextWord PARSE-WORD ;
: PARSE-NAME PARSE-WORD ;
: PARSE ( char "ccc<char>" -- c-addr u ) \ 94 CORE EXT
\ ‚뤥«¨âì ccc, ®£à ­¨ç¥­­®¥ ᨬ¢®«®¬ char.
\ c-addr -  ¤à¥á (¢­ãâਠ¢å®¤­®£® ¡ãä¥à ), ¨ u - ¤«¨­  ¢ë¤¥«¥­­®© áâப¨.
\ …᫨ à §¡¨à ¥¬ ï ®¡« áâì ¡ë«  ¯ãáâ , १ã«ìâ¨àãîé ï áâப  ¨¬¥¥â ­ã«¥¢ãî
\ ¤«¨­ã.
CharAddr >IN @
ROT SkipUpTo
>IN @ - NEGATE
>IN 1+!
;
: PSKIP ( char "ccc<char>" -- )
\ <20>யãáâ¨âì à §¤¥«¨â¥«¨ char.
BEGIN
DUP GetChar >R = R> AND
WHILE
>IN 1+!
REPEAT DROP
;

33
programs/develop/SPForth/src/compiler/spf_read_source.f Normal file
View File

@ -0,0 +1,33 @@
( —⥭¨¥ áâப¨ ¨á室­®£® ⥪áâ  ¨§ ¢å®¤­®£® ¯®â®ª : ª®­á®«¨ ¨«¨ ä ©« .
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
<20>¥¢¨§¨ï: ‘¥­âï¡àì 1999
)
VECT <PRE>
: CONSOLE-HANDLES \ $$$$
;
: QUERY ( --- )
\ Read a line from the terminal into the terminal input buffer.
TIB 80 ACCEPT #TIB ! 0 >IN ! ;
: FREFILL ( h -- flag )
TIB C/L ROT READ-LINE THROW \ TAKEN-TIB
SWAP #TIB ! 0 >IN ! CURSTR 1+!
0 SOURCE + C!
;
: REFILL ( --- f)
\ Refill the current input source when it is exhausted. f is
\ true if it was successfully refilled.
SOURCE-ID -1 = IF
0 \ Not refillable for EVALUATE
ELSE SOURCE-ID
IF SOURCE-ID FREFILL
ELSE QUERY -1 \ Always successful from terminal.
THEN
THEN
;

222
programs/develop/SPForth/src/compiler/spf_translate.f Normal file
View File

@ -0,0 +1,222 @@
( ’à ­á«ïæ¨ï ¨á室­ëå ⥪á⮢ ¯à®£à ¬¬.
Ž‘-­¥§ ¢¨á¨¬ë¥ ®¯à¥¤¥«¥­¨ï.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
<20>८¡à §®¢ ­¨¥ ¨§ 16-à §à來®£® ¢ 32-à §àï¤­ë© ª®¤ - 1995-96££
<20>¥¢¨§¨ï - ᥭâï¡àì 1999
)
VECT OK.
VECT <MAIN>
VECT ?LITERAL
VECT ?SLITERAL
USER-VALUE SOURCE-ID-XT \ ¥á«¨ ­¥ à ¢¥­ ­ã«î, ⮠ᮤ¥à¦¨â § ¯®«­ïî饥
: DEPTH ( -- +n ) \ 94
\ +n - ç¨á«® ®¤¨­ à­ëå ï祥ª, ­ å®¤ïé¨åáï ­  á⥪¥ ¤ ­­ëå ¯¥à¥¤
\ ⥬ ª ª â㤠 ¡ë«® ¯®¬¥é¥­® +n.
SP@ S0 @ - NEGATE 4 U/
;
: ?STACK ( -> ) \ ¢ë¤ âì ®è¨¡ªã "¨áç¥à¯ ­¨¥ á⥪ ", ¥á«¨ ®­ ¡®«¥¥ 祬 ¯ãáâ
SP@ S0 @ SWAP U< IF S0 @ SP! -4 THROW THEN
;
: ?COMP ( -> )
STATE @ 0= IF -312 THROW THEN ( ’®«ìª® ¤«ï ०¨¬  ª®¬¯¨«ï樨 )
;
: WORD ( char "<chars>ccc<char>" -- c-addr ) \ 94
\ <20>யãáâ¨âì ¢¥¤ã騥 à §¤¥«¨â¥«¨. ‚ë¡à âì ᨬ¢®«ë, ®£à ­¨ç¥­­ë¥
\ à §¤¥«¨â¥«¥¬ char.
\ ˆáª«îç¨â¥«ì­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ ¤«¨­  ¨§¢«¥ç¥­­®© áâப¨
\ ¡®«ìè¥ ¬ ªá¨¬ «ì­®© ¤«¨­ë áâப¨ á® áç¥â稪®¬.
\ c-addr -  ¤à¥á ¯¥à¥¬¥­­®© ®¡« áâ¨, ᮤ¥à¦ é¥© ¨§¢«¥ç¥­­®¥ á«®¢®
\ ¢ ¢¨¤¥ áâப¨ á® áç¥â稪®¬.
\ …᫨ à §¡¨à ¥¬ ï ®¡« áâì ¯ãáâ  ¨«¨ ᮤ¥à¦¨â ⮫쪮 à §¤¥«¨â¥«¨,
\ १ã«ìâ¨àãîé ï áâப  ¨¬¥¥â ­ã«¥¢ãî ¤«¨­ã.
\ ‚ ª®­¥æ áâப¨ ¯®¬¥é ¥âáï ¯à®¡¥«, ­¥ ¢ª«îç ¥¬ë© ¢ ¤«¨­ã áâப¨.
\ <20>ணࠬ¬  ¬®¦¥â ¨§¬¥­ïâì ᨬ¢®«ë ¢ áâப¥.
DUP PSKIP PARSE
DUP HERE C! HERE 1+ SWAP CMOVE
BL HERE COUNT + !
HERE
;
1 [IF]
: ' ( "<spaces>name" -- xt ) \ 94
\ <20>யãáâ¨âì ¢¥¤ã騥 ¯à®¡¥«ë. ‚뤥«¨âì name, ®£à ­¨ç¥­­®¥ ¯à®¡¥«®¬. <20> ©â¨ name
\ ¨ ¢¥à­ãâì xt, ¢ë¯®«­¨¬ë© ⮪¥­ ¤«ï name. <20>¥®¯à¥¤¥«¥­­ ï á¨âã æ¨ï ¢®§­¨ª ¥â,
\ ¥á«¨ name ­¥ ­ ©¤¥­®.
\ ‚® ¢à¥¬ï ¨­â¥à¯à¥â æ¨¨ ' name EXECUTE à ¢­®á¨«ì­® name.
PARSE-WORD SFIND 0=
IF -321 THROW THEN ( -? )
;
[THEN]
: CHAR ( "<spaces>name" -- char ) \ 94
\ <20>யãáâ¨âì ¢¥¤ã騥 à §¤¥«¨â¥«¨. ‚뤥«¨âì ¨¬ï, ®à£ ­¨ç¥­­®¥ ¯à®¡¥« ¬¨.
\ <20>®«®¦¨âì ª®¤ ¥£® ¯¥à¢®£® ᨬ¢®«  ­  á⥪.
PARSE-WORD DROP C@ ;
CREATE ILAST-WORD 0 , 0 ,
: INTERPRET_ ( -> ) \ ¨­â¥à¯à¥â¨à®¢ âì ¢å®¤­®© ¯®â®ª
SAVEERR? ON
BEGIN
PARSE-WORD DUP
WHILE 2DUP ILAST-WORD 2!
\ ." <" TYPE ." >"
SFIND ?DUP
IF
STATE @ =
IF COMPILE, ELSE EXECUTE THEN
ELSE
S" NOTFOUND" SFIND
IF EXECUTE
ELSE 2DROP ?SLITERAL THEN
\ ?SLITERAL
THEN
?STACK
REPEAT 2DROP
;
VARIABLE &INTERPRET
' INTERPRET_ &INTERPRET !
: INTERPRET &INTERPRET @ EXECUTE ;
\ : HALT ( ERRNUM -> ) \ ¢ë室 á ª®¤®¬ ®è¨¡ª¨
\ >R exit ;
: .SN ( n --)
\ <20> á¯¥ç â âì n ¢¥àå­¨å í«¥¬¥­â®¢ á⥪ 
>R BEGIN
R@
WHILE
SP@ R@ 1- CELLS + @ DUP 0<
IF DUP U>D <# #S #> TYPE
." (" ABS 0 <# #S [CHAR] - HOLD #> TYPE ." ) " ELSE . THEN
R> 1- >R
REPEAT RDROP
;
: OK1
STATE @ 0=
IF ." Ok" DEPTH 70 UMIN
0 ?DO [CHAR] . EMIT LOOP CR
THEN
;
: EVAL-WORD ( a u -- )
\ ¨­â¥à¯à¥â¨à®¢ âì ( â࠭᫨஢ âì) á«®¢® á ¨¬¥­¥¬ a u
SFIND ?DUP IF
STATE @ = IF
COMPILE, ELSE
EXECUTE THEN
ELSE
-2003 THROW THEN
;
: [ \ 94 CORE
\ ˆ­â¥à¯à¥â æ¨ï: ᥬ ­â¨ª  ­¥®¯à¥¤¥«¥­ .
\ Š®¬¯¨«ïæ¨ï: ‚믮«­¨âì ᥬ ­â¨ªã ¢ë¯®«­¥­¨ï, ¤ ­­ãî ­¨¦¥.
\ ‚믮«­¥­¨¥: ( -- )
\ “áâ ­®¢¨âì á®áâ®ï­¨¥ ¨­â¥à¯à¥â æ¨¨. [ á«®¢® ­¥¬¥¤«¥­­®£® ¢ë¯®«­¥­¨ï.
STATE 0!
; IMMEDIATE
: ] ( -- ) \ 94 CORE
\ “áâ ­®¢¨âì á®áâ®ï­¨¥ ª®¬¯¨«ï樨.
TRUE STATE !
;
: QUIT ( -- ) ( R: i*x ) \ CORE 94
\ ‘¡à®á¨âì á⥪ ¢®§¢à â®¢, § ¯¨á âì ­®«ì ¢ SOURCE-ID.
\ “áâ ­®¢¨âì áâ ­¤ àâ­ë© ¢å®¤­®© ¯®â®ª ¨ á®áâ®ï­¨¥ ¨­â¥à¯à¥â æ¨¨.
\ <20>¥ ¢ë¢®¤¨âì á®®¡é¥­¨©. <20>®¢â®àïâì á«¥¤ãî饥:
\ - <20>ਭïâì áâப㠨§ ¢å®¤­®£® ¯®â®ª  ¢® ¢å®¤­®© ¡ãä¥à, ®¡­ã«¨âì >IN
\ ¨ ¨­â¥¯à¥â¨à®¢ âì.
\ - ‚뢥á⨠§ ¢¨áï饥 ®â ॠ«¨§ æ¨¨ á¨á⥬­®¥ ¯à¨£« è¥­¨¥, ¥á«¨
\ á¨á⥬  ­ å®¤¨âáï ¢ á®áâ®ï­¨¨ ¨­â¥à¯à¥â æ¨¨, ¢á¥ ¯à®æ¥ááë § ¢¥à襭ë,
\ ¨ ­¥â ­¥®¤­®§­ ç­ëå á¨âã æ¨©.
\ R0 @ RP! ( ­¥ ¤¥« ¥¬ í⮣®, çâ®¡ë ¯®§¢®«¨âì "['] QUIT CATCH" )
CONSOLE-HANDLES
0 TO SOURCE-ID
[COMPILE] [
<MAIN>
;
: MAIN1 ( -- )
BEGIN REFILL
WHILE INTERPRET OK.
REPEAT _BYE
;
' MAIN1 TO <MAIN>
: SAVE-SOURCE ( -- i*x i )
SOURCE-ID-XT SOURCE-ID >IN @ SOURCE CURSTR @ 6
;
: RESTORE-SOURCE ( i*x i -- )
6 <> IF ABORT THEN
CURSTR ! SOURCE! >IN ! TO SOURCE-ID TO SOURCE-ID-XT
;
: EVALUATE-WITH ( ( i*x c-addr u xt -- j*x )
\ ‘ç¨â ï c-addr u ¢å®¤­ë¬ ¯®â®ª®¬, ¢ëç¨á«¨âì ¥ñ ¨­â¥à¯à¥â â®à®¬ xt.
SAVE-SOURCE N>R
>R SOURCE! -1 TO SOURCE-ID
R> ( ['] INTERPRET) CATCH
NR> RESTORE-SOURCE
THROW
;
: EVALUATE ( i*x c-addr u -- j*x ) \ 94
\ ‘®åà ­ï¥â ⥪ã騥 ᯥæ¨ä¨ª æ¨¨ ¢å®¤­®£® ¯®â®ª .
\ ‡ ¯¨á뢠¥â -1 ¢ SOURCE-ID. „¥« ¥â áâபã, § ¤ ­­ãî c-addr u,
\ ¢å®¤­ë¬ ¯®â®ª®¬ ¨ ¢å®¤­ë¬ ¡ãä¥à®¬, ãáâ ­ ¢«¨¢ ¥â >IN ¢ 0
\ ¨ ¨­â¥à¯à¥â¨àã¥â. Š®£¤  áâப  à §®¡à ­  ¤® ª®­æ  - ¢®ááâ ­ ¢«¨¢ ¥â
\ ᯥæ¨ä¨ª æ¨¨ ¯à¥¤ë¤ã饣® ¢å®¤­®£® ¯®â®ª .
\ „à㣨¥ ¨§¬¥­¥­¨ï á⥪  ®¯à¥¤¥«ïîâáï ¢ë¯®«­ï¥¬ë¬¨ ¯® EVALUATE á«®¢ ¬¨.
['] INTERPRET EVALUATE-WITH
;
: FQUIT
BEGIN REFILL
WHILE INTERPRET
REPEAT ;
: INCLUDE-FILE ( i*x fileid -- j*x ) \ 94 FILE
>IN @ >R
SOURCE-ID >R TO SOURCE-ID
RP@ #TIB @ ALIGNED - RP!
TIB RP@ #TIB @ CMOVE
SOURCE 2>R
\ TCR ." IF"
['] FQUIT CATCH SAVEERR
\ ['] NOOP CATCH SAVEERR
2R> SOURCE!
RP@ TIB #TIB @ CMOVE
RP@ #TIB @ ALIGNED + RP!
R> TO SOURCE-ID
R> >IN ! THROW ;
: INCLUDED_ ( c-addr u ---- )
\ Open the file with name c-addr u and interpret all lines contained in it.
R/O OPEN-FILE THROW \ ABORT" Can't open include file"
DUP >R
['] INCLUDE-FILE CATCH
R> CLOSE-FILE DROP THROW
;
: REQUIRED ( waddr wu laddr lu -- )
2SWAP SFIND
IF DROP 2DROP
ELSE 2DROP INCLUDED_ THEN
;
: REQUIRE ( "word" "libpath" -- )
PARSE-NAME PARSE-NAME 2DUP + 0 SWAP C!
REQUIRED
;
: AUTOEXEC S" /sys/INIT.F" INCLUDED_ ;

188
programs/develop/SPForth/src/compiler/spf_wordlist.f Normal file
View File

@ -0,0 +1,188 @@
( ‘®§¤ ­¨¥ á«®¢ àëå áâ â¥© ¨ á«®¢ à¥© WORDLIST.
Ž‘-­¥§ ¢¨á¨¬ë¥ ®¯à¥¤¥«¥­¨ï.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
<20>८¡à §®¢ ­¨¥ ¨§ 16-à §à來®£® ¢ 32-à §àï¤­ë© ª®¤ - 1995-96££
<20>¥¢¨§¨ï - ᥭâï¡àì 1999
Œ®¤¨ä¨æ¨à®¢ ­­® Œ ªá¨¬®¢ë¬ Œ.Ž.
email:mak@mail.rtc.neva.ru
http://informer.rtc.neva.ru/
â ¤ {812}105-92-03
â à {812}552-47-64
)
HEX
1 CONSTANT &IMMEDIATE \ ª®­áâ ­â  ¤«ï ¢ëá¥ç¥­¨ï ä« ¦ª  IMMEDIATE
2 CONSTANT &VOC
\ ‚®§¢à â¨âì wid - ¨¤¥­â¨ä¨ª â®à ᯨ᪠ á«®¢, ¢ª«îç î饣® ¢á¥ áâ ­¤ àâ­ë¥
\ á«®¢ , ®¡¥á¯¥ç¨¢ ¥¬ë¥ ॠ«¨§ æ¨¥©. <20>â®â ᯨ᮪ á«®¢ ¨§­ ç «ì­® ᯨ᮪
\ ª®¬¯¨«ï樨 ¨ ç áâì ­ ç «ì­®£® ¯®à浪  ¯®¨áª .
: >BODY ( xt -- a-addr ) \ 94
\ a-addr -  ¤à¥á ¯®«ï ¤ ­­ëå, ᮮ⢥âáâ¢ãî騩 xt.
\ ˆáª«îç¨â¥«ì­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ xt ­¥ ®â á«®¢ ,
\ ®¯à¥¤¥«¥­­®£® ç¥à¥§ CREATE.
( 1+ @ ¡ë«® ¢ ¢¥àᨨ 2.5 )
5 +
;
: SWORD, ( addr u wid -> ) \ ¤®¡ ¢«¥­¨¥ § £®«®¢ª  áâ âì¨ á ¨¬¥­¥¬,
\ § ¤ ­­ë¬ áâப®© addr u, ª ᯨáªã, § ¤ ­­®¬ã wid.
\ ”®à¬¨àã¥â ⮫쪮 ¯®«ï ¨¬¥­¨ ¨ á¢ï§¨ á
\ ®â¢¥¤¥­¨¥¬ ¯ ¬ï⨠¯® ALLOT.
HERE CELL+
DUP LAST !
SWAP DUP @ , !
S, 0 C,
;
: WORDLIST ( -- wid ) \ 94 SEARCH
\ ‘®§¤ ¥â ­®¢ë© ¯ãá⮩ ᯨ᮪ á«®¢, ¢®§¢à é ï ¥£® ¨¤¥­â¨ä¨ª â®à wid.
\ <20>®¢ë© ᯨ᮪ á«®¢ ¬®¦¥â ¡ëâì ¢®§¢à é¥­ ¨§ ¯à¥¤¢ à¨â¥«ì­® à á¯à¥¤¥«¥­­ëå
\ ᯨ᪮¢ á«®¢ ¨«¨ ¬®¦¥â ¤¨­ ¬¨ç¥áª¨ à á¯à¥¤¥«ïâìáï ¢ ¯à®áâà ­á⢥ ¤ ­­ëå.
\ ‘¨á⥬  ¤®«¦­  ¤®¯ã᪠âì ᮧ¤ ­¨¥ ª ª ¬¨­¨¬ã¬ 8 ­®¢ëå ᯨ᪮¢ á«®¢ ¢
\ ¤®¯®«­¥­¨¥ ª ¨¬¥î騬áï ¢ á¨á⥬¥.
HERE VOC-LIST @ , VOC-LIST !
HERE 0 , \ §¤¥áì ¡ã¤¥â 㪠§ â¥«ì ­  ¨¬ï ¯®á«¥¤­¥£® á«®¢  ᯨ᪠
0 , \ §¤¥áì ¡ã¤¥â 㪠§ â¥«ì ­  ¨¬ï ᯨ᪠ ¤«ï ¨¬¥­®¢ ­ëå
0 , \ wid á«®¢ àï-¯à¥¤ª 
0 , \ ª« áá á«®¢ àï = wid á«®¢ àï, ®¯à¥¤¥«ïî饣® ᢮©á⢠ ¤ ­­®£®
;
: CLASS! ( cls wid -- ) CELL+ CELL+ CELL+ ! ;
: CLASS@ ( wid -- cls ) CELL+ CELL+ CELL+ @ ;
: PAR! ( Pwid wid -- ) CELL+ CELL+ ! ;
: PAR@ ( wid -- Pwid ) CELL+ CELL+ @ ;
: ID. ( NFA[E] -> )
ZCOUNT TYPE
;
\ -9 -- flags
\ -8 -- cfa
\ -4 -- LFA
\ 0 -- NFA
Code NAME>L ;( NFA -> LFA )
LEA EAX, [EAX-4]
RET
EndCode
Code NAME>C ;( NFA -> 'CFA )
LEA EAX, [EAX-8]
RET
EndCode
Code NAME> ;( NFA -> CFA )
MOV EAX, [EAX-8]
RET
EndCode
Code NAME>F ;( NFA -> FFA )
LEA EAX, [EAX-9]
RET
EndCode
Code CDR ;( NFA1 -> NFA2 )
OR EAX, EAX
SIF 0<>
MOV EAX, [EAX-4]
STHEN
RET
EndCode
: ?IMMEDIATE ( NFA -> F )
NAME>F C@ &IMMEDIATE AND
;
: ?VOC ( NFA -> F )
NAME>F C@ &VOC AND
;
0 [IF]
: IMM ( -- ) \ 94
\ ‘¤¥« âì ¯®á«¥¤­¥¥ ®¯à¥¤¥«¥­¨¥ á«®¢®¬ ­¥¬¥¤«¥­­®£® ¨á¯®«­¥­¨ï.
\ ˆáª«îç¨â¥«ì­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ ¯®á«¥¤­¥¥ ®¯à¥¤¥«¥­¨¥
\ ­¥ ¨¬¥¥â ¨¬¥­¨.
LAST @ NAME>F DUP C@ &IMMEDIATE OR SWAP ." I=" 2DUP H. H.
;
: IMMEDIATE ( -- ) \ 94
\ ‘¤¥« âì ¯®á«¥¤­¥¥ ®¯à¥¤¥«¥­¨¥ á«®¢®¬ ­¥¬¥¤«¥­­®£® ¨á¯®«­¥­¨ï.
\ ˆáª«îç¨â¥«ì­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ ¯®á«¥¤­¥¥ ®¯à¥¤¥«¥­¨¥
\ ­¥ ¨¬¥¥â ¨¬¥­¨.
LAST @ NAME>F DUP C@ &IMMEDIATE OR SWAP C!
;
[THEN]
: VOC ( -- )
\ <20>®¬¥â¨âì ¯®á«¥¤­¥¥ ®¯à¥¤¥«¥­­®¥ á«®¢® ¯à¨§­ ª®¬ "á«®¢ àì".
LAST @ NAME>F DUP C@ &VOC OR SWAP C!
;
\ ==============================================
\ ®â« ¤ª  - ¯®¨áª á«®¢  ¯®  ¤à¥áã ¢ ¥£® ⥫¥
\ ==============================================
\ ®â« ¤ª  - ¯®¨áª á«®¢  ¯®  ¤à¥áã ¢ ¥£® ⥫¥
: N_UMAX ( nfa nfa1 -- nfa|nfa1 )
OVER DUP IF NAME> THEN
OVER DUP IF NAME> THEN U< IF NIP EXIT THEN DROP ;
: WL_NEAR_NFA ( addr wid - addr nfa | addr 0 )
@
BEGIN 2DUP DUP IF NAME> THEN U<
WHILE CDR
REPEAT
;
0
[IF]
: NEAR_NFA ( addr - nfa addr | 0 addr )
0 SWAP
VOC-LIST
BEGIN @ DUP
WHILE DUP >R CELL+ WL_NEAR_NFA SWAP >R N_UMAX R> R>
REPEAT DROP
;
[ELSE]
: WL_NEAR_NFA_N ( addr nfa - addr nfa | addr 0 )
BEGIN 2DUP DUP IF NAME> THEN U<
WHILE CDR
REPEAT
;
: WL_NEAR_NFA_M ( addr wid - nfa2 addr | 0 addr )
0 -ROT
CELL+ @
BEGIN DUP
WHILE WL_NEAR_NFA_N \ nfa addr nfa1
SWAP >R
DUP >R N_UMAX
R> DUP IF CDR THEN
R> SWAP
REPEAT DROP
;
: NEAR_NFA ( addr - nfa addr | 0 addr )
0 SWAP
VOC-LIST
BEGIN @ DUP
WHILE DUP >R WL_NEAR_NFA_M
>R N_UMAX R> R>
REPEAT DROP
;
[THEN]
: WordByAddr ( addr -- c-addr u )
\ ­ ©â¨ á«®¢®, ⥫㠪®â®à®£® ¯à¨­ ¤«¥¦¨â ¤ ­­ë©  ¤à¥á
DUP DP @ U> IF DROP S" <not in the image>" EXIT THEN
NEAR_NFA DROP DUP 0= IF DROP S" <not found>" EXIT THEN
COUNT
;
DECIMAL

45
programs/develop/SPForth/src/compiler/spf_words.f Normal file
View File

@ -0,0 +1,45 @@
( <20>¥ç âì ᯨ᪠ á«®¢ á«®¢ àï - WORDS.
Ž‘-­¥§ ¢¨á¨¬ë¥ ®¯à¥¤¥«¥­¨ï.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
<20>८¡à §®¢ ­¨¥ ¨§ 16-à §à來®£® ¢ 32-à §àï¤­ë© ª®¤ - 1995-96££
<20>¥¢¨§¨ï - ᥭâï¡àì 1999
)
VARIABLE NNN
: ?CR-BREAK ( NFA -- NFA TRUE | FALSE )
DUP
IF DUP ZCOUNT NIP AT-XY? DROP + SCR_WIDTH-S >
IF CR
NNN @
IF -1 NNN +! TRUE
ELSE ." more?" CR 16 NNN !
KEY [CHAR] Q <> AND ?DUP 0<>
THEN
ELSE TRUE
THEN
THEN
;
: NLIST ( A -> )
@
CR W-CNT 0! 16 NNN !
BEGIN ?CR-BREAK
WHILE
W-CNT 1+!
DUP ID. \ 9 EMIT
SPACE AT-XY? >R 8 / 1+ 8 * R> AT-XY
CDR
REPEAT KEY? IF KEY DROP THEN
CR CR ." Words: " W-CNT @ U. CR
;
: WORDS ( -- ) \ 94 TOOLS
\ ‘¯¨á®ª ¨¬¥­ ®¯à¥¤¥«¥­¨© ¢ ¯¥à¢®¬ ᯨ᪥ á«®¢ ¯®à浪  ¯®¨áª . ”®à¬ â § ¢¨á¨â
\ ®â ॠ«¨§ æ¨¨.
\ WORDS ¬®¦¥â ¡ëâì ॠ«¨§®¢ ­ á ¨á¯®«ì§®¢ ­¨¥¬ á«®¢ ä®à¬ â­®£® ¯à¥®¡à §®¢ ­¨ï
\ ç¨á¥«. ‘®®â¢¥âá⢥­­®, ®­ ¬®¦¥â ¨á¯®àâ¨âì ¯¥à¥¬¥é ¥¬ãî ®¡« áâì,
\ ¨¤¥­â¨ä¨æ¨à㥬ãî #>.
CONTEXT @ NLIST
;

46
programs/develop/SPForth/src/global.f Normal file
View File

@ -0,0 +1,46 @@
: TYPE TYPE ;
: (ABORT") (ABORT") ;
\ : COMPILE, COMPILE, ;
: CUR_POS ABORT ;
: B_CR ( -- ) \ 94
\ <20>¥à¥¢®¤ áâப¨.
10 EMIT
13 EMIT
;
: GETPR ABORT ;
: SPP_M ABORT ;
: TIBB_M ABORT ;
: NTIB_M ABORT ;
: NTIB ABORT ;
: draw_window ABORT ;
: CC_LINES ABORT ;
: ?KEY ABORT ;
: EMIT_N ABORT ;
: DR_CUR ABORT ;
: CL_CUR ABORT ;
: KEY_M ABORT ;
: _BYE ABORT ;
: ROWH ABORT ;
: ROWW ABORT ;
: draw_window ABORT ;
: MEMS ABORT ;
\ FORWORD
: READ ABORT ;
: CLIT, ABORT ;
: _PREVIOUS PREVIOUS ;
: _SHEADER SHEADER ;
: _: : ;
: [;] POSTPONE ; ;
: S, ABORT ;
: SWORD, ABORT ;
: PARSE-NAME PARSE-WORD ;
: PSLITERAL POSTPONE SLITERAL ;

231
programs/develop/SPForth/src/gspf.f Normal file
View File

@ -0,0 +1,231 @@
CR .( SFF.F)
\ ' ANSI>OEM TO ANSI><OEM
\ ' OEM>ANSI TO ANSI><OEM
REQUIRE DUPENDCASE ~mak/case.f
CR .( DC=) ' DUPENDCASE .
VARIABLE START-LAB
VARIABLE FINISH-LAB
VARIABLE START-LIST
VARIABLE FINISH-LIST
VARIABLE START-LIST2
VARIABLE FINISH-LIST2
VARIABLE FINISH-LIST3
VARIABLE START-VAR
VARIABLE FINISH-VAR
VARIABLE START-ARRAY
VARIABLE FINISH-ARRAY
0 VALUE IMAGE-END
S" lib/ext/disasm2.f" INCLUDED
1000 CELLS ALLOCATE DROP DUP START-VAR ! FINISH-VAR !
1000 CELLS ALLOCATE DROP DUP START-LIST ! FINISH-LIST !
1000 CELLS ALLOCATE DROP DUP START-LIST2 ! FINISH-LIST2 !
1000 CELLS ALLOCATE DROP DUP START-LAB ! FINISH-LAB !
100 CELLS ALLOCATE DROP DUP START-ARRAY ! FINISH-ARRAY !
\ REQUIRE [IF] ~mak/CompIF.f
REQUIRE [IFNDEF] ~nn/lib/ifdef.f
\ REQUIRE (* ~af/lib/comments.f
: CC HERE DROP ; IMMEDIATE
: KDD KEY DROP ;
VARIABLE HSSSS
VARIABLE ZSSSS
0 VALUE ALITERAL-CODE
\ !!! REQUIRE Z" ~mak/~af/lib/c/zstr.f
[IFNDEF] PARSE-WORD : PARSE-WORD NextWord ;
[THEN]
[IFNDEF] PSKIP : PSKIP SKIP ;
[THEN]
\ : KEY MKEY ;: KEY? MKEY? ;
\ REQUIRE SEE lib/ext/disasm.f
\ REQUIRE SEE lib/ext/disasm1.f
: B, C, ; : B@ C@ ; : B! C! ; : /CHAR 1 ;
: PARSE-NAME NextWord ;
\ : UMIN 2DUP U< IF DROP EXIT THEN NIP ;
REQUIRE { ~ac\lib\locals.f
\ REQUIRE { lib\ext\locals.f
[IFDEF] z z : z d
[THEN]
[IFDEF] d z ; POSTPONE d d IMMEDIATE
[THEN]
WARNING 0! \ ÷òîáû íå áûëî ñîîáùåíèé isn't unique
S" lib/include/tools.f" INCLUDED
C" CELL-" FIND NIP 0=
[IF] : CELL- 1 CELLS - ;
[THEN]
C" U>" FIND NIP 0=
[IF] : U> SWAP U< ;
[THEN]
C" D-" FIND NIP 0=
[IF]
: D- ( D1 D2 -- FLAG )
DNEGATE D+ ;
[THEN]
C" D=" FIND NIP 0=
[IF]
: D= ( D1 D2 -- FLAG )
D- D0= ;
[THEN]
C" \S" FIND NIP 0=
[IF]
: \S \ comment to end of file
SOURCE-ID FILE-SIZE DROP
SOURCE-ID REPOSITION-FILE DROP
[COMPILE] \ ; IMMEDIATE
[THEN]
S" ~mak/utils_.f" INCLUDED
\ S" lib/ext/spf-asm.f" INCLUDED
\ ALSO ASSEMBLER ALSO ASM-HIDDEN
\ ' NOOP IS CODE-ALIGN
\ PREVIOUS PREVIOUS
S" ~mak/asm/ASM.FRT" INCLUDED
\ S" lib/include/tools.f" INCLUDED
C" LAST-HERE" FIND NIP 0= VALUE INLINEVAR
' DUP VALUE 'DUP
0 VALUE RESERVE
USER-HERE CONSTANT USER-HERE-SET
USER-HERE-SET TO RESERVE
MODULE: GSPF0
S" src/global.f" INCLUDED
;MODULE
S" src/global.f" INCLUDED
S" src/tc_spfopt.f" INCLUDED
' _CONSTANT-CODE TO CONSTANT-CODE
' _CREATE-CODE TO CREATE-CODE
' _CLITERAL-CODE TO CLITERAL-CODE
' _SLITERAL-CODE TO SLITERAL-CODE
\ : TOMM_SIZE TO MM_SIZE ;
DIS-OPT
\ VOCABULARY GSPF0
: ?HS
HERE CELL- @
HERE HSSSS @ + CELL- @ <>
IF CR
HERE CELL- @ H.
HERE HSSSS @ + CELL- @ H.
-1 ABORT" HSSSS "
THEN
;
: TT 0 IF THEN ;
\ : CODE ?HS CODE ;
\ ALSO GGSPF0
ALSO GSPF0 DEFINITIONS
: >R POSTPONE >R ; IMMEDIATE
: R> POSTPONE R> ; IMMEDIATE
CR
0x10 TOMM_SIZE
HERE DUP H.
HERE 0xF OR 1+ DP !
HERE DUP H. MM_SIZE H.
HERE ZSSSS ! 0 HSSSS !
0x11223344 , 0x55667788 , ?HS
S" src/gspf0.f" INCLUDED
CR MM_SIZE H.
PREVIOUS ( PREVIOUS ) DEFINITIONS
\ ALSO GSPF0
MM_SIZE H.
[IFDEF] S"_L" S" _LL" S"_L" PLACE [THEN]
\ S" src/global.f" INCLUDED
CR
0x10 TOMM_SIZE
HERE DUP H.
HERE 0xF OR 1+ DP !
HERE DUP H. MM_SIZE H.
ZSSSS @ HERE - HSSSS !
0x11223344 , 0x55667788 , ?HS
S" src/gspf0.f" INCLUDED
\ Òóò ìîæíî îïðåäåëèòü êàêèå òî ñâîè ñëîâà äëÿ ïðîáû.
\ ×òîáû íå áûëî îøèáîê, êàêîé òî ôàéë ñêðèïòà äîëæåí áûòü ïîäãðóæåí. Ïðèìåð íèæå.
\ HERE TO IMAGE-END
\ VARIABLE lm
\ VECT m
\ 0 CONSTANT m
\ : doTest 2000000 0 DO m @ 2 + I @ 4 + * I ! LOOP ;
\ ðàññêîìåíòèðîâàâ íèæå ýòó ñòðîêó è îòìå÷åííûå íèæå * ìîæíî ïîëó÷èòü âåñü êîä ó÷àñòâóþùèé
\ ïðè âûïîëíåíèè äàííîé íèæå ñòðîêè
\ : doTest 10 0 DO I . LOOP ;
\ Òóò çàãðóæàåì èíòåðåñóþøèé íàñ ñêðèïò.
\ ×èñëî çàãðóæàåìûõ ñêðèïòîâ íå îãðàíè÷åííî.
\ H-STDOUT VALUE File
\ HERE TO IMAGE-END
\ : File:
\ NextWord DUP >R
\ HEAP-COPY DUP R> R/W CREATE-FILE-SHARED THROW TO File FREE THROW
\ ;
\ File: Test.log \ Ýòî èìÿ ôàéëà êóäà âûâîäèì.
\ H-STDOUT >R File TO H-STDOUT DROP \ âêëþ÷åíèå âûâîäà
\ ïðîãðàììû ïîëüçîâàòåëÿ
\ S" example.f" INCLUDED
\ Ñëîâà êîòîðûå ìû õîòèì äèçàñåìáëèðîâàòü.
\ Åñëè â âàøåé ïðîãðàììå íóæíî èïîëüçîâàòü íåñêîëüêî ñëîâ-ïðîöåäóð, òî
\ ëó÷ùå äèçàñåìáëèðîâàòü âìåñòå. Òîãäà îíè áóäóò ññûëàòüñÿ íà îáùèé ðåâóðñ îïðåäåëåíèé.
\ Åñëè íóæíà âñÿ ïðîãðàììà, òî äèçàññåìáëèðóåì ãëàâíîå îïðåäåëåíèå.
\ * íèæå ýòó
\ ' doTest DISASM-LIST \ Ñëîââî " ' " Ïîëó÷àåò àäðåñ ñëåäóþøåãî çà íèì ñëîâà, ñëîâî DISASM-LIST ïîíÿòíî èç íàçâàíèÿ.
\ ' WildCMP-U1 DISASM-LIST
\ êîíåö
\ * à òàêæå ýòó
\ TYPE-ALL
\ File FLUSH-FILE THROW R> TO H-STDOUT \ âûêëþ÷åíèå âûâîäà
\ CR
\ : B I I I */ ;
\ ' B SEE2
\ SEE B
\ ' doTest DISASM-LIST
\ ' doTest SEE2
\ ' m SEE2
\ ' B DISASM-LIST \ Ñëîââî " ' " Ïîëó÷àåò àäðåñ ñëåäóþøåãî çà íèì ñëîâà, ñëîâî DISASM-LIST ïîíÿòíî èç íàçâàíèÿ.
\ êîíåö
\ CR TYPE-ALL
\ START-LIST @ FREE DROP
\ START-LIST2 @ FREE DROP
\ START-LAB @ FREE DROP
\ START-VAR @ FREE DROP
\ START-ARRAY @ FREE DROP

112
programs/develop/SPForth/src/gspf0.f Normal file
View File

@ -0,0 +1,112 @@
\ TSET-OPT
0x10 TOMM_SIZE
HERE TO TSAVE_LIMIT
USER-HERE-SET TO RESERVE
USER-HERE-SET USER-OFFS !
\ DECIMAL
\ TRUE WARNING ! \ çâ®¡ë ¡ë«®
\ ==============================================================
\ <20> ç «® ®¡à §  ”®àâ-á¨á⥬ë
\ S" src/USER.F" INCLUDED
\ S" src/spf_defkern.f" INCLUDED
CR .( S" src/spf_forthproc.f" INCLUDED)
S" src/spf_forthproc.f" INCLUDED
\ S" src/spf_floatkern.f" INCLUDED
S" src/spf_forthproc_hl.f" INCLUDED
S" src/kol/spf_kol_const.f" INCLUDED
\ ==============================================================
S" src/kol\spf_kol_sys.f" INCLUDED
\ ’à ­á«ïæ¨ï ¨á室­ëå ⥪á⮢.
\ Ž¡à ¡®âª  ®è¨¡®ª.
\ Ž¯à¥¤¥«ïî騥 á«®¢ .
\ —¨á«®¢ë¥ «¨â¥à «ë.
\ “¯à ¢«¥­¨¥ ª®¬¯¨«ï樥©.
\ Š®¬¯¨«ïæ¨ï ã¯à ¢«ïîé¨å áâàãªâãà.
S" src/compiler/spf_immed_lit.f" INCLUDED
S" src/compiler/spf_defwords.f" INCLUDED
S" src/compiler/spf_immed_loop.f" INCLUDED
S" src/compiler/spf_error.f" INCLUDED
TDIS-OPT
S" src/compiler/spf_translate.f" INCLUDED
S" src/compiler/spf_immed_transl.f" INCLUDED
S" src/compiler/spf_literal.f" INCLUDED
S" src/compiler/spf_immed_control.f" INCLUDED
\ ==============================================================
\ Š®¬¯¨«ïæ¨ï ç¨á¥« ¨ áâப ¢ á«®¢ àì.
\ ‘®§¤ ­¨¥ á«®¢ à­ëå áâ â¥©.
\ <20>®¨áª á«®¢ ¢ á«®¢ àïå.
\ <20>¥ç âì á«®¢ à¥©.
\ S" src/temps4_.f" INCLUDED
\ EOF
S" src/compiler/spf_wordlist.f" INCLUDED
S" src/compiler/spf_find.f" INCLUDED
S" src/compiler/spf_words.f" INCLUDED
S" src/compiler/spf_compile0.f" INCLUDED
S" ~mak/~af/lib/c/zstr.f" INCLUDED
' ALITERAL TO ALITERAL-CODE
\ ‘âàãªâãà¨à®¢ ­­ ï ®¡à ¡®âª  ¨áª«î祭¨© (á¬.â ª¦¥ init)
S" src/spf_except.f" INCLUDED
\ ==============================================================
\ <20>¥ç âì ç¨á¥«
S" src/spf_print.f" INCLUDED
S" src/kol\spf_kol_module.f" INCLUDED
\ ==============================================================
\ ” ©«®¢ë© ¨ ª®­á®«ì­ë© ¢¢®¤-¢ë¢®¤ (kol-§ ¢¨á¨¬ë¥)
S" src/kol/spf_kol_con_io.f" INCLUDED
S" src/spf_con_io.f" INCLUDED
S" src/kol/spf_kol_io.f" INCLUDED
\ ==============================================================
\ “¯à ¢«¥­¨¥ ¯ ¬ïâìî
S" src/kol/spf_kol_memory.f" INCLUDED
\ ==============================================================
\ Œ ªà®¯®¤áâ ­®¢é¨ª-®¯â¨¬¨§ â®à
TRUE TO INLINEVAR
CR .( S" src/macroopt.f" INCLUDED)
MM_SIZE DUP H.
0x10 TOMM_SIZE
S" src/macroopt.f" INCLUDED
DUP H. TOMM_SIZE
S" src/compiler/spf_compile.f" INCLUDED
\ ==============================================================
\ <20> àá¥à ¨á室­®£® ⥪áâ  ä®àâ-¯à®£à ¬¬
S" src/compiler/spf_parser.f" INCLUDED
S" src/compiler/spf_read_source.f" INCLUDED
\ ==============================================================
\ ˆ­¨æ¨ «¨§ æ¨ï ¯¥à¥¬¥­­ëå, startup
CR .( S" src/spf_init.f" INCLUDED)
S" src/spf_init.f" INCLUDED
\ ==============================================================
S" src/compiler/spf_modules.f" INCLUDED
S" src/MEFORTH.F" INCLUDED
S" src/spf_last.f" INCLUDED
\ S" src/tst.f" INCLUDED \EOF
\ EOF
CR .( =============================================================)
CR .( Done.
CR .( =============================================================)
MM_SIZE H.

5061
programs/develop/SPForth/src/macroopt.f Normal file
View File

File diff suppressed because it is too large Load Diff

41
programs/develop/SPForth/src/spf_con_io.f Normal file
View File

@ -0,0 +1,41 @@
( Š®­á®«ì­ë© ¢¢®¤-¢ë¢®¤.
Ž‘-­¥§ ¢¨á¨¬ë¥ á«®¢  [®â­®á¨â¥«ì­®...].
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
<20>८¡à §®¢ ­¨¥ ¨§ 16-à §à來®£® ¢ 32-à §àï¤­ë© ª®¤ - 1995-96££
<20>¥¢¨§¨ï - ᥭâï¡àì 1999
)
32 VALUE BL ( -- char ) \ 94
\ char - §­ ç¥­¨¥ ᨬ¢®«  "¯à®¡¥«".
: SPACE ( -- ) \ 94
\ ‚뢥á⨠­  íªà ­ ®¤¨­ ¯à®¡¥«.
BL EMIT
;
: SPACES ( n -- ) \ 94
\ …᫨ n>0 - ¢ë¢¥á⨠­  ¤¨á¯«¥© n ¯à®¡¥«®¢.
BEGIN
DUP
WHILE
BL EMIT 1-
REPEAT DROP
;
VARIABLE PENDING-CHAR \ ª« ¢¨ âãà  ®¤­  -> ¯¥à¥¬¥­­ ï £«®¡ «ì­ ï, ­¥ USER
VECT DO-KEY?
' NOOP TO DO-KEY?
: KEY?
EVENT-CASE DO-KEY?
&KEY @ 0<> ;
\ : KEY?
\ 0 ;
VECT KEY
' _KEY TO KEY

114
programs/develop/SPForth/src/spf_defkern.f Normal file
View File

@ -0,0 +1,114 @@
( <20>à®æ¥¤ãàë ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï ¤«ï CONSTANT, VARIABLE, etc.
Ž‘-­¥§ ¢¨á¨¬ë¥ á«®¢ .
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
<20>८¡à §®¢ ­¨¥ ¨§ 16-à §à來®£® ¢ 32-à §àï¤­ë© ª®¤ - 1995-96££
<20>¥¢¨§¨ï - ᥭâï¡àì 1999
Œ®¤¨ä¨æ¨à®¢ ­­® Œ ªá¨¬®¢ë¬ Œ.Ž.
email:mak@mail.rtc.neva.ru
http://informer.rtc.neva.ru/
â ¤ {812}105-92-03
â à {812}552-47-64
)
Code _CREATE-CODE
SUB EBP, 4
MOV [EBP] , EAX
POP EAX
RET
EndCode
Code _CONSTANT-CODE
SUB EBP , 4
MOV [EBP] , EAX
POP EAX
MOV EAX, [EAX]
RET
EndCode
Code _USER-CODE
SUB EBP, 4
MOV [EBP], EAX
POP EAX
MOV EAX, [EAX]
ADD EAX, EDI
RET
EndCode
Code USER+ ;( offs -- addr )
ADD EAX, EDI
RET
EndCode
Code _USER-VALUE-CODE
SUB EBP , 4
MOV [EBP] , EAX
POP EAX
MOV EAX, [EAX]
ADD EAX, EDI
MOV EAX, [EAX]
RET
EndCode
Code _USER-VECT-CODE
POP EBX
MOV EBX, [EBX]
LEA EBX, [EDI+EBX]
MOV EBX, [EBX]
JMP EBX
RET
EndCode
Code _VECT-CODE
POP EBX
JMP [EBX]
EndCode
Code _TOVALUE-CODE
POP EBX
SUB EBX, 9
MOV [EBX] , EAX
MOV EAX, [EBP]
ADD EBP, 4
RET
EndCode
Code _TOUSER-VALUE-CODE
POP EBX
SUB EBX, 9
MOV EBX, [EBX] ; ᬥ饭¨¥ user-¯¥à¥¬¥­­®©
ADD EBX, EDI
MOV [EBX] , EAX
MOV EAX, [EBP]
ADD EBP, 4
RET
EndCode
Code _SLITERAL-CODE
SUB EBP, 8
MOV [EBP+4], EAX
POP EBX
MOVZX EAX, BYTE PTR [EBX]
INC EBX
MOV [EBP], EBX
ADD EBX, EAX
; INC EBX
JMP EBX
EndCode
Code _CLITERAL-CODE
SUB EBP, 4
MOV [EBP] , EAX
POP EAX
MOVZX EBX, BYTE PTR [EAX]
LEA EBX, [EAX+EBX+1]
JMP EBX
EndCode
\EOF
' _CLITERAL-CODE VALUE CLITERAL-CODE
' _CREATE-CODE VALUE CREATE-CODE
' _USER-CODE VALUE USER-CODE
' _CONSTANT-CODE VALUE CONSTANT-CODE
' _TOVALUE-CODE VALUE TOVALUE-CODE

83
programs/develop/SPForth/src/spf_except.f Normal file
View File

@ -0,0 +1,83 @@
( Структурированная обработка исключений.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
Преобразование из 16-разрядного в 32-разрядный код - 1995-96гг
Ревизия - сентябрь 1999
)
' NOOP ->VECT FATAL-HANDLER
\ если в результате сбоев повредилось исходное значение HANDLER,
\ установленное при входе в поток/задачу или позднее,
\ то выполнится этот обработчик FATAL-HANDLER
: (THROW)
\ Аналог THROW но в случае 0 последний не убирается со стека
\ Для оптимизатора.
DUP
IF
DUP 109 = IF DROP EXIT THEN \ broken pipe - обычно не ошибка, а конец входного потока в CGI
HANDLER @
DUP
IF RP!
R> HANDLER !
R> SWAP >R
SP! DROP R>
ELSE DROP FATAL-HANDLER THEN
THEN
;
: THROW
\ Если любые биты n ненулевые, взять верхний кадр исключений со стека
\ исключений, включая все на стеке возвратов над этим кадром. Затем
\ восстановить спецификации входного потока, который использовался перед
\ соответствующим CATCH, и установить глубины всех стеков, определенных
\ в этом Стандарте, в то состояние, которое было сохранено в кадре
\ исключений (i - это то же число, что и i во входных аргументах
\ соответствующего CATCH), положить n на вершину стека данных и передать
\ управление в точку сразу после CATCH, которое положило этот кадр
\ исключений.
\ Если вершина стека не ноль, и на стеке исключений есть кадр
\ исключений, то поведение следующее:
\ Если n=-1, выполнить функцию ABORT (версию ABORT из слов CORE),
\ не выводя сообщений.
\ Если n=-2, выполнить функцию ABORT" (версию ABORT" из слов CORE),
\ выводя символы ccc, ассоциированные с ABORT", генерирующим THROW.
\ Иначе система может вывести на дисплей зависящее от реализации
\ сообщение об условии, соответствующем THROW с кодом n. Затем
\ система выполнит функцию ABORT (версию ABORT из CORE).
?DUP
IF HANDLER @
?DUP
IF RP!
R> HANDLER !
R> SWAP >R
SP! DROP R>
ELSE FATAL-HANDLER THEN
THEN
;
VECT <SET-EXC-HANDLER> \ установить обработчик аппаратных исключений
: CATCH ( i*x xt -- j*x 0 | i*x n ) \ 94 EXCEPTION
\ Положить на стек исключений кадр перехвата исключительных ситуаций
\ и выполнить токен xt (как по EXECUTE) таким образом, чтобы управление
\ могло быть передано в точку сразу после CATCH, если во время выполнения
\ xt выполняется THROW.
\ Если выполнение xt заканчивается нормально (т.е. кадр исключений,
\ положенный на стек словом CATCH не был взят выполнением THROW),
\ взять кадр исключений и вернуть ноль на вершину стека данных,
\ остальные элементы стека возвращаются xt EXECUTE. Иначе остаток
\ семантики выполнения дается THROW.
\ <SET-EXC-HANDLER>
SP@ >R HANDLER @ >R
RP@ HANDLER !
EXECUTE
R> HANDLER !
RDROP
0
;
: ABORT \ 94 EXCEPTION EXT
\ Расширить сематику CORE ABORT чтобы было:
( i*x -- ) ( R: j*x -- )
\ Выполнить функцию -1 THROW
-1 THROW
;

1384
programs/develop/SPForth/src/spf_forthproc.f Normal file
View File

File diff suppressed because it is too large Load Diff

4076
programs/develop/SPForth/src/spf_forthproc.f_L Normal file
View File

File diff suppressed because it is too large Load Diff

104
programs/develop/SPForth/src/spf_forthproc_hl.f Normal file
View File

@ -0,0 +1,104 @@
( Žá⠢訥áï á«®¢  "ä®àâ-¯à®æ¥áá®à " ¢ ¢¨¤¥ ¢ë᮪®ã஢­¥¢ëå ®¯à¥¤¥«¥­¨©.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
<20>८¡à §®¢ ­¨¥ ¨§ 16-à §à來®£® ¢ 32-à §àï¤­ë© ª®¤ - 1995-96££
<20>¥¢¨§¨ï - ᥭâï¡àì 1999
)
0 CONSTANT FALSE ( -- false ) \ 94 CORE EXT
\ ‚¥à­ãâì ä« £ "«®¦ì".
-1 CONSTANT TRUE ( -- true ) \ 94 CORE EXT
\ ‚¥à­ãâì ä« £ "¨á⨭ ", ï祩ªã á® ¢á¥¬¨ ãáâ ­®¢«¥­­ë¬¨ ¡¨â ¬¨.
4 CONSTANT CELL
: */ ( n1 n2 n3 -- n4 ) \ 94
\ “¬­®¦¨âì n1 ­  n2, ¯®«ãç¨âì ¯à®¬¥¦ãâ®ç­ë© ¤¢®©­®© १ã«ìâ â d.
\ <20> §¤¥«¨âì d ­  n3, ¯®«ãç¨âì ç áâ­®¥ n4.
*/MOD NIP
;
: CHAR+ ( c-addr1 -- c-addr2 ) \ 94
\ <20>ਡ ¢¨âì à §¬¥à ᨬ¢®«  ª c-addr1 ¨ ¯®«ãç¨âì c-addr2.
1+
;
: CHARS ( n1 -- n2 ) \ 94
\ n2 - à §¬¥à n1 ᨬ¢®«®¢.
; IMMEDIATE
: MOVE ( addr1 addr2 u -- ) \ 94
\ …᫨ u ¡®«ìè¥ ­ã«ï, ª®¯¨à®¢ âì ᮤ¥à¦¨¬®¥ u ¡ ©â ¨§ addr1 ¢ addr2.
\ <20>®á«¥ MOVE ¢ u ¡ ©â å ¯®  ¤à¥áã addr2 ᮤ¥à¦¨âáï ¢ â®ç­®á⨠⮠¦¥,
\ çâ® ¡ë«® ¢ u ¡ ©â å ¯®  ¤à¥áã addr1 ¤® ª®¯¨à®¢ ­¨ï.
>R 2DUP SWAP R@ + U< \ ­ §­ ç¥­¨¥ ¯®¯ ¤ ¥â ¢ ¤¨ ¯ §®­ ¨áâ®ç­¨ª  ¨«¨ «¥¢¥¥
IF 2DUP U< \ ˆ <20>… «¥¢¥¥
IF R> CMOVE> ELSE R> CMOVE THEN
ELSE R> CMOVE THEN ;
: ERASE ( addr u -- ) \ 94 CORE EXT
\ …᫨ u ¡®«ìè¥ ­ã«ï, ®ç¨áâ¨âì ¢á¥ ¡¨âë ª ¦¤®£® ¨§ u ¡ ©â ¯ ¬ïâ¨,
\ ­ ç¨­ ï á  ¤à¥á  addr.
0 FILL ;
: BLANK ( addr len -- ) \ fill addr for len with spaces (blanks)
BL FILL ;
: DABS ( d -- ud ) \ 94 DOUBLE
\ ud  ¡á®«îâ­ ï ¢¥«¨ç¨­  d.
DUP 0< IF DNEGATE THEN
;
255 CONSTANT MAXCOUNTED \ maximum length of contents of a counted string
\ : 0X BASE @ HEX >R BL WORD ?LITERAL
\ R> BASE ! ; IMMEDIATE
: "CLIP" ( a1 n1 -- a1 n1' ) \ clip a string to between 0 and MAXCOUNTED
MAXCOUNTED AND ;
: PLACE ( addr len dest -- )
SWAP "CLIP" SWAP
2DUP C! CHAR+ SWAP CHARS MOVE ;
: +PLACE ( addr len dest -- ) \ append string addr,len to counted
\ string dest
>R "CLIP" MAXCOUNTED R@ C@ - MIN R>
\ clip total to MAXCOUNTED string
2DUP 2>R
COUNT CHARS + SWAP MOVE
2R> +! ;
: C+PLACE ( c1 a1 -- ) \ append char c1 to the counted string at a1
DUP 1+! COUNT + 1- C! ;
: STR>R ( addr u -- addr1 u)
\ <20>®«®¦¨âì áâபã addr u ­  á⥪ ¢®§¢à â®¢
\ ‚®§¢à â¨âì addr1  ¤à¥á ­®¢®© áâப¨
;
0 VALUE DOES-CODE
: $! ( addr len dest -- )
PLACE ;
: ASCII-Z ( addr len buff -- buff-z ) \ make an ascii string
DUP >R $! R> COUNT OVER + 0 SWAP C! ;
: 0MAX 0 MAX ;
: ASCIIZ> ZCOUNT ;
: R> ['] C-R> INLINE, ; IMMEDIATE
: >R ['] C->R INLINE, ; IMMEDIATE
: 2CONSTANT ( d --- )
\ Create a new definition that has the following runtime behavior.
\ Runtime: ( --- d) push the constant double number on the stack.
CREATE HERE 2! 8 ALLOT DOES> 2@ ;
: U/MOD 0 SWAP UM/MOD ;
: 2NIP 2SWAP 2DROP ;
: ON TRUE SWAP ! ;
: OFF ( a--) 0! ;

48
programs/develop/SPForth/src/spf_init.f Normal file
View File

@ -0,0 +1,48 @@
( ⻏儗魰錒諘灕<EFBFBD> USER-櫇謥懤臇𤒼.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
栫艜<E6A0AB>摫<EFBFBD> 1999
)
VARIABLE MAINX
VECT <FLOAT-INIT>
: TITLE
." SP-FOPTH ANS FORTH 94 for fasm" CR
." A.Cherezov http://www.forth.org.ru/" CR
." M.Maksimov http://forth.spb.su:8888/ http://www.chat.ru/~mak" CR
." PAGE - Clearing of a screen" CR
." WORDS - list of forth-words" CR
." BYE - KolibriOS continuance" CR
;
: ERR-EXIT ( xt -- )
CATCH
?DUP IF _BYE THEN
;
: HH.
0x10000000 U/MOD DIGIT> EMIT
0x1000000 U/MOD DIGIT> EMIT
0x100000 U/MOD DIGIT> EMIT
0x10000 U/MOD DIGIT> EMIT
0x1000 U/MOD DIGIT> EMIT
0x100 U/MOD DIGIT> EMIT
0x10 U/MOD DIGIT> EMIT DIGIT> EMIT ;
: INIT
CURFILE 0!
[ TDIS-OPT ]
1 ALIGN-BYTES !
OP0 0! JP0 JpBuffSize ERASE
0 LIT, 0x20 TO MM_SIZE SET-OPT
TITLE
['] AUTOEXEC CATCH ?DUP IF
ERROR_DO THEN
BEGIN
['] QUIT CATCH ( 璅物 能言<EFBFBD> 漭花<EFBFBD>)
ERROR_DO
AGAIN
;

76
programs/develop/SPForth/src/spf_last.f Normal file
View File

@ -0,0 +1,76 @@
DECIMAL
\ ' DUP VALUE 'DUP_V
\ ' DROP VALUE 'DROP_V
USER HLD \ ¯¥à¥¬¥­­ ï - ¯®§¨æ¨ï ¯®á«¥¤­¥© «¨â¥àë, ¯¥à¥­¥á¥­­®© ¢ PAD
0 VALUE H-STDIN \ åí­¤« ä ©«  - áâ ­¤ àâ­®£® ¢¢®¤ 
1 VALUE H-STDOUT \ åí­¤« ä ©«  - áâ ­¤ àâ­®£® ¢ë¢®¤ 
1 VALUE H-STDERR \ åí­¤« ä ©«  - áâ ­¤ àâ­®£® ¢ë¢®¤  ®è¨¡®ª
USER ALIGN-BYTES
: ALIGNED ( addr -- a-addr ) \ 94
\ a-addr - ¯¥à¢ë© ¢ë஢­¥­­ë©  ¤à¥á, ¡®«ì訩 ¨«¨ à ¢­ë© addr.
ALIGN-BYTES @ DUP 0= IF 1+ DUP ALIGN-BYTES ! THEN
2DUP
MOD DUP IF - + ELSE 2DROP THEN
;
: ALIGN ( -- ) \ 94
\ …᫨ 㪠§ â¥«ì ¯à®áâà ­á⢠ ¤ ­­ëå ­¥ ¢ë஢­¥­ -
\ ¢ë஢­ïâì ¥£®.
DP @ ALIGNED DP @ - ALLOT
;
: ALIGN-NOP ( n -- )
\ ¢ë஢­ïâì HERE ­  n ¨ § ¯®«­¨âì NOP
HERE DUP ROT 2DUP
MOD DUP IF - + ELSE 2DROP THEN
OVER - DUP ALLOT 0x90 FILL
;
: IMMEDIATE ( -- ) \ 94
\ ‘¤¥« âì ¯®á«¥¤­¥¥ ®¯à¥¤¥«¥­¨¥ á«®¢®¬ ­¥¬¥¤«¥­­®£® ¨á¯®«­¥­¨ï.
\ ˆáª«îç¨â¥«ì­ ï á¨âã æ¨ï ¢®§­¨ª ¥â, ¥á«¨ ¯®á«¥¤­¥¥ ®¯à¥¤¥«¥­¨¥
\ ­¥ ¨¬¥¥â ¨¬¥­¨.
LAST @ NAME>F DUP C@ &IMMEDIATE OR SWAP C!
;
: :NONAME ( C: -- colon-sys ) ( S: -- xt ) \ 94 CORE EXT
\ ‘®§¤ âì ¢ë¯®«­¨¬ë© ⮪¥­ xt, ãáâ ­®¢¨âì á®áâ®ï­¨¥ ª®¬¯¨«ï樨 ¨
\ ­ ç âì ⥪ã饥 ®¯à¥¤¥«¥­¨¥, ¯à®¨§¢¥¤ï colon-sys. „®¡ ¢¨âì ᥬ ­â¨ªã
\ ¨­¨æ¨ «¨§ æ¨¨ ª ⥪ã饬㠮¯à¥¤¥«¥­¨î.
\ ‘¥¬ ­â¨ª  ¢ë¯®«­¥­¨ï xt ¡ã¤¥â § ¤ ­  á«®¢ ¬¨, ᪮¬¯¨«¨à®¢ ­­ë¬¨
\ ¢ ⥫® ®¯à¥¤¥«¥­¨ï. <20>â® ®¯à¥¤¥«¥­¨¥ ¬®¦¥â ¡ëâì ¯®§¦¥ ¢ë¯®«­¥­® ¯®
\ xt EXECUTE.
\ …᫨ ã¯à ¢«ïî騩 á⥪ ॠ«¨§®¢ ­ á ¨¬¯®«ì§®¢ ­¨¥¬ á⥪  ¤ ­­ëå,
\ colon-sys ¡ã¤¥â ¢¥àå­¨¬ í«¥¬¥­â®¬ ­  á⥪¥ ¤ ­­ëå.
\ ˆ­¨æ¨ «¨§ æ¨ï: ( i*x -- i*x ) ( R: -- nest-sys )
\ ‘®åà ­¨âì § ¢¨áïéãî ®â ॠ«¨§ æ¨¨ ¨­ä®à¬ æ¨î nest-sys ® ¢ë§®¢¥
\ ®¯à¥¤¥«¥­¨ï. <20>«¥¬¥­âë á⥪  i*x ¯à¥¤áâ ¢«ïîâ  à£ã¬¥­âë xt.
\ xt ‚믮«­¥­¨¥: ( i*x -- j*x )
\ ‚믮«­¨âì ®¯à¥¤¥«¥­¨¥, § ¤ ­­®¥ xt. <20>«¥¬¥­âë á⥪  i*x ¨ j*x
\ ¯à¥¤áâ ¢«ïîâ  à£ã¬¥­âë ¨ १ã«ìâ âë xt ᮮ⢥âá⢥­­®.
HERE ]
HERE TO :-SET ;
: INCLUDED INCLUDED_ ;
' NOOP TO <PRE>
' FIND1 TO FIND
' ?LITERAL2 TO ?LITERAL
' ?SLITERAL2 TO ?SLITERAL
' OK1 TO OK.
' (ABORT1") TO (ABORT")
VECT TYPE ' _TYPE TO TYPE
VECT EMIT ' _EMIT TO EMIT
: H. BASE @ SWAP HEX U. BASE ! ;
: TST S" /rd/1/autoload.f" INCLUDED_ ;
: TST1 S" WORDS" EVALUATE ;

168
programs/develop/SPForth/src/spf_print.f Normal file
View File

@ -0,0 +1,168 @@
( Слова форматной печати чисел.
Copyright [C] 1992-1999 A.Cherezov ac@forth.org
Преобразование из 16-разрядного в 32-разрядный код - 1995-96гг
Ревизия - сентябрь 1999 [переход на USER-переменные и
замена CODE-слов высокоуровневыми определениями]
)
4096 DUP CONSTANT NUMERIC-OUTPUT-LENGTH
USER-CREATE SYSTEM-PAD
USER-ALLOT \ Область форматного преобразования - обязательно перед PAD
: HEX ( -- ) \ 94 CORE EXT
\ Установить содержимое BASE равным шестнадцати.
16 BASE !
;
: DECIMAL ( -- ) \ 94
\ Установить основание системы счисления равным десяти.
10 BASE !
;
: HOLD ( char -- ) \ 94
\ Добавить char к началу форматной числовой строки.
\ Исключительная ситуация возникает, если использовать HOLD
\ вне <# и #>, ограничивающивающих преобразование чисел.
HLD @ 1- DUP HLD ! C!
;
: HOLDS ( addr u -- ) \ from eserv src
TUCK + SWAP 0 ?DO DUP I - 1- C@ HOLD LOOP DROP
;
: <# ( -- ) \ 94
\ Начать форматное преобразование чисел.
PAD 1- HLD !
0 PAD 1- C!
;
: DIGIT> ( c -- c1 )
DUP 10 < 0= IF 7 + THEN 48 + ;
: # ( ud1 -- ud2 ) \ 94
\ Делением ud1 на значение BASE выделить одну цифру с конца и
\ добавить ее в буфер форматного преобразования чисел,
\ оставив частное ud2.
\ Исключительная ситуация возникает, если использовать #
\ вне <# и #>, ограничивающивающих преобразование чисел.
0 BASE @ UM/MOD >R BASE @ UM/MOD R>
ROT DIGIT> HOLD
;
: #S ( ud1 -- ud2 ) \ 94
\ Выделять цифры D1 по слову # до получения нуля.
\ ud2 - ноль.
\ Исключительная ситуация возникает, если использовать #S
\ вне <# и #>, ограничивающивающих преобразование чисел.
BEGIN
# 2DUP D0=
UNTIL
;
: #> ( xd -- c-addr u ) \ 94
\ Убрать xd. Сделать буфер форматного преобразования доступным в виде
\ строки символов, заданной c-addr и u.
\ Программа может менять символы в этой строке.
2DROP HLD @ PAD OVER - 1-
;
: SIGN ( n -- ) \ 94
\ Если n отрицательно, добавить в строку форматного преобразования
\ чисел минус.
\ Исключительная ситуация возникает, если использовать SIGN
\ вне <# и #>, ограничивающивающих преобразование чисел.
0< IF [CHAR] - HOLD THEN
;
: (D.) ( d -- addr len ) DUP >R DABS <# #S R> SIGN #> ;
: D. ( d -- ) (D.) TYPE SPACE ;
: . ( n -- ) S>D D. ;
: D.R ( d w -- ) >R (D.) R> OVER - 0MAX SPACES TYPE ;
: .R ( n w -- ) >R S>D R> D.R ;
: U.R ( u w -- ) 0 SWAP D.R ;
: U. ( u -- ) \ 94
\ Напечатать u в свободном формате.
U>D D.
;
: .0
>R 0 <# #S #> R> OVER - 0 MAX DUP
IF 0 DO [CHAR] 0 EMIT LOOP
ELSE DROP THEN TYPE
;
: >PRT
DUP BL U< IF DROP [CHAR] . THEN
;
: PTYPE
0 DO DUP C@ >PRT EMIT 1+ LOOP DROP
;
: DUMP ( addr u -- ) \ 94 TOOLS
DUP 0= IF 2DROP EXIT THEN
BASE @ >R HEX
15 + 16 U/ 0 DO
CR DUP 4 .0 SPACE
SPACE DUP 16 0
DO I 4 MOD 0= IF SPACE THEN
DUP C@ 2 .0 SPACE 1+
LOOP SWAP 16 PTYPE
LOOP DROP R> BASE !
;
: (.") ( T -> )
COUNT TYPE
;
\ ' (.") TO (.")-CODE
: DIGIT ( C, N1 ->> N2, TF / FF )
\ N2 - значение литеры C как
\ цифры в системе счисления по основанию N1
>R
[CHAR] 0 - 10 OVER U<
IF
DUP [CHAR] A [CHAR] 0 - < IF RDROP DROP 0 EXIT THEN
DUP [CHAR] a [CHAR] 0 - 1- > IF [CHAR] a [CHAR] A - - THEN
[CHAR] A [CHAR] 0 - 10 - -
THEN R> OVER U> DUP 0= IF NIP THEN ;
: >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ 94
\ ud2 - результат преобразования символов строки, заданной c-addr1 u1,
\ в цифры, используя число в BASE, и добавлением каждой к ud1 после
\ умножения ud1 на число в BASE. Преобразование продолжается слева
\ направо до первого непреобразуемого символа, включая символы "+" и "-",
\ или до полного преобразования строки.
\ c-addr2 - адрес первого непреобразумого символа или первого символа
\ за концом строки, если строка была полностью преобразована.
\ u2 - число непреобразованных символов в строке.
\ Неоднозначная ситуация возникает, если ud2 переполняется во время
\ преобразования.
BEGIN
DUP
WHILE
>R
DUP >R
C@ BASE @ DIGIT 0= \ ud n flag
IF R> R> EXIT THEN \ ud n ( ud = udh udl )
SWAP BASE @ UM* DROP \ udl n udh*base
ROT BASE @ UM* D+ \ (n udh*base)+(udl*baseD)
R> 1+ R> 1-
REPEAT
;
: SCREEN-LENGTH ( addr n -- n1 ) \ экранная-длина
\ дать длину строки при выводе (при печати)
\ - число знакомест, которое строка займет на экране.
\ addr n - строка. n1 число знакомест на экран.
0 -ROT OVER + SWAP ?DO
I C@ 9 = IF 3 RSHIFT 1+ 3 LSHIFT
ELSE 1+ THEN
LOOP
;

93
programs/develop/SPForth/src/tc_spfopt.f Normal file
View File

@ -0,0 +1,93 @@
REQUIRE INCLUDED_L ~mak/listing3.f
0 VALUE TOUSER-VALUE-CODE
0 VALUE ---CODE
0 VALUE DO-OFF
0 VALUE ?DO-OFF
0 VALUE OFF-LOOP
0 VALUE OFF-+LOOP
0 VALUE 'DUP_V
0 VALUE 'DROP_V
' DUP TO 'DUP_V
' DROP TO 'DROP_V
: 'DUP 'DUP_V ;
: 'DROP 'DROP_V ;
: M\ POSTPONE \ ; IMMEDIATE
: OS\ ( POSTPONE \) ; IMMEDIATE
: [>T] ; IMMEDIATE
: >T ; IMMEDIATE
TRUE VALUE J_OPT?
: TT ;
S" src/macroopt.f" INCLUDED
: TSET-OPT SET-OPT ;
: TDIS-OPT DIS-OPT ;
: TOMM_SIZE TO MM_SIZE ;
REQUIRE GTYPE ~mak/djgpp/gdis.f
TRUE TO ?C-JMP
\ 0 TO ?C-JMP
: TC-COMPILE, \ 94 CORE EXT
\ Èíòåðïðåòàöèÿ: ñåìàíòèêà íå îïðåäåëåíà.
\ Âûïîëíåíèå: ( xt -- )
\ Äîáàâèòü ñåìàíòèêó âûïîëíåíèÿ îïðåäåëåíèÿ, ïðåäñòàâëåíîãî xt, ê
\ ñåìàíòèêå âûïîëíåíèÿ òåêóùåãî îïðåäåëåíèÿ.
CON>LIT
IF INLINE?
IF INLINE,
ELSE _COMPILE,
THEN
THEN
;
: _DABS ( d -- ud ) \ 94 DOUBLE
\ ud àáñîëþòíàÿ âåëè÷èíà d.
DUP 0< IF DNEGATE THEN
;
0xE9 ' COMPILE, C!
' TC-COMPILE, ' COMPILE, - 5 - ' COMPILE, 1+ !
: DABS ( d -- ud ) \ 94 DOUBLE
\ ud àáñîëþòíàÿ âåëè÷èíà d.
DUP 0< IF DNEGATE THEN
;
0 VALUE TSAVE_LIMIT
: TSAVE ( ADDR LEN -- )
H-STDOUT >R R/W CREATE-FILE THROW TO H-STDOUT
UNIX-LINES
CR ." MUSEROFFS EQU " USER-HERE RESERVE - 2 MAX .
CR
HERE >R
CONTEXT @ @
BEGIN
CR ." AHEADER "
DUP 1- C@ . ." ,"
DUP COUNT ATYPE ." ,"
DUP COUNT GTYPE
CR
R> OVER NAME> GDIS
DUP NAME>C >R
CDR
DUP TSAVE_LIMIT U<
UNTIL DROP RDROP CR
H-STDOUT CLOSE-FILE THROW R> TO H-STDOUT
;
: RN> CHAR SWAP WordByAddr DROP C! ;
' CR CONSTANT '_CR