forth5mx_procs.opp
Descripción del contenido de la página
Uno de los ficheros fuentes principales de Forth 5mx, un Forth para la computadora Psion 5mx, escrito en OPL+.
Este fichero contiene procedimientos de uso general, o bien extraídos de la definición de palabras en Forth para ser reutilizados.
Código fuente
// forth5mx_procs.opp
// Copyright (C) 2004-2011,2015 Marcos Cruz (http://programandala.net)
// This file is part of Forth 5mx.
// Forth 5mx 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, see <http://gnu.org/licenses>.
/*
Procs
*/
// -------------------------------------------------------
// Some Forth words factored to procedures
// -------------------------------------------------------
proc dump:(a&,u&)
local address&,count&
local temp&,i&,char%
address& = a&
count& = u&
while count&>0
temp& = address&
i& = 8
print right$("0000000"+hex$(temp&)+" ",8),
while i&
print right$("0"+hex$(peekb(temp&)),2),
i&--
temp&++
endwh
temp& = address&
i& = 8
while i&
char% = peekb(temp&)
if (char% < KKeySpace%)
char% = %.
endif
print chr$(char%);
i&--
temp&++
endwh
print
address& = address& + 8
count& = count& - 8
endwh
endp
// -------------------------------------------------------
// Low level procedures to build words
// -------------------------------------------------------
proc primitive&:(_name$,_control_bits%)
header&:(_name$,_control_bits%)
_COMMA?(last_nt&) // vector to OPL label
return last_nt&
endp
proc header&:(_name$,_control_bits%)
// Create a word header in the dictionary.
_CALCULATE_HASH_LOCALS
#ifdef _WARNING // does the warning feature must be compiled?
_FIND_LOCALS // locals needed by forth5mx_inc_find.opp
if warning&
nametofind$=_name$
// input:nametofind$
#include "forth5mx_inc_find.opp"
// output: nt& = nt or 0
if nt&
print "Warning:",_name$,"isn't unique."
endif
endif
#endif
#if 0 // obsolete
last_nt& = last_nt&+1
name&(last_nt&)=_NAME_ADDRESS
poke$ name&(last_nt&), lower$(left$(_name$,KMaxHeaderSize%))
dp& = _ALIGNED?(dp&)
_COMMA?(last_nt&)
pokel _XT_ADDRESS?(last_nt&), dp&
pokeb _CONTROL_BITS_ADRESS?(last_nt&), _control_bits%
#else
last_nt& = last_nt&+1
poke$ _NAME_ADDRESS?(last_nt&), lower$(left$(_name$,KMaxNameSize%))
dp& = _ALIGNED?(dp&)
_COMMA?(last_nt&)
pokel _XT_ADDRESS?(last_nt&), dp&
pokeb _CONTROL_BITS_ADDRESS?(last_nt&), _control_bits%
#endif
// maybe faster with the former poke$ value? b!!!
word$=_NAME?(last_nt&)
// input: word$
_CALCULATE_HASH
// output: hash%
#ifdef _DEBUG1
if word$="drop"
print "DROP hash=";hash%
get
endif
#endif
thread&(thread_pointer%) = thread&(hash%)
thread&(thread_pointer%+1) = last_nt&
thread&(hash%) = thread_pointer%
thread_pointer% = thread_pointer%+2
endp
// -------------------------------------------------------
// Procedures to manage strings
// -------------------------------------------------------
proc move:(string$,addr&)
// Store string$ in addr&.
// ?!!!
// used only by ACCEPT and EXPECT
// Could be used the macro _STORE_STRING instead
local temp&, i&
temp& = len(string$)
i& = 0 // ?!!! needed?
while i& < temp&
pokeb addr&+i&,asc(mid$(string$,i&+1,1))
i& = i&+1
endwh
endp
// -------------------------------------------------------
// Procedures to manage numbers
// (unfinished, experimental)
// -------------------------------------------------------
proc signed_unsigned:(number)
// Return the two's complement of a 32-bit number,
// but only if the number is in the range in which
// the integer can be signed or unsigned.
local complement
// 4294967296 = 2^32
// 2147483648 = 2^31
// 2147483647 = 2^31 - 1
complement = number
if number<0
complement = 4294967296+number
elseif number>2147483647
complement = -4294967296+number
endif
return complement
endp
proc complement2:(number)
// Return the two's complement of a 32-bit number.
local complement
// 4294967296 = 2^32
// 2147483648 = 2^31
// 2147483647 = 2^31 - 1
// :!!! ?!!!
complement = number
if number<0
complement = 4294967296+number
elseif number>2147483647
complement = -4294967296+number
endif
return complement
endp
proc unsigned:(signed&)
// :!!!
// Return the unsigned 32-bit integer correspondent to a signed 32-bit integer.
// 4294967296 = 2^32
/*
local result
print "unsigned 1: "; result
result=4294967296
print "unsigned 2: "; result
result=result*abs(signed&<0)
print "unsigned 3: "; result
result=result+signed&
print "unsigned 4: "; result
return result
*/
return 4294967296*abs(signed&<0)+signed&
endp
proc signed&:(unsigned)
// Return the signed 32-bit integer correspondent to an unsigned 32-bit integer.
// 4294967296 = 2^32
// 2147483648 = 2^31
// 2147483647 = 2^31 - 1
return -4294967296*abs(unsigned>2147483647)+unsigned
endp
// -------------------------------------------------------
// Procedures to manage numbers
// -------------------------------------------------------
proc numberq%:(number$)
// Used in NUMBER? and INTERPRET
local startchar%,testchar%,currentchar%,valid%
testchar% = len(number$)
startchar% = (asc(left$(number$,1)) <> %-) + 1
do
#ifdef _NOT_DEFINED
// old code
currentchar% = asc(mid$(number$,testchar%,1))
currentchar% = currentchar%-(currentchar%>=%a and %a)-(currentchar%<=%9 and 26)-22
valid% = (currentchar% < base&) and (currentchar% >= 0)
#else
currentchar% = asc(mid$(number$,testchar%,1))
// print mid$(number$,testchar%,1), currentchar% // d!!!
valid%=CharIsAlphaDigit%:(currentchar%)
if valid%
currentchar%=currentchar%-%0-(7 and (CharIsAlpha%:(currentchar%)))-(32 and (CharIsLower%:(currentchar%)))
// print "alphadigit converted to ";currentchar% // d!!!
valid%=(currentchar% < base&)
endif
#endif
testchar%--
until (testchar% = startchar%) or (not valid%)
return valid%
endp
proc number&:(number$)
// Used in NUMBER and INTERPRET
local lastchar%,testchar%,currentchar%
local number, number&
testchar% = (asc(left$(number$,1)) <> %-) + 2
lastchar% = len(number$)
number = 0
do
currentchar% = asc(mid$(number$,testchar%,1))
currentchar% = currentchar% - %0 - (currentchar%>96 and 32) - (currentchar%>64 and 7)
number = number*base&+currentchar%
testchar%++
until (testchar% > lastchar%)
if (asc(left$(number$,1)) = %-)
number = 0-number
if number<-2147483648
// error :!!!
endif
else
if number>2147483647
number=signed&:(number)
endif
endif
return number
endp
proc digit:
// ?!!!
local temp&
temp& = mod&:(tos&,base&)
tos& = tos&/base&
if temp& > 41 // 41 = ascii )
temp& = temp&+39 // 39 = ascii '
endif
hold: (temp&+48) // 48 = ascii 0
endp
proc hold:(char&)
// ?!!!
local temp&
temp& = pad&
pokel temp&,peekl(temp&)-1
pokeb peekl(temp&),char&
endp
// -------------------------------------------------------
// Terminal input
// -------------------------------------------------------
proc press_key:
print "-- Press a key to continue. --" // ?!!!
get
endp
proc lineedit$:(line$,len&,dohotkey&)
local editcmd%(13) // one more than needed; the last element must be zero
local cmd%
local line1$(KMaxStringLen%)
local key%
local cursor%
local temp%
local to%,from% // used in left and right movements
local clipboard$(KMaxStringLen%)
local current_history%
current_history%=LastHistory%
editcmd%(1) = KKeyDel%
editcmd%(2) = KKeyLeftArrow%
editcmd%(3) = KKeyRightArrow%
editcmd%(4) = KKeyPageLeft%
editcmd%(5) = KKeyPageRight%
editcmd%(6) = KKeyEsc%
editcmd%(7) = KKeySidebarMenu%+3 // zoom out
editcmd%(8) = KKeySidebarMenu%+4 // zoom in
editcmd%(9) = 12 // Ctrl L
editcmd%(10) = KKeyUpArrow%
editcmd%(11) = KKeyDownArrow%
editcmd%(12) = 22 // Ctrl V
line1$ = line$
cursor% = len(line1$)+1
print
showline: (line1$,cursor%)
key% = get
if key%=5 // Ctrl E
bye:
endif
while key% <> KKeyEnter%
if key% >= KKeySpace& and key% <= 255
// printable char
if len(line1$) < len&
line1$ = left$(line1$,cursor%-1)+chr$(key%)+mid$(line1$,cursor%,KMaxStringLen%)
cursor% = cursor%+1
showline:(line1$,cursor%)
else
beep 2,800
endif
else
// edit command
cmd% = 0
do
cmd% += 1
until editcmd%(cmd%)=0 or editcmd%(cmd%)=key%
vector cmd%
backspace
cursorleft
cursorright
cursorhome
cursorend
eraseline
zoomin
zoomout
clearscreen
cursorup
cursordown
paste
endv
/*
if dohotkey&
if xkeytable&
print
print "keytable has no function yet. key was ",key%
showline:(line1$,cursor%)
endif
endif
*/
beep 2,800
goto nextkey
paste::
clipboard$=from_clipboard$:
if len(clipboard$)<=(len&-len(line1$))
line1$ = left$(line1$,cursor%-1)+clipboard$+mid$(line1$,cursor%,KMaxStringLen%)
cursor% = cursor%+len(clipboard$)
showline:(line1$,cursor%)
else
beep 2,800
endif
goto showline
clearscreen::
cls
goto showline
backspace::
if kmod = KKmodShift%
if cursor% <= len(line1$)
line1$ = deletechar$:(line1$,cursor%)
endif
elseif cursor% > 1
cursor%--
line1$ = deletechar$:(line1$,cursor%)
endif
goto showline
/* // :!!!
cursor% = cursor%-(kmod<>KKmodShift%)*(cursor%>1)
line1$ = left$(line1$,max(0,cursor%-1))+mid$(line1$,max(len(line1$),cursor%+1),KMaxStringLen%)
goto showline
*/
cursorleft::
if kmod = 0
// move to the next left character
cursor% = max(cursor%-1,1)
else
if kmod = KKmodControl%
// move to the next left word
temp%=0
to%=asc(mid$(line1$,cursor%,1))
from%=to%
while (cursor%>1) and not(from%<>KKeySpace% and to%=KKeySpace% and temp%>1)
from%=to%
cursor%--
temp%++
to%=asc(mid$(line1$,cursor%,1))
endwh
cursor%=cursor%+iabs(cursor%<>1)
endif
endif
goto showline
cursorright::
if kmod = 0
// move to the next right character
cursor% = min(cursor%+1,len(line1$)+1)
else
if kmod = KKmodControl%
// move to the next right word
to%=asc(mid$(line1$,cursor%,1))
from%=to%
while (cursor%<len(line1$)) and not(from%=KKeySpace% and to%<>KKeySpace%)
from%=to%
cursor%++
to%=asc(mid$(line1$,cursor%,1))
endwh
endif
endif
goto showline
cursorup::
if current_history%
line1$=history$(current_history%)
current_history%--
if current_history%<1
current_history%=MaxLastHistory%
endif
goto cursorhome
else
beep 2,800
endif
cursordown::
if current_history%
line1$=history$(current_history%)
current_history%++
if current_history%>MaxLastHistory%
current_history%=1
endif
else
beep 2,800
endif
cursorhome::
cursor% = 1
goto showline
cursorend::
cursor% = len(line1$)+1
goto showline
eraseline::
showline:(rept$(" ",len(line1$)+1),0)
line1$ = ""
cursor% = 1
goto showline
zoomin::
temp% = 1
goto changefont
zoomout::
temp% = -1
changefont::
temp% = max(min(font%+temp%,KFonts%),1)
setfont:(temp%,fontattr%)
hello:
print "font",font%,"of",KFonts%;":",screeninfo%(4);"×";screeninfo%(3)
_OK
showline::
// print "lh=";lasthistory%;" mlh=";maxlasthistory%;" ch=";current_history% // d!!!
showline:(line1$,cursor%)
nextkey::
endif
key% = get
endwh
// showline:(line1$,not(cursor%)) // old!!!
print chr$(KKeyEnter%);line1$;chr$(KKeySpace&)
if len(line1$)
// Add to the history
LastHistory%++
if LastHistory%>KMaxHistory%
LastHistory%=1
endif
MaxLastHistory%++
MaxLastHistory%=min(MaxLastHistory%,KMaxHistory%)
history$(LastHistory%) = line1$
endif
return line1$
endp
proc deletechar$:(line$,cursor%)
return left$(line$,cursor%-1)+mid$(line$,cursor%+1,KMaxStringLen%)
endp
proc showline:(line$,cursor%)
local screen_width%
local offset%
local line_showed$(KMaxStringLen%)
local cursor_showed%
local temp%
screeninfo screeninfo%()
screen_width%=screeninfo%(KSInfoAScrW%)-1
offset%=max(1,max(cursor%,1)-screen_width%+1)
line_showed$=mid$(line$,offset%,screen_width%+(cursor%>len(line$)))+left$(" ",iabs(cursor%>len(line$)))
cursor_showed%=max(cursor%,1)-offset%+1
// *!!!
// cls
// print "[";rept$("-",screen_width%-2);"]"
// print "len=";len(line$);" cursor=";cursor%;" width=";screen_width%;" len_sh=";len(line_showed$);" cursor_sh=";cursor_showed%
gupdate off
print chr$(KKeyEnter%);
print left$(line_showed$,cursor_showed%-1);
style KgStyleInverse%
print mid$(line_showed$,max(1,cursor_showed%),iabs(cursor_showed%<=len(line_showed$))); // cursor
style fontattr%
print right$(line_showed$,max(0,len(line_showed$)-cursor_showed%));
print left$(" ",iabs(len(line_showed$)<screen_width%));
temp%= screen_width%-len(line_showed$)-1
temp% = temp%*iabs(temp%>0)
print rept$(" ",temp%); // erase possible rests of history commands
gupdate on
endp
// -------------------------------------------------------
// Screen
// -------------------------------------------------------
proc setfont:(fontsize%,desiredattr%)
local font&,usedattr%
font% = fontsize%
fontattr% = desiredattr%
usedattr% = desiredattr% and (not 1)
if desiredattr% and 1
usedattr% = usedattr% or boldattr%(fontsize%)
font& = boldfont&(fontsize%)
else
usedattr% = usedattr% or thinattr%(fontsize%)
font& = thinfont&(fontsize%)
endif
font font&,usedattr%
screeninfo screeninfo%()
endp
proc hello:
cls
print "Forth 5mx (version ";_VERSION;")"
print "A Forth for the Psion 5mx computer"
print "Copyright (C) 2004-2010 Marcos Cruz (http://programandala.net)"
print "This program comes with ABSOLUTELY NO WARRANTY. This is free software,"
print "and you are welcome to redistribute it under certain conditions;"
print "for details type LICENSE ."
endp
/*
// obsolete
proc mm$:(month_abbr$)
local temp%
temp% = loc("JanFebMarAprMayJunJulAugSepOctNovDec",month_abbr$)
temp% = temp%/3+1
return right$("0"+gen$(temp%,2),2)
endp
proc version$:(opp_date$)
return "v."+right$(opp_date$,4)+mm$:(left$(opp_date$,3))+mid$(opp_date$,5,2)+" r."+gen$(KRelease%,1)
endp
*/
proc indicate:(string$)
if string$ <> indicator$
indicator$ = string$
if len(indicator$)
busy indicator$,KBusyBottomRight%
else
busy off
endif
endif
endp
// -------------------------------------------------------
// Error
// -------------------------------------------------------
proc report_error:(error$)
/* This proc must be called with the macro _REPORT_ERROR,
that inits the global variables needed here and in the debug proc.
*/
local errorlocation%, key%
print
if sourceid&
// loading from file
print g_ib$
endif
errorlocation% = max(0,g_toin&-len(g_parsed_word$)-1)
print rept$(" ",errorlocation%);rept$("^",len(g_parsed_word$))
print "error:",upper$(g_parsed_word$)
print error$
if error_sound&
// provisional :!!!
// It should be controled from Forth
beep 32,800
// playsound:("z:\system\alarms\timbre",volume&)
endif
print "-- Press [D] to debug. Any other to continue. --"
key%=get
if key%=%D or key%=%d
debug:(error$) // *!!!
endif
endp
// -------------------------------------------------------
// Files
// -------------------------------------------------------
proc whole_path$:(given_path$)
// Return whole path.
local new_path$(KMaxStringLen%),drive$(2),i%
new_path$=backslash$:(given_path$)
// if mid$(new_path$,2,1)=":"
// drive$=left$(new_path$,2)
// new_path$=right$(new_path$,len(new_path$)-2)
// else
// drive$=left$(path$,2)
// endif
if left$(new_path$,1)="\"
new_path$=left$(path$,2)+new_path$
// elseif left$(new_path$,1)="~\"
// new_path$=home_path$+right$(new_path$,len(new_path$)-2)
// elseif left$(new_path$,2)=".\"
// new_path$=path$+right$(new_path$,len(new_path$)-2)
// elseif left$(new_path$,3)="..\"
// new_path$=parent_dir$:(path$)+right$(new_path$,len(new_path$)-3)
elseif mid$(new_path$,2,1)<>":"
new_path$=path$+new_path$
endif
// Take ".\" off:
i%=loc(new_path$,"\.\")
while i%
new_path$=left$(new_path$,i%)+right$(new_path$,len(new_path$)-i%-2)
i%=loc(new_path$,"\.\")
endwh
// Make "..\" efective:
i%=loc(new_path$,"\..\")
while i%
new_path$=parent_dir$:(left$(new_path$,i%))+right$(new_path$,len(new_path$)-i%-3)
i%=loc(new_path$,"\..\")
endwh
return new_path$
endp
proc backslash$:(given_path$)
// Changes Unix slashes into DOS backslashes.
local new_path$(KMaxStringLen%),addr&,i%
new_path$=given_path$
addr&=addr(new_path$)
i%=peekb(addr&)
while i%
if peekb(addr&+i%)=%/
pokeb(addr&+i%),KCharBackSlash%
endif
i%=i%-1
endwh
return new_path$
endp
proc parent_dir$:(given_dir$)
// Return the parent of a given directory
// :!!!
local parent$(KMaxStringLen%),parent&,i%,c%
parent$=backslash$:(given_dir$)
parent&=addr(parent$)
i%=peekb(parent&)
do
i%=i%-1
c%=peekb(parent&+i%)
until c%=KCharBackSlash% or c%=%: or i%=0
pokeb parent&,i%
return parent$
endp
proc only_path$:(path_and_file$)
// Return only the path, without the file name.
local path$(KMaxStringLen%), path&, i%
path$ = path_and_file$
path& = addr(path$)
i% = peekb(path&)
while i%
if peekb(path&+i%)=KCharBackSlash%
break
endif
i%=i%-1
endwh
pokeb path&,i%
return path$
endp
proc OBSOLETE_close_file:(file_id&)
if ioclose(file_id&)
report_error:("error closing file")
endif
endp
proc unlimited_ioread&:(fileid&,address&,bytes&)
// Read up to bytes& bytes from a file with the handle fileid% as set by IOOPEN.
// address& is the address of a buffer into which the data is read.
// This proc does not have the 16 KiB limit of the original ioread().
// 2007-10-19
// 2008-05-11 Bug fixed
local current_address&
local bytes_left&
local bytes_to_read%
local ior%
local ret&
current_address& = address&
bytes_left& = bytes&
ior%=0 // :!!! not needed
while bytes_left& and ior%>-1
bytes_to_read% = min(16384,bytes_left&)
ior%=ioread(fileid&,current_address&,bytes_to_read%)
// old code: //
// if ior%<0
// // ior% = error code
// bytes_left&=0 // exit
// else
if ior%>0
// ior% = bytes read
current_address&+=ior%
bytes_left&-=ior%
endif
endwh
if ior%>=0 or ior%=-36
// no error or "end of file"
// :!!! this calculation is not real in case of error -36:
ret&=bytes&-bytes_left&
else
// error
ret&=ior%
endif
return ret&
endp
// -------------------------------------------------------
// Debug
// -------------------------------------------------------
/* unused
proc debug_packed$:(_addr&,_len&)
// debug procedure *!!!
// Print the string whose address and lenght are indicated.
local string$(KMaxStringLen%), addr&, len&
addr& = _addr&
len& = _len&
while len&
string$ = string$+chr$(peekb(addr&))
len& = len&-1
addr& = addr&+1
endwh
print string$
debug:("fin de debug_packed$")
endp
*/
proc pointed$:(pointer1&,pointer2&,_mark$)
// pointer1& = 0 ... depth
// pointer2& = 0 ... depth
// _mark$ = character to return
// Return a character if both pointers are the same. Otherwise return an empty string.
local mark$(1)
if pointer1&=pointer2&
mark$=_mark$
endif
return mark$
endp
proc stack_element&:(n&)
// n& = 0 ... data stack depth
// Return an element from the data stack.
#ifdef _TOS
return g_tos&*iabs(n&=0)+peekl(g_sp&+KCell&*(n&-1))*iabs(n&>0)
#else
return peekl(g_sp&+KCell&*n&)
#endif
endp
proc rstack_element&:(n&)
// n& = 0 ... return stack depth
// Return an element from the return stack.
return peekl(g_rp&+KCell&*n&)
endp
proc debug_type:(address&,len&)
local a&,i&
a& = address&
i& = len&
while i&
print chr$(peekb(a&));
a& = a&+1
i& = i&-1
endwh
print
print "Press any key to continue"
get
endp
proc debug:(debug_point$)
/* This proc must be called with the macro _DEBUG,
that inits the global variables needed here.
*/
local inwp&
local depth&,rdepth&
local stack_pointer&,rstack_pointer&
local option%
local title$(KMaxStringLen%)
local a1&,u1&,i&
if not debug&
return 0
endif
beep 10,800
inwp& = 0
screeninfo screeninfo%()
title$=" DEBUG POINT"+left$(": ",2*iabs(debug_point$<>""))+debug_point$+" "
title$=rept$("*",(screeninfo%(3)-len(title$))/2)+title$+rept$("*",(screeninfo%(3)-len(title$))/2)
do
print :print title$
print "ip=";g_ip&,
if g_ip&
print "(ip)=";peekl(g_ip&),
endif
print "wp=";g_wp&,
if g_wp&
print "(wp)=";peekl(g_wp&);" ( ";_NAME?(peekl(g_wp&));" )",
endif
print "dp=";g_dp&,
print "latest=";g_last_nt&;" ( ";_NAME?(g_last_nt&);" )"
// data stack
print "Data stack: sp0=";g_sp0&,"sp=";g_sp&,"(";
depth&=(g_sp0&-g_sp&)/KCell&
if depth&
print depth&;" element";left$("s",iabs(depth&>1));")"
print "( S: ";
#ifdef _TOS
while depth&>1
print pointed$:(depth&-1,stack_pointer&,"<");peekl(g_sp&+KCell&*(depth&-2));pointed$:(depth&-1,stack_pointer&,">");" ";
depth&--
endwh
print pointed$:(0,stack_pointer&,"<");g_tos&;pointed$:(0,stack_pointer&,">");" ";
#else
while depth&
print pointed$:(depth&-1,stack_pointer&,"<");peekl(g_sp&+KCell&*(depth&-1));pointed$:(depth&-1,stack_pointer&,">");" ";
depth&--
endwh
#endif
else
print "empty";
endif
print ")"
// return stack
print "Return stack: rp0=";g_rp0&,"rp=";g_rp&,"(";
rdepth&=(g_rp0&-g_rp&)/KCell&
if rdepth&
print rdepth&;" element";left$("s",iabs(rdepth&>1));")"
print "( R: ";
while rdepth&
print pointed$:(rdepth&-1,rstack_pointer&,"{");peekl(g_rp&+KCell&*(rdepth&-1));pointed$:(rdepth&-1,rstack_pointer&,"}");" ";
rdepth&=rdepth&-1
endwh
else
print "empty";
endif
print ")"
print "source recursion=";g_source_recursion%;
print " source-id=";g_sourceid&;
print "ib_len&=";g_ib_len&;" >IN=";g_toin&
print "ib$=«";left$(g_ib$,g_toin&);"[>IN]";right$(g_ib$,max(0,len(g_ib$)-g_toin&));"»"
print "(ib_addr&)=«";
if g_ib_len&
i&=0
while i&<g_ib_len&
print chr$(peekb(g_ib_addr&+i&));
i&++
endwh
endif
print "»"
print
print "General commands: [a]bort [b]ye [l]eave debug-[o]ff"
print "Data stack commands: [<>] [e]mit [f]etch [t]ype [d]ump"
print "Return stack commands: [{}] [E]mit [F]etch [T]ype [D]ump"
print rept$("*",screeninfo%(3)-1)
option%=get
if option%=%f
// @
print stack_element&:(stack_pointer&);" @ ";peekl(stack_element&:(stack_pointer&))
print stack_element&:(stack_pointer&);" C@ ";peekb(stack_element&:(stack_pointer&))
press_key:
elseif option%=%F
// @
print rstack_element&:(rstack_pointer&);" @ ";peekl(rstack_element&:(rstack_pointer&))
print rstack_element&:(rstack_pointer&);" C@ ";peekb(rstack_element&:(rstack_pointer&))
press_key:
elseif option%=%b
stop
elseif option%=%D
// DUMP from the return stack
dump:(rstack_element&:(rstack_pointer&),64)
press_key:
elseif option%=%d
// DUMP from the data stack
dump:(stack_element&:(stack_pointer&),64)
press_key:
elseif option%=%E
// EMIT from the return stack
print rstack_element&:(rstack_pointer&);" EMIT ";chr$(rstack_element&:(rstack_pointer&))
press_key:
elseif option%=%e
// EMIT from the data stack
print stack_element&:(stack_pointer&);" EMIT ";chr$(stack_element&:(stack_pointer&))
press_key:
elseif option%=%o
debug&=KFalse&
elseif option%=%T
// TYPE from the return stack
debug_type:(rstack_element&:(rstack_pointer&),rstack_element&:(rstack_pointer&-1))
elseif option%=%t
// TYPE from the data stack
debug_type:(stack_element&:(stack_pointer&),stack_element&:(stack_pointer&-1))
elseif option%=%>
stack_pointer&=stack_pointer&-iabs(stack_pointer&>0)
elseif option%=%<
stack_pointer&=stack_pointer&+iabs(stack_pointer&<((g_sp0&-g_sp&)/KCell&-1))
elseif option%=%}
rstack_pointer&=rstack_pointer&-iabs(rstack_pointer&>0)
elseif option%=%{
rstack_pointer&=rstack_pointer&+iabs(rstack_pointer&<((g_rp0&-g_rp&)/KCell&-1))
endif
until option%=%l or option%=%a or option%=%o
aborted% = (option%=%a)
endp
proc trace_message:(text$)
print text$;" - PRESS ANY KEY"
get
endp
// -------------------------------------------------------
// Clipboard
// -------------------------------------------------------
proc from_clipboard$:
// Return the string in the clipboard.
// Copied from the OPL_Knowledge_base
local string$(255),len&
len&=read_clipboard_buffer&:(addr(string$)+1,int(255))
pokeb addr(string$),len&
return string$
endp
proc read_clipboard_buffer&:(_Buf&,Bytes&)
// Copied from the OPL_Knowledge_base
local CbId%,cbLen&,Pos&,Offset&
Offset&=16
IOOPEN(CbId%,KClipboardFile$,512)
IOSEEK(CbId%,1,Offset&)
IOREAD(CbId%,ADDR(Pos&),4)
IOREAD(CbId%,ADDR(cbLen&),4)
cbLen&=MIN(cbLen&,Bytes&)
IOREAD(CbId%,_Buf&,cbLen&)
IOCLOSE(CbId%)
return cbLen&
endp
// -------------------------------------------------------
// Command history
// -------------------------------------------------------
proc read_history:
local fid%
local line%
local ioret%
local address&
ioret% = IOOPEN(fid%,HistoryFile$,KIoOpenModeOpen% OR KIoOpenFormatText%)
if ioret%=0
line%=1
do
address&=addr(history$(line%))
ioret% = IOREAD(fid%,address&+1,KMaxStringLen%)
if ioret%>0
pokeb address&,ioret%
// print line%,"==>",history$(line%) // d!!!
line%++
endif
// print "ioret%=",ioret% : get // d!!!
until line%>KMaxHistory% OR ioret%<0
MaxLastHistory%=line%-1
LastHistory%=line%-1
IOCLOSE(fid%)
// get // d!!!
endif
endp
proc write_history:
local fid%
local line%
local ioret%
local address&
line%=1
ioret% = IOOPEN(fid%,HistoryFile$,KIoOpenModeReplace% OR KIoOpenFormatText%)
if ioret%=0
do
if len(history$(line%))
address&=addr(history$(line%))
ioret% = IOWRITE(fid%,address&+1,peekb(address&))
endif
// print line%,"==>",history$(line%) // d!!!
line%++
until line%>MaxLastHistory% OR ioret%<0
IOCLOSE(fid%)
endif
// get // d!!!
endp
proc bye:
#ifdef _ASM
MCUnloadExt&:(mc_handle&) // remove the machine code extension
FREEALLOC mc_workspace& // release the allocated memory
#endif
write_history:
stop
endp