forked from KolibriOS/kolibrios
Forth 12.1: several optimizations
git-svn-id: svn://kolibrios.org@4868 a494cfbc-eb01-0410-851d-a64ba20cac60
This commit is contained in:
Kirill Lipatov (Leency)
parent
09488af869
commit
154d1426af
@ -1,137 +0,0 @@
|
||||
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'
|
||||
@ -1 +1,3 @@
|
||||
fasm.exe meforth.ASM
|
||||
|
||||
pause
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
; KolSPForth v12
|
||||
|
||||
SYSTEM equ EMUL
|
||||
SYSTEM equ EMUL
|
||||
|
||||
;Memory Map
|
||||
;
|
||||
@ -86,18 +86,19 @@ cfa_#F_CFA:
|
||||
}
|
||||
|
||||
|
||||
;; Main entry points and COLD start data
|
||||
;; Main entry points and COLD start data
|
||||
|
||||
use32
|
||||
format binary as ""
|
||||
|
||||
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
|
||||
db 'MENUET01'
|
||||
dd 0x01
|
||||
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
|
||||
@ -107,7 +108,7 @@ end if
|
||||
|
||||
lang fix ru
|
||||
include 'MACROS.INC'
|
||||
include "proc32.inc"
|
||||
include '..\..\proc32.inc'
|
||||
|
||||
align 4
|
||||
proc strncmp stdcall, s1:dword, s2:dword, n:dword
|
||||
@ -179,47 +180,53 @@ BYE: mcall -1
|
||||
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
|
||||
pusha
|
||||
mcall 12,1
|
||||
mov [fRed],ebx
|
||||
mcall 0, <0,FW_WIDTH>, <0,FW_HEIGHT>, 0x54000000
|
||||
; mcall 0,,,COL_WINDOW_BG, ,title ; define window
|
||||
mcall 71, 1, header
|
||||
|
||||
mcall 9,pinfo,-1
|
||||
mov eax,[pinfo.x_size]
|
||||
cdq
|
||||
sub eax,20
|
||||
mov ebx,6
|
||||
div ebx
|
||||
mov [pinfo.x_start],eax
|
||||
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 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
|
||||
mov [pinfo.y_start],eax
|
||||
call erase_screen
|
||||
mcall 12, 2
|
||||
mcall 67,-1,-1,FW_WIDTH,FW_HEIGHT
|
||||
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
|
||||
macro GetSkinHeight
|
||||
{
|
||||
mov eax,48
|
||||
mov ebx,4
|
||||
int 0x40
|
||||
}
|
||||
|
||||
erase_screen:
|
||||
GetSkinHeight
|
||||
mov ecx,eax
|
||||
shl ecx,16
|
||||
add ecx,[pinfo.y_size]
|
||||
sub ecx,eax
|
||||
sub ecx,4
|
||||
mov ebx,[pinfo.x_size]
|
||||
add ebx,5 shl 16 - 9
|
||||
mcall 13,,,0;xff
|
||||
ret
|
||||
|
||||
|
||||
AHEADER 0,"CC_LINES",cfa_CC_LINES
|
||||
@ -463,6 +470,8 @@ cfa_AHEADER 0,'READ_GIF',READ_GIF ;( gif_ptr, out_ptr -- result )
|
||||
last_ebp dd 0
|
||||
|
||||
include 'amain.asm'
|
||||
|
||||
header db 'Kolibri Forth v12.1',0
|
||||
|
||||
FINFO:
|
||||
.mode dd 0
|
||||
@ -471,17 +480,9 @@ cfa_AHEADER 0,'READ_GIF',READ_GIF ;( gif_ptr, out_ptr -- result )
|
||||
.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 '/RD/1/PICTURE.F'
|
||||
db 0
|
||||
.end_path:
|
||||
|
||||
|
||||
@ -1,268 +0,0 @@
|
||||
|
||||
; 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 }
|
||||
Loading…
Reference in New Issue
Block a user