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+.

Etiquetas:

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