rem *** forth32 kernel for opl32 *** )
rem this file is distributed under the terms of the GNU public license
rem author: l.schmidt )

rem this is an opl program. load into program editor, run.
rem on forth prompt:    from <extensions-file>  (the accompanied ascii file)
rem                     save <image-file>   , which can be quickly loaded again with
rem                     load <image-file>


rem  customization notes: search for *****

rem last modifications:
rem 23dec1999ls: interpret-only clarified message
rem 22dec1999ls: dropped backquotes word (ascii 148)


rem search-for-adding-a-new-primitive
rem search-for-adding-a_new-hilevel-word



app PsiForth,&10007777
caption "Forth32",1
enda


include "Const.oph"
include "System.oxh"

const KVersion%		=	0
const KRevision%	=	23

const KMemsize%		=	12000			rem cells program + stack space
const KCell&		=	 4
const K2Cells&		=	 8
const K3Cells&		=	12

const KMaxHeaders%	=	500

const KThreads%		=	128			rem must be power of 2
const KThreadMask%	=	127			rem threads - 1
const KThreadMem%	=	1128			rem 2*maxheaders + threads

const KMaxHeaderSize%	=	16			rem max chars/header

const KStackSize&	=	512			rem bytes
const KPadSize&		=	128			rem bytes between here and pad

const KFonts%		=	 8
const KImmediate%	=	64

const KTrue&		=	-1
const KFalse&		=	 0
const KBl&		=	32
const KEsc&		=	27
const KCr&		=	13


PROC Forth:
rem ------------------------ saved -----------------------------


	global uid1&
	global uid2&
	global uid3&
	global last&
	global dp&,tp%
	global cfa&(KMaxHeaders%)			rem name>cfa. max headers
	global thread%(KThreadMem%)
	global prec%(KMaxHeaders%)			rem precedence bit, hide/reveal flags
	global name$(KMaxHeaders%,KMaxHeaderSize%)
	global xbase&,xstate&,xloading&,xuser&,xvolume&
	global xautoexec&
	global font%,fontattr%
	global sourcepath$(128)

rem  must be last 
	global mem&(KMemsize%)				rem program- and data storage, stacks


rem ------------------------ not saved ---------------------------
	global startwatch&,stopwatch&
	global sp&,wp&,ip&,rp&,i&,tos&,temp&,s0&,r0&
	global thinfont&(KFonts%)
	global boldfont&(KFonts%)
	global thinattr%(KFonts%)
	global boldattr%(KFonts%)	
	global tib$(KMaxStringLen%)			rem input buffer
	global history$(1,KMaxStringLen%)		rem copies of input line
	global pad$(KMaxStringLen%)			rem scratch pad		
	global word$(KMaxStringLen%)	
	global screeninfo%(10)
	global xdocol&,xexit&,xlit&,xlitstr&
	global xbranch&,xdovar&,xdoconst&
	global xprompt&,xquery&,xinterpret&
	global interpreturn&,xthrow0&,xbattstat&
	global xcold&,xabort&,xquit&
	global indicator$(KBusyMaxText%)		rem busy/battery indicator
	global filebuffer$(255)

	r0&		=	aligned&:(addr(mem&(KMemsize%-1)),KCell&)
	s0&		=	r0&-KStackSize&*KCell&
	sp&		=	s0&
	rp&		=	r0&
	dp&		=	aligned&:(addr(mem&(1)),KCell&)
	tp%		=	Kthreads%+1
	last&		=	0
	font%		=	3
	fontattr%	=	1
	xbase&		=	10
	xstate&		=	KFalse&
	xvolume&	=	3
	xautoexec&	=	0
	xbattstat&	=	KTrue&
	sourcepath$	=	"d:\system\apps\forth32\"
rem ***** path of sources directory .  prepended to  load <filename>
rem ***** images (save, load) are written to this folder too


rem the intention was to associate forth source with interpreter, haven't got that running yet
	uid1&		=	&10007777
	uid2&		=	&10007777
	uid3&		=	&10007777
	
	thinfont&(1)	=	KFontCourierNormal8&	: thinattr%(1)	= 0
	thinfont&(2)	=	KFontCourierNormal11&	: thinattr%(2)	= 0
	thinfont&(3)	=	KFontCourierNormal13&	: thinattr%(3)	= 0
	thinfont&(4)	=	KFontCourierNormal15&	: thinattr%(4)	= 0
	thinfont&(5)	=	KFontCourierNormal18&	: thinattr%(5)	= 0
	thinfont&(6)	=	KFontCourierNormal22&	: thinattr%(6)	= 0
	thinfont&(7)	=	KFontCourierNormal27&	: thinattr%(7)	= 0
	thinfont&(8)	=	KFontCourierNormal32&	: thinattr%(8)	= 0

	boldfont&(1)	=	KFontCourierBold8&	: boldattr%(1)	= 0
	boldfont&(2)	=	KFontCourierBold11&	: boldattr%(2)	= 0
	boldfont&(3)	=	KFontCourierBold13&	: boldattr%(3)	= 0
	boldfont&(4)	=	KFontCourierNormal15&	: boldattr%(4)	= 1
	boldfont&(5)	=	KFontCourierNormal18&	: boldattr%(5)	= 1
	boldfont&(6)	=	KFontCourierNormal22&	: boldattr%(6)	= 1
	boldfont&(7)	=	KFontCourierNormal27&	: boldattr%(7)	= 1
	boldfont&(8)	=	KFontCourierNormal32&	: boldattr%(8)	= 1


	build_primitives:
	build_constants:
	build_hilevel:
	coldstart:
ENDP





PROC build_primitives:

	xdocol& 	=	handler:("docol",0)
	xdovar&		=	handler:("dovar",0)
	xdoconst&	=	handler:("doconst",0)
				handler:("dodoes",0)
				handler:("dodefer",0)
				handler:("douser",0)
				handler:("doarray",0)
				handler:("dotable",0)
				handler:("docode",0)


				primitive:("cold",0)
	xexit&		=	cfa&(primitive:("exit",0))
	xlit&		=	cfa&(primitive:("lit",0))
	xlitstr&	=	cfa&(primitive:("lit$",0))
				primitive:("nop",0)
				primitive:("dup",0)
				primitive:("drop",0)
				primitive:("swap",0)
				primitive:("over",0)
				primitive:("nip",0)
				primitive:("tuck",0)
				primitive:("?dup",0)
		 		primitive:("pick",0)
				primitive:("r@",0)
	xbranch&	=	cfa&(primitive:("branch",0))
				primitive:("0branch",0)
		 		primitive:(">r",0)
				primitive:("r>",0)
				primitive:("0=",0)
				primitive:("0<>",0)
				primitive:("immediate",0)
				primitive:("immediate?",0)
		 		primitive:("execute",0)
				primitive:("=",0)
				primitive:("not",0)
				primitive:("latest",0)
				primitive:("compiling",0)
				primitive:("[",KImmediate%)
				primitive:("]",0)
				primitive:("@",0)
				primitive:("!",0)
				primitive:("key",0)
				primitive:("emit",0)
				primitive:(".",0)
				primitive:("cr",0)
				primitive:("type",0)
	xquery&		=	cfa&(primitive:("query",0))
				primitive:("word",0)
				primitive:("here",0)
				primitive:("find",0)
				primitive:("name>",0)
				primitive:("name",0)
				primitive:("(create)",0)
				primitive:("allot",0)
				primitive:("error",0)
				primitive:("bye",0)
				primitive:("cls",0)
				primitive:("from",0)
				primitive:("number?",0)
				primitive:("number",0)
	xabort&		=	cfa&(primitive:("abort",0))
				primitive:("+",0)
				primitive:("-",0)
				primitive:("depth",0)
				primitive:("*/",0)
				primitive:("and",0)
				primitive:("or",0)
				primitive:("xor",0)
				primitive:("<",0)
				primitive:("rot",0)
				primitive:("-rot",0)
				primitive:("cmove",0)
				primitive:("fill",0)
				primitive:("at",0)
				primitive:("emits",0)
				primitive:("2drop",0)
				primitive:("0<",0)
				primitive:("1-",0)
				primitive:("1+",0)
				primitive:("byte-",0)
				primitive:("byte+",0)
				primitive:("cell-",0)
				primitive:("cell+",0)
				primitive:("2*",0)
				primitive:("2/",0)
				primitive:("2dup",0)
				primitive:("exchange",0)
				primitive:("c@",0)
				primitive:("c!",0)
				primitive:("c,",0)
				primitive:("pad",0)
				primitive:(">body",0)
				primitive:("$,",0)
				primitive:("move$",0)
				primitive:("min",0)
				primitive:("max",0)
				primitive:(".name",0)
				primitive:("(do)",0)
				primitive:("(loop)",0)
				primitive:("i",0)
				primitive:("j",0)
				primitive:("k",0)
				primitive:("leave",0)
				primitive:("(+loop)",0)	
				primitive:("call",0)
				primitive:("thread",0)
				primitive:("down",0)
	interpreturn&	=	cfa&(primitive:("",0))
	xinterpret&	=	cfa&(primitive:("interpret",0))
				primitive:("debug",0)
				primitive:(",",0)
				primitive:("create",0)
				primitive:(":",Kimmediate%)
				primitive:(";",KImmediate%)
	xprompt&	=	cfa&(primitive:("prompt",0))
				primitive:("count",0)
				primitive:("skim",0)
				primitive:("space",0)
				primitive:("spaces",0)
				primitive:("gat",0)
				primitive:("gline",0)
				primitive:(chr$(34),KImmediate%)
				primitive:("compile",0)	
				primitive:("home",0)
				primitive:("font",0)
				primitive:("gbox",0)
				primitive:("gcircle",0)
				primitive:("gfilledcircle",0)
				primitive:("gcolor",0)
				primitive:("gellipse",0)
				primitive:("gfilledellipse",0)
				primitive:("gfill",0)
				primitive:("gmode",0)
				primitive:("gmove",0)
				primitive:("gxy",0)
				primitive:("<#",0)
				primitive:("#",0)
				primitive:("#s",0)
				primitive:("#>",0)
				primitive:("hold",0)
				primitive:("sign",0)
				primitive:("",0)
				primitive:("key?",0)
				primitive:("cells",0)
				primitive:("bytes",KImmediate%)
				primitive:("*",0)
				primitive:("/",0)
				primitive:("<>",0)
				primitive:(">",0)
				primitive:("?error",0)
				primitive:("tasks",0)
				primitive:("lookup",0)
				primitive:("mod",0)
				primitive:("/mod",0)
				primitive:("colormode",0)
				primitive:("accept",0)
				primitive:("catch",0)
				primitive:("throw",0)
				primitive:("beep",0)
				primitive:(">indicator",0)
				primitive:("abs",0)
				primitive:("days",0)
				primitive:("day",0)
				primitive:("month",0)
				primitive:("year",0)
				primitive:("hour",0)
				primitive:("minute",0)
				primitive:("second",0)
				primitive:("screen",0)
				primitive:("screeninfo",0)
				primitive:("gcls",0)
				primitive:("setcontrast",0)
				primitive:("week",0)
	xthrow0&	=	cfa&(primitive:("0throw",0))	: comma:(xthrow0&)
				primitive:("pluck",0)
				primitive:("rp@",0)
				primitive:("sp@",0)
				primitive:("r0",0)
				primitive:("s0",0)
				primitive:("?comp",0)
				primitive:("?exec",0)
				primitive:("negate",0)
				primitive:("bold",0)
				primitive:("thin",0)
				primitive:(".r",0)
				primitive:("+!",0)
				primitive:("0>",0)
				primitive:("free",0)
				primitive:("body>",0)
				primitive:("indicator",0)
				primitive:("play",0)
				primitive:("2over",0)
				primitive:("2swap",0)
				primitive:("dump",0)
				primitive:("save",0)
				primitive:("load",0)
				primitive:("open-file",0)
				primitive:("close-file",0)
				primitive:("read-file",0)
				primitive:("write-file",0)
				primitive:("seek-file",0)
				primitive:("parse-file",0)
				primitive:("sourcepath",0)
				primitive:(">sourcepath",0)
				primitive:("delete",0)
				primitive:("directory",0)
				primitive:("alloc",0)
				primitive:("realloc",0)					
				primitive:("freealloc",0)						
				primitive:("dinit",0)
				primitive:("dbutton",0)
				primitive:("dbuttons",0)
				primitive:("dcheckbox",0)
				primitive:("dialog",0)
				primitive:("dposition",0)
				primitive:("dtext",0)
				primitive:("dchoice",0)
				primitive:("getevent",0)
				primitive:("event",0)
							
	
rem search-for-adding-a-new-primitive
ENDP


rem the virtual machine, primitive dispatch and primitives
PROC coldstart:
	local keywaiting%,temp%
	local nbuttons%
	local dbutton%(5),dbutton$(5,128)
	local dialogresult%(32)
	local dialogresults%
	
	local eventstat%,eventbuf&(16)

	onerr oplerror

coldstart::
	gcls
	setfont:(font%,fontattr%)
	hello:
	ip& = xcold&
	wp& = xautoexec&
	if wp&
	   goto xvector
	endif


xnop::
xbytes::
xnext::
	wp& = peekl(ip&)
	ip& = ip&+KCell&
xvector::
	VECTOR peekl(wp&)
		xdocol
		xdovar
		xdoconst
		xdodoes
		xdodefer
		xdouser
		xdoarray
		xdotable
		xdocode


		coldstart
		xexit
		xlit
		xlitstr
		xnext
		xdup
		xdrop
		xswap
		xover
		xnip
		xtuck
		xqdup
		xpick
		xrfetch
		xbranch
		x0branch
		xtor
		xrfrom
		x0equal
		x0notequal	
		ximm
		ximmq
		xexecute
		xequal
		xnot
		xlatest
		xcompq
		xlsqbr
		xrsqbr
		xfetch
		xstore
		xkey
		xemit
		xdot
		xcr
		xtype
		xquery
		xword
		xhere
		xfind
		xnamefrom
		xname
		xbrcreate
		xallot
		xerror
		xbye
		xcls
		xfrom
		xnumberq
		xnumber
		xabort
		xplus
		xminus
		xdepth
		xstsl
		x_and
		x_or
		x_xor
		xless	
		xrot
		xminrot
		xcmove
		xfill
		xat
		xemit
		x2drop
		xless0
		xonem
		xonep
		xbytem
		xbytep
		xcellm
		xcellp
		x2mul
		x2div
		x2dup
		xexchange
		xcfetch
		xcstore
		xccomma
		xpad
		xtobody
		xstrcomma
		xmovestr
		xmin
		xmax
		xdotname
		xdo
		xloop
		xi
		xj
		xk
		xleave
		xplusloop
		xcall
		xthread
		xdown	
		interpreturn
		xinterpret
		xdebug
		xcomma
		xcreate
		xcolon
		xsemicolon
		xprompt
		xcount
		xskim
		xspace
		xspaces
		xgat
		xgline
		xquote
		xcompile
		xhome
		xfont
		xgbox
		xgcircle
		xgfilledcircle
		xgcolor
		xgellipse
		xgfilledellipse
		xgfill
		xgmode
		xgmove
		xgxy
		xfrhash
		x1hash
		xhashs
		xhashto
		xhold
		xsign
		xnext
		xqkey
		xcells
		xbytes
		xmul
		xdiv
		xnotequal
		xmore
		xqerror
		xother
		xlookup
		xmod
		xslmod
		xcolormode
		xaccept
		xcatch
		xthrow
		xbeep
		xbusy
		xabs
		xdays
		xday
		xmonth
		xyear
		xhour
		xminute
		xsecond
		xscreen
		xscreeninfo
		xgcls
		xsetcontrast
		xweek
		xthrow0
		xpluck
		xrpfetch
		xspfetch
		xr0
		xs0
		xqcomp
		xqexec
		xnegate
		xbold
		xthin
		xdotr
		xplusstore
		xgreater0
		xfree
		xbodyfrom
		xindicator
		xplay
		x2over
		x2swap
		xdump
		xsave
		xload
		xioopen
		xioclose
		xioread
		xiowrite
		xioseek
		xioparse
		xsourcepath
		xtosourcepath
		xdelete
		xdirectory
		xalloc
		xrealloc
		xfreealloc
		xdinit
		xdbutton
		xdbuttons
		xdcheckbox
		xdialog
		xdposition
		xdtext
		xdchoice
		xgetevent
		xevent
		
		

rem search-for-adding-a-new-primitive
	ENDV

	debug:
	report_error:("execution attempt of undefined primitive "+num$(wp&,5))
	goto xabort



xswap::
	temp& = peekl(sp&)
	pokel sp&,tos&
	tos& = temp&
	goto xnext



xtor::
	rp& = rp&-KCell&
	pokel rp&,tos&
xdrop::
	tos& = peekl(sp&)
xnip::
	sp& = sp&+KCell&
	goto xnext



xrfrom::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = peekl(rp&)
	rp& = rp&+KCell&
	goto xnext



xi::
xrfetch::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = peekl(rp&)
	goto xnext



xqdup::
	if (tos& = 0)
	   goto xnext
	endif
xdup::
	sp& = sp&-KCell&
	pokel sp&,tos&
	goto xnext



xover::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = peekl(sp&+KCell&)
	goto xnext



xrot::
	temp& = tos&
	tos& = peekl(sp&+KCell&)
	pokel sp&+KCell&,peekl(sp&)
	pokel sp&,temp&
	goto xnext


xminrot::
	temp& = tos&
	tos& = peekl(sp&)
	pokel sp&,peekl(sp&+KCell&)
	pokel sp&+KCell&,temp&
	goto xnext
	

xtuck::
	sp& = sp&-KCell&
	pokel sp&,peekl(sp&+KCell&)
	pokel sp&+KCell&,tos&
	goto xnext


xpluck::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = peekl(sp&+K2Cells&)
	goto xnext
	

xpick::
	tos& = peekl(sp&+tos&*KCell&)
	goto xnext



xlit::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = peekl(ip&)
	ip& = ip&+KCell&
	goto xnext



xlitstr::
	sp& = sp&-K2Cells&
	pokel sp&+KCell&,tos&
	pokel sp&,ip&+1
	tos& = peekb(ip&)
	ip& = ((ip&+tos&) or 3) +1
	goto xnext



xdovar::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = wp& + KCell&
	goto xnext



xdoconst::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = peekl(wp&+KCell&)
	goto xnext


xdotable::
	tos& = peekl(wp& + (tos&+1) * KCell&)
	goto xnext
	
xdoarray::
	tos& = wp& + (tos&+1) * KCell&
	goto xnext


xdodoes::
	sp& = sp& - KCell&
	pokel sp&,tos&
	tos& = wp& + KCell&
	rp& = rp&-KCell&
	pokel rp&,ip&
	ip& = peekl(wp& - KCell&)
	goto xnext

	

xdodefer::
	wp& = peekl(wp& + KCell&)
	goto xvector


xdouser::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = peekl(wp& + KCell&) + xuser&
	goto xnext



xdocol::
	rp& = rp&-KCell&
	pokel rp&,ip&
	ip& = wp& + KCell&
	goto xnext



xexit::
	ip& = peekl(rp&)
	rp& = rp&+KCell&
	goto xnext

	


xj::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = peekl(rp&+K3Cells&)
	goto xnext



xk::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = peekl(rp&+6*KCell&)
	goto xnext


	
xplus::
	tos& = tos&+peekl(sp&)
	sp& = sp&+KCell&
	goto xnext


xminus::
	tos& = peekl(sp&)-tos&
	sp& = sp&+KCell&
	goto xnext


xbodyfrom::
xcellm::
	tos& = tos&-KCell&
	goto xnext


xbytem::
xonem::
	tos& = tos&-1
	goto xnext
	

xtobody::
xcellp::
	tos& = tos&+KCell&
	goto xnext


xbytep::
xonep::
	tos& = tos&+1
	goto xnext


x2mul::
	tos& = tos&+tos&
	goto xnext
	

x2div::
	tos& = tos&/2
	goto xnext


xcells::
	tos& = tos&*KCell&
	goto xnext


xstsl::
	tos& = peekl(sp&+KCell&)*peekl(sp&)/tos&
	sp& = sp&+K2Cells&
	goto xnext
	
	
xmul::
	tos& = peekl(sp&)*tos&
	sp& = sp&+KCell&
	goto xnext


	
xdiv::
	tos& = peekl(sp&)/tos&
	sp& = sp&+KCell&
	goto xnext
	


xslmod::
	temp& = peekl(sp&)
	pokel sp&,mod&:(temp&,tos&)
	tos& = temp&/tos&
	goto xnext


	
xmod::
	tos& = mod&:(peekl(sp&),tos&)
	sp& = sp&+KCell&
	goto xnext



xmin::
	tos& = min(tos&,peekl(sp&))
	sp& = sp& + KCell&
	goto xnext


xmax::
	tos& = max(tos&,peekl(sp&))
	sp& = sp&+KCell&
	goto xnext


xabs::
	tos& = iabs(tos&)
	goto xnext



x_and::
	tos& = tos& and peekl(sp&)
	sp& = sp&+KCell&
	goto xnext


x_or::
	tos& = tos& or peekl(sp&)
	sp& = sp&+KCell&
	goto xnext


x_xor::
	tos& = xor&:(tos&,peekl(sp&))
	sp& = sp&+KCell&
	goto xnext



xcompq::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = xstate&
	goto xnext



xcfetch::
	tos& = peekb(tos&)
	goto xnext



xfetch::
	tos& = peekl(tos&)
	goto xnext



xcstore::
	pokeb tos&,peekl(sp&)
	tos& = peekl(sp&+KCell&)
	sp& = sp&+K2Cells&
	goto xnext


xstore::
	pokel tos&,peekl(sp&)
x2drop::
	tos& = peekl(sp&+KCell&)
	sp& = sp&+K2Cells&
	goto xnext



xplusstore::
	pokel tos&,peekl(sp&)+peekl(tos&)
	tos& = peekl(sp&+KCell&)
	sp& = sp&+K2Cells&
	goto xnext




xcount::
	sp& = sp&-KCell&
	pokel sp&,tos&+1
	tos& = peekb(tos&)
	goto xnext


xskim::
	sp& = sp&-KCell&
	pokel sp&,tos&+KCell&
	tos& = peekl(tos&)
	goto xnext



xexchange::
	temp& = peekl(tos&)
	pokel tos&,peekl(sp&)
	tos& = temp&
	sp& = sp&+KCell&
	goto xnext

	

x2dup::
	sp& = sp&-K2Cells&
	pokel sp&,peekl(sp&+K2Cells&)
	pokel sp&+KCell&,tos&
	goto xnext


	
	
xstrcomma::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = dp&
	dp& = ((dp&+peekl(sp&)) or 3) + 1
xmovestr::
	temp& = peekl(sp&)
	pokeb tos&,temp&
	pokel sp&,tos&+1
	tos& = temp&	
xcmove::
	i& = peekl(sp&)
	temp& = peekl(sp&+KCell&)
	if i&<temp&
	   while tos&
	      pokeb i&,peekb(temp&)
	      i& = i&+1
	      temp& = temp&+1
	      tos& = tos&-1
	   endwh
	else
	   temp& = temp&+tos&
	   i& = i&+tos&
	   while tos&
	      i& = i&-1
	      temp& = temp&-1
	      pokeb i&,peekb(temp&)
	      tos& = tos&-1
	   endwh
	endif
	tos& = peekl(sp& + K2Cells&)
	sp& = sp& + K3Cells&
	goto xnext

			

xfill::
	i& = peekl(sp&)
	temp& = peekl(sp& + KCell&)
	while i&
	   pokeb temp&,tos&
	   temp& = temp& + 1
	   i& = i& - 1
	endwh
	tos& = peekl(sp& + K2Cells&)
	sp& = sp& + K3Cells&
	goto xnext
	


xlatest::
	sp& = sp& - KCell&
	pokel sp&,tos&
	tos& = last&
	goto xnext


ximm::
	prec%(last&) = prec%(last&) or KImmediate%
	goto xnext


ximmq::
	tos& = (prec%(tos&) and KImmediate%) <> 0
	goto xnext
	

xequal::
	tos& = (tos&=peekl(sp&))
	sp& = sp&+KCell&
	goto xnext


xnotequal::
	tos& = (tos&<>peekl(sp&))
	sp& = sp&+KCell&
	goto xnext
	

xnot::
	tos& = not tos&
	goto xnext

		
x0equal::
	tos& = (tos&=0)
	goto xnext
	

x0notequal::
	tos& = (tos&<>0)
	goto xnext


xless::
	tos& = (peekl(sp&) < tos&)
	sp& = sp& + KCell&
	goto xnext


xmore::
	tos& = (peekl(sp&) > tos&)
	sp& = sp&+KCell&
	goto xnext


xless0::
	tos& = (tos& < 0)	
	goto xnext


xgreater0::
	tos& = (tos& > 0)	
	goto xnext
	

	
	
x0branch::
	temp& = tos&
	tos& = peekl(sp&)
	sp& = sp&+KCell&
	if temp&
	   ip& = ip&+KCell&
	   goto xnext
	endif
xbranch::
	ip& = ip&+peekl(ip&)+KCell&
	goto xnext


xdo::
	temp& = peekl(ip&)
	ip& = ip&+KCell&
	rp& = rp&-K3Cells&
	pokel rp&+K2Cells&,temp&+ip&
	pokel rp&+KCell&,peekl(sp&)
	pokel rp&,tos&
	tos& = peekl(sp&+KCell&)
	sp& = sp& + K2Cells&
	goto xnext
	
	
xloop::
	pokel rp&,peekl(rp&)+1
	if peekl(rp&) < peekl(rp&+KCell&)
	   ip& = ip&+peekl(ip&)+KCell&
	   goto xnext
	endif
	rp& = rp&+K3Cells&
	ip& = ip&+KCell&
	goto xnext


	
xplusloop::
	pokel rp&,peekl(rp&)+tos&
	tos& = peekl(sp&)
	sp& = sp&+KCell&	
	if peekl(rp&) < peekl(rp&+KCell&)
	   ip& = ip&+peekl(ip&)+KCell&
	   goto xnext
	endif
	rp& = rp&+K3Cells&
	ip& = ip&+KCell&
	goto xnext



xleave::
	ip& = peekl(rp&+K2Cells&)
	rp& = rp&+K3Cells&
	goto xnext



xccomma::
	pokeb dp&,tos&
	dp& = dp&+1
	tos& = peekl(sp&)
	sp& = sp&+KCell&
	goto xnext


xcomma::
	pokel dp&,tos&
	dp& = dp&+KCell&
	tos& = peekl(sp&)
	sp& = sp&+KCell&
	goto xnext



xqkey::
	sp& = sp&-KCell&
	pokel sp&,tos&
	if (keywaiting% = 0)
	   keywaiting% = key
	endif
	tos& = (keywaiting%<>0)
	goto xnext


xkey::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = keywaiting%
	if tos&
	   keywaiting% = 0
	else
	   tos& = get
	endif
	goto xnext



xemit::
	print chr$(tos&);
	tos& = peekl(sp&)
	sp& = sp&+KCell&
	goto xnext



xemits::
	print rept$(chr$(peekl(sp&)),tos&);
	tos& = peekl(sp&+KCell&)
	sp& = sp&+K2Cells&
	goto xnext


xat::
	at peekl(sp&),tos&
	tos& = peekl(sp&+KCell&)
	sp& = sp&+K2Cells&
	goto xnext


xfrhash::
	temp& = dp&+KPadsize&-KCell&
	pokel temp&,temp&
	sp& = sp&-KCell&
	pokel sp&,tos&
	goto xnext


x1hash::
	digit:
	goto xnext


xhashs::
	while tos&
	   digit:
	endwh
	goto xnext

xhashto::
	temp& = dp&+KPadsize&-KCell&
	tos& = temp& - peekl(temp&)
	pokel sp&,peekl(temp&)
	goto xnext

		
xhold::
	temp& = dp& + KPadsize& - KCell&
	hold:(tos&)
	tos& = peekl(sp&)
	sp& = sp& + KCell&
	goto xnext


xsign::
	if (peekl(sp&) < 0)
	   hold:(%-)
	endif
	goto xnext


xdot::
	print tos&,
	tos& = peekl(sp&)
	sp& = sp& + KCell&
	goto xnext



xdotr::
	print num$(peekl(sp&),(not tos&)+1),
	tos& = peekl(sp&+KCell&)
	sp& = sp& + K2Cells&
	goto xnext

	
xcr::
	print
	goto xnext

	
xtype::
	print packed$:;
	goto xnext


xspace::
	print " ";
	goto xnext


xspaces::
	print rept$(" ",tos&);
	tos& = peekl(sp&)
	sp& = sp&+KCell&
	goto xnext


xgcls::
	gcls
	goto xnext


xcls::
	cls
xhome::
	at			1,1
	goto xnext	
	


	
xquery::
	tib$ = ""
	if keywaiting%
	   tib$ = chr$(keywaiting%)
	   keywaiting% = 0
	endif
	if xloading&
		
rem ---- loading from file ----
	   pad$ = loadline$:(xloading&,KCr&)
	   while len(pad$)				rem convert control chars to spaces
	      i& = asc(left$(pad$,1))
	      pad$ = mid$(pad$,2,255)
	      if (i& < KBl&)
	         i& = kBl&
	      endif
	      tib$ = tib$ + chr$(i&)
	   endwh
	else
rem ---- buffered keyboard input ----
	   tib$ = lineedit$:(tib$,80)
	endif
	history$(1) = tib$
	goto xnext


	

xaccept::
	pad$ = lineedit$:("",tos&)
	move:(pad$,peekl(sp&))
	tos& = len(pad$)
	sp& = sp&+KCell&	
	goto xnext


		
xword::
	pad$		=	word$:(tos&)
	tos&		=	peekl(sp&)
	sp&		=	sp&+KCell&
	string:			(pad$,dp&)
	goto xnext


xdp::
	sp& = sp&-KCell&
	pokel sp&,tos&	
	tos& = addr(dp&)
	goto xnext

	
xhere::
	sp& = sp&-KCell&
	pokel sp&,tos&	
	tos& = dp&
	goto xnext


xpad::
	sp& = sp&-KCell&
	pokel sp&,tos&	
	tos& = dp&+KPadSize&
	goto xnext
	
	
xallot::
	dp& = dp&+tos&
	tos& = peekl(sp&)
	sp& = sp&+KCell&
	goto xnext


xcreate::
	pad$ = word$:(Kbl&)
	goto padcreate
		

rem ( addr u -- )
xbrcreate::
	pad$ = packed$:
padcreate::
	header&:(pad$,0)
	comma:(xdovar&)
	goto xnext


xcolon::
	if xstate&
	   goto interpret_only
	endif
	pad$ = word$:(Kbl&)
	header&:(pad$,0)
	comma:(xdocol&)
xrsqbr::
	xstate& = KTrue&
	goto xnext	


xsemicolon::
	comma:(xexit&)
xlsqbr::
	xstate& = KFalse&
	goto xnext




xfind::
	pad$ = packed$:
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = find:(pad$)				rem name field or 0
	goto xnext
		
	
xnamefrom::
	tos& = cfa&(tos&)
	goto xnext


	
	
rem  header to addr,cnt
xname::
	sp& = sp& - KCell&
	pokel sp&,addr(name$(tos&))+1
	tos& = len(name$(tos&))
	goto xnext


	

xdotname::
	print name$(tos&),
	tos& = peekl(sp&)
	sp& = sp&+KCell&
	goto xnext

	

xdepth::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = (s0&-sp&-KCell&)/KCell&
	goto xnext


	
oplerror::
	report_error:( err$(err) + " (opl error #" + num$(iabs(err),4) + ")" )
	goto xabort

interpret_only::
	report_error:( "do not use during compilation" )
	goto xabort

compile_only::
	report_error:( "use only during compilation" )
	goto xabort

	

xqerror::
	if ( peekl(sp&+KCell&) = 0 )
	   tos& = peekl(sp& + K2Cells&)
	   sp& = sp& + K3Cells&
	   goto xnext
	endif
xerror::
	report_error:( packed$: )
xabort::
	if xloading&
	   close_file:(xloading&)
	   indicate:("")
	   xloading& = 0
	endif
	sp& = s0&
	rp& = r0&
	xstate& = 0
	tib$ = ""
	wp& = xquit&
	goto xvector


	
xcatch::
	rp& = rp& - K2Cells&
	pokel rp&,ip&
	pokel rp&+KCell&,sp&
	ip& = xthrow0&+KCell&
xexecute::
	wp& = tos&
	tos& = peekl(sp&)
	sp& = sp&+KCell&
	goto xvector



xthrow::
	rp& = rp&+KCell&
	goto xthrow1
xthrow0::
	tos& = 0
xthrow1::
	ip& = peekl(rp&)
	sp& = peekl(rp&+KCell&)
	rp& = rp&+K2Cells&
	goto xnext

	

xnumberq::
	pad$ = packed$:
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = numberq:(pad$)
	goto xnext


xnumber::
	pad$ = packed$:
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = val(pad$)
	goto xnext


	

xinterpret::
	do
	   word$ = word$:(Kbl&)
	   if len(word$)
	      temp& = find:(word$)
	      if temp&
	         if ( xstate& and ((prec%(temp&) and KImmediate%)=0) )
	            pokel dp&,cfa&(temp&)
	            dp& = dp& + KCell&
	         else
	            wp& = cfa&(temp&)
	            rp& = rp&-K2Cells&
	            pokel rp&+KCell&,interpreturn&
	            pokel rp&,ip&
	            ip& = rp&+KCell&
	            goto xvector			rem execution of next must return
interpreturn::
	            ip& = peekl(rp&)
	            rp& = rp&+K2Cells&					
	         endif

	         if ( s0&-sp& < 0 )
	            report_error:( "stack underflow" )
	            goto xabort
	         endif
	      elseif numberq:(word$)			rem  not found
	         if xstate&
	            pokel dp&,xlit&
	            pokel dp&+KCell&,val(word$)
	            dp& = dp& + K2Cells&
	         else
	            sp& = sp&-KCell&
	            pokelsp&,tos&
	            tos& = val(word$)
	         endif
	      else
	         report_error:( "not found" )
	         goto xabort
	      endif
	   endif
	until ( len(tib$)=0 )
	goto xnext


	
xdebug::
	debug:
	goto xnext


	
xprompt::
	if ( (xstate& or xloading&) = 0 )
	   print " ok";rept$(".",(s0&-sp&)/KCell&),
	   temp& = MAINBATTERYSTATUS&:
	   if ( xbattstat& <> temp& )
	      xbattstat& = temp&
	      pad$ = ""
	      if ( temp& < 2 )
	         pad$ = "replace battery"
	      elseif ( temp& < 3 )
	         pad$ = "battery low"
	      endif
	      indicate:(pad$)
	   endif
	endif
	goto xnext



xgat::
	gat peekl(sp&),tos&
	tos& = peekl(sp&+KCell&)
	sp& = sp&+K2Cells&
	goto xnext


xgline::
	glineto peekl(sp&),tos&
	tos& = peekl(sp&+KCell&)
	sp& = sp&+K2Cells&
	goto xnext



xquote::
	pad$ = word$:(%")
	if xstate&
	   pokel dp&,xlitstr&
	   dp& = dp&+KCell&
	   string:(pad$,dp&)
	   goto xstrcomma
	endif
	string:(pad$,dp&+KPadSize&)
	goto xnext


xcompile::
	pokel dp&,peekl(ip&)
	ip& = ip&+KCell&
	dp& = dp&+KCell&
	goto xnext


xfont::
	font% = peekl(sp&)
	fontattr% = tos&
	setfont:(font%,fontattr%)
	tos& = peekl(sp&+KCell&)
	sp& = sp&+K2Cells&
	goto xnext


xbold::
	setfont:(font%,fontattr% or 1)
	goto xnext
	
xthin::
	setfont:(font%,0)
	goto xnext

		
xgbox::
	gbox peekl(sp&),tos&
	tos& = peekl(sp&+KCell&)
	sp& = sp&+K2Cells&
	goto xnext


xgcircle::
	gcircle tos&
	tos& = peekl(sp&)
	sp& = sp&+KCell&
	goto xnext
		

xgfilledcircle::
	gcircle peekl(sp&),tos&
	tos& = peekl(sp&+KCell&)
	sp& = sp&+K2Cells&
	goto xnext


xgcolor::
	gcolor peekl(sp&+KCell&),peekl(sp&),tos&
	tos& = peekl(sp& + K2Cells&)
	sp& = sp& + K3Cells&
	goto xnext

	
xgellipse::
	gellipse peekl(sp&),tos&
	tos& = peekl(sp&+KCell&)
	sp& = sp&+K2Cells&
	goto xnext

	
xgfilledellipse::
	gellipse peekl(sp&+KCell&),peekl(sp&),tos&
	tos& = peekl(sp& + K2Cells&)
	sp& = sp& + K3Cells&
	goto xnext


xgfill::
	gfill peekl(sp&+KCell&),peekl(sp&),tos&
	tos& = peekl(sp& + K2Cells&)
	sp& = sp& + K3Cells&
	goto xnext
	

xgmode::
	ggmode tos&
	tos& = peekl(sp&)
	sp& = sp&+KCell&
	goto xnext
	

xgmove::
	gmove peekl(sp&),tos&
	tos& = peekl(sp&+KCell&)
	sp& = sp&+K2Cells&
	goto xnext

	
xgxy::
	sp& = sp&-K2Cells&
	pokel sp&+KCell&,tos&
	pokel sp&,gx
	tos& = gy
	goto xnext


xother::
	DisplayTaskList:
	goto xnext


xlookup::
	i& = peekl(tos&)
	temp& = tos&+KCell&
	tos& = 0
	while ( i& and (tos&=0) )
	   if ( peekl(temp&) = peekl(sp&) )
	      tos& = peekl(temp&+KCell&)
	   endif
	   i& = i&-1
	   temp& = temp&+K2Cells&
	endwh
	sp& = sp&+KCell&
	goto xnext


xcolormode::
	defaultwin tos&
	tos& = peekl(sp&)
	sp& = sp&+KCell&
	goto xnext


xbeep::
	beep (tos&-1)/50+1,512000/(peekl(sp&)+1)
	tos& = peekl(sp&+KCell&)
	sp& = sp&+K2Cells&
	goto xnext
	
	
xbusy::
	indicate:(packed$:)
	goto xnext


xindicator::
	sp& = sp& - K2Cells&
	pokel sp& + KCell&,tos&
	pokel sp&,addr(indicator$)+1
	tos& = len(indicator$)
	goto xnext


xdays::
	tos& = days(peekl(sp&+KCell&),peekl(sp&),tos&)
	sp& = sp&+K2Cells&
	goto xnext


xday::
	sp& = sp&-KCell&	
	pokel sp&,tos&
	tos& = day
	goto xnext

xmonth::
	sp& = sp&-KCell&	
	pokel sp&,tos&
	tos& = month
	goto xnext
	
xyear::
	sp& = sp&-KCell&	
	pokel sp&,tos&
	tos& = year
	goto xnext
	
xhour::
	sp& = sp&-KCell&	
	pokel sp&,tos&
	tos& = hour
	goto xnext
	
xminute::
	sp& = sp&-KCell&	
	pokel sp&,tos&
	tos& = minute
	goto xnext
	
xsecond::
	sp& = sp&-KCell&	
	pokel sp&,tos&
	tos& = second
	goto xnext


xscreen::
	screen peekl(sp&),tos&,peekl(sp&+K2Cells&),peekl(sp&+KCell&)
	tos& = peekl(sp&+K3Cells&)
	sp& = sp&+4*KCell&
	goto xnext


xscreeninfo::
	tos& = screeninfo%(tos&)
	goto xnext
	
	
xsetcontrast::
	SETDISPLAYCONTRAST:(tos&)s
	tos& = peekl(sp&)
	sp& = sp&+KCell&
	goto xnext
	
	
xweek::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = week(day,month,year)
	goto xnext
	
	
	
xrpfetch::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = rp&
	goto xnext
	
xspfetch::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = sp&
	goto xnext

xr0::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = r0&
	goto xnext

xs0::
	sp& = sp&-KCell&
	pokel sp&,tos&
	tos& = s0&
	goto xnext


xqcomp::
	if ( xstate&=0 )
	   goto compile_only
	endif
	goto xnext

	

	

xqexec::
	if xstate&
	   goto interpret_only
	endif
	goto xnext


xnegate::
	tos& = (not tos&) + 1
	goto xnext


xfree::
	sp& = sp& - KCell&
	pokel sp&,tos&
	tos& = (s0& - KStackSize&) - (dp& + 2*KPadSize&)
	goto xnext
	
	
xplay::
	playsound:(packed$:,xvolume&)
	goto xnext
	
	
x2over::
	sp& = sp& - K2Cells&
	pokel sp&+KCell&,tos&
	pokel sp&,peekl(sp&+K2Cells&)
	goto xnext

x2swap::
	temp& = tos&
	tos& = peekl(sp&+KCell&)
	pokel sp&+KCell&,temp&
	temp& = peekl(sp&+K2Cells&)
	pokel sp&+K2Cells&,peekl(sp&)
	pokel sp&,temp&
	goto xnext




xdump::
	print
	while ( tos& > 0 )
	   temp& = peekl(sp&)
	   i& = 8
   	   print right$("0000000"+hex$(temp&)+"  ",8),
	   while i&
	      print right$("0"+hex$(peekb(temp&)),2),
	      i& = i& - 1
	      temp& = temp& + 1
	   endwh
	   temp& = peekl(sp&)
	   i& = 8
	   while i&
	      temp% = peekb(temp&)
	      if ( (temp% < KBl&) or (temp% > 126) )
	         temp% = %.
	      endif
	      print chr$(temp%);
   	      i& = i& - 1
	      temp& = temp& + 1
	   endwh
	   print
	   tos& = tos& - 8
	   pokel sp&,peekl(sp&) + 8
	endwh
	tos& = peekl(sp&)
	sp& = sp& + KCell&
	goto xnext

	

xioopen::
	rp& = rp&-KCell&
	pokel rp&,tos&	
	tos& = peekl(sp&)
	sp& = sp&+KCell&
	pad$ = packed$:
	sp& = sp& - K2Cells&
	pokel sp&+KCell&,tos&	
	tos& = ioopen(temp%,pad$,peekl(rp&))
	rp& = rp&+KCell&
	pokel sp&,temp%
	goto xnext	



xioclose::
	tos& = ioclose(tos&)
	goto xnext


xioread::
	tos& = ioread(peekl(sp&+KCell&),peekl(sp&),tos&)
	sp& = sp& + K2Cells&
	goto xnext
	

xiowrite::
	tos& = iowrite(peekl(sp&+KCell&),peekl(sp&),tos&)
	sp& = sp& + K2Cells&
	goto xnext


xioseek::
	temp& = ioseek(peekl(sp&+KCell&),peekl(sp&),tos&)
	sp& = sp& + KCell&
	pokel sp&,tos&
	tos& = temp&
	goto xnext
	

	
rem    handle addr n delimiter -- n status
xioparse::
	temp% = tos&					rem delimiter
	i& = peekl(sp&)					rem max len
	temp& = peekl(sp& + KCell&)			rem addr
	sp& = sp& + KCell&

	while ( i& and (tos& >= 0) )
	   tos& = ioread(peekl(sp&+KCell&),temp&,1)
	   if ( tos& > 0 )
	      if ( peekb(temp&) = temp% )
	         i& = 0
	      else
	         i& = i&-1
	         temp& = temp& + 1
	      endif
	   endif
	endwh

	if ( tos& > 0 )
	   tos& = temp&-peekl(sp&)
	endif
	sp& = sp& + K2Cells&
	goto xnext

	
	
rem example:
rem		" xxx" 0 open-file
rem		" couldn't open" ?error
rem		dup pad 100 read-file
rem		dup 0< " couldn't read" ?error
rem		dup . " bytes read: " type
rem		pad swap type
rem		close-file
rem		" couldn't close" ?error



xsave::
	setdoc pad$
	pad$ = word$:(0)
	if loc(pad$,"\")=0
	 pad$ = sourcepath$ + pad$
	endif
	if ( ioopen(temp%,pad$,1) )
	   report_error:("couldn't open " + pad$)
	   goto xabort
	endif
	if ( iowrite(temp%,addr(uid1&),dp&-addr(uid1&)) )
	   report_error:("couldn't write " + pad$)
	   goto xabort
	endif
	if ( ioclose(temp%) )
	   report_error:("couldn't close " + pad$)
	   goto xabort
	endif
	goto xnext
	



xload::
	pad$ = word$:(0)
	if ( loc(pad$,"\")=0 )
	   pad$	= sourcepath$ + pad$
	endif
	if ( ioopen(temp%,pad$,0) )
	   report_error:("couldn't open " + pad$)
	   goto xabort
	endif
	if ( ioread(temp%,addr(uid1&),32767)<0 )
	   report_error:("couldn't read " + pad$)
	   goto xabort
	endif
	if ( ioclose(temp%) )
	   report_error:("couldn't close " + pad$)
	   goto xabort
	endif
	goto coldstart



xdelete::
	pad$ = packed$:
	if ( loc(pad$,"\")=0 )
	   pad$ = sourcepath$ + pad$
	endif
	delete pad$
	goto xnext



xdirectory::
	pad$ = packed$:
	if ( loc(pad$,"\")=0 )
	   pad$ = sourcepath$ + pad$
	endif
	print
	pad$ = dir$(pad$)
	while ( len(pad$) )
	   print pad$
	   pad$ = dir$("")
	endwh
	goto xnext


xdocode::
	print "would execute code at addr",wp& + KCell&
	goto xnext



xsourcepath::
	sp& = sp& - K2Cells&
	pokel sp& + KCell&,tos&
	pokel sp&,addr(sourcepath$)+1
	tos& = len(sourcepath$)
	goto xnext



xtosourcepath::
	sourcepath$ = packed$:
	goto xnext
	
	

xdinit::
	i& = tos&
	tos& = peekl(sp&)
	sp& = sp& + KCell&
	dinit packed$:,i&
	nbuttons% = 0
	dialogresults% = 0
	goto xnext


xdbutton::
	nbuttons% = nbuttons% + 1
	dbutton%(nbuttons%) = tos&
	tos& = peekl(sp&)
	sp& = sp& + KCell&
	dbutton$(nbuttons%) = packed$:
	goto xnext

	
xdbuttons::
	vector nbuttons%
	   button1
	   button2
	   button3
	   button4
	   button5
	endv
	
button1::
	dbuttons dbutton$(1),dbutton%(1)
	goto xnext

button2::
	dbuttons dbutton$(1),dbutton%(1),dbutton$(2),dbutton%(2)
	goto xnext

button3::
	dbuttons dbutton$(1),dbutton%(1),dbutton$(2),dbutton%(2),dbutton$(3),dbutton%(3)
	goto xnext

button4::
	dbuttons dbutton$(1),dbutton%(1),dbutton$(2),dbutton%(2),dbutton$(3),dbutton%(3),dbutton$(4),dbutton%(4)
	goto xnext

button5::
	dbuttons dbutton$(1),dbutton%(1),dbutton$(2),dbutton%(2),dbutton$(3),dbutton%(3),dbutton$(4),dbutton%(4),dbutton$(5),dbutton%(5)
	goto xnext


	
	
xdcheckbox::
print 1
	dialogresults% = dialogresults% + 1
print 2
	dialogresult%(dialogresults%) = tos&
	temp% = tos&
print 3
	tos& = addr(dialogresult%(dialogresults%))
print 4
	dCHECKBOX temp%,packed$:
print 5
rem	dCHECKBOX dialogresult%(dialogresults%),packed$:	
	goto xnext




xdialog::
	sp& = sp& - KCell&
	pokel sp&,tos&
	tos& = dialog
	goto xnext
	
	
xdposition::
	dposition peekl(sp&),tos&
	tos& = peekl(sp& + KCell&)
	sp& = sp& + K2Cells&
	goto xnext
	

xdtext::
	i& = tos&
	tos& = peekl(sp&)
	sp& = sp& + KCell&
	dtext packed$:,packed$:,i&
	goto xnext


		
xdchoice::
	dialogresults% = dialogresults% + 1
	dialogresult%(dialogresults%) = tos&
	tos& = addr(dialogresult%(dialogresults%))
	dchoice dialogresult%(dialogresults%),packed$:,packed$:
	goto xnext
	


xalloc::
	tos& = alloc(tos&)
	goto xnext


xrealloc::
	tos& = realloc(tos&,peekl(sp&))
	sp& = sp& + KCell&
	goto xnext
	
	
xfreealloc::
	freealloc tos&
	tos& = peekl(sp&)
	sp& = sp& + KCell&
	goto xnext

	
xgetevent::
	geteventa32 eventstat%,eventbuf&()
	goto xnext
	
xevent::
	if tos&
	   tos& = eventbuf&(tos&)
	else
	   tos& = eventstat%
	   eventstat% = 0
	endif	
	goto xnext



rem search-for-adding-a-new-primitive


xthread::
	tos& = thread%(tos&)
	goto xnext

	

	        	
rem call machine code at addr tos&
rem code needs a way to locate both stacks.
xcall::
rem	tos& = usr(tos&)
	goto xnext


	
	
	
rem loads source from file. filename from input stream	
xfrom::
	pad$ = word$:(0)
	if ( loc(pad$,"\") = 0 )
	   pad$ = sourcepath$+pad$
	endif	
	if ( ioopen(temp%,pad$,0) )
	   report_error:("can't open "+pad$)
	   goto xabort
	endif
	indicate:("loading")
	xloading& = temp%
	goto xnext



xdown::
	off
	goto xnext



xbye::
	stop

ENDP






PROC build_constants:
	constant&:("state",addr(xstate&))
	constant&:("loading",addr(xloading&))
	constant&:("base",addr(xbase&))
	constant&:("user",addr(xuser&))
	constant&:("volume",addr(xvolume&))
	constant&:("autoexec",addr(xautoexec&))
	constant&:("batterystate",addr(xbattstat&))
	constant&:("systembegin",addr(uid1&))
	constant&:("last",addr(last&))
	constant&:("dp",addr(dp&))
	constant&:("esc",KEsc&)
	constant&:("bl",Kbl&)
	constant&:("true",KTrue&)
	constant&:("false",KFalse&)
	constant&:("cell",KCell&)
	constant&:("byte",1)
	constant&:("#threads",KThreads%)
	constant&:("version",KVersion%)
	constant&:("revision",KRevision%)
ENDP



rem "compile" hi-level words:  cold quit
PROC build_hilevel:
	xcold& = dp&
	comma:(xprompt&)
	comma:(xabort&)

	xquit& = cfa&(colon:("quit",0))
	comma:(xquery&)
	comma:(xinterpret&)
	comma:(xprompt&)
	comma:(xbranch&)
	comma:(-5*KCell&)
	comma:(xexit&)

ENDP	



PROC colon:(header$,imm%)	
	header&:(header$,imm%)
	comma:(xdocol&)
	return last&
ENDP



PROC constant&:(header$,value&)
	header&:(header$,0)
	comma:(xdoconst&)
	comma:(value&)
	return dp&-KCell&
ENDP



PROC handler:(header$,imm%)
	header&:(header$,imm%)
	cfa&(last&) = last&
	return last&
ENDP



PROC primitive:(header$,imm%)
	pokel dp&,header&:(header$,imm%)
	dp& = dp&+KCell&
	return last&
ENDP



rem add a header, apply header flags, return word#
PROC header&:(header$,imm%)
	local temp%
	last& = last&+1
	name$(last&) = left$(header$,KMaxHeaderSize%)
	cfa&(last&) = dp&
	prec%(last&) = imm%
	temp% = hash:(name$(last&))
	thread%(tp%) = thread%(temp%)
	thread%(tp%+1) = last&
	thread%(temp%) = tp%
	tp% = tp%+2
	return last&
ENDP




PROC comma:(n&)
	pokel dp&,n&
	dp& = dp&+KCell&
ENDP





PROC word$:(delimiter&)
	local string$(KMaxStringLen%)
	string$		=	""
	while ( loc(tib$," ") = 1 )
	   tib$ = right$(tib$,len(tib$)-1)
	endwh
	if ( len(tib$) )
	   temp& = loc(tib$,chr$(delimiter&))
	   if ( temp& )
	      string$ = left$(tib$,temp&-1)
	      tib$ = right$(tib$,len(tib$)-temp&)
	   else
	      string$ = tib$
	      tib$ = ""
	   endif
	endif
	return string$
ENDP




PROC find:(name$)
	local nfa&,link%
	link% = thread%(hash:(left$(name$,KMaxHeaderSize%)))
	nfa& = 0
	while ( link% and (nfa&=0) )
	   if ( name$(thread%(link%+1)) = left$(name$,KMaxHeaderSize%) )
	      nfa& = thread%(link%+1)
	   endif
	   link% = thread%(link%)	
	endwh
	return nfa&
ENDP




PROC hash:(name$)
	local hashvalue&
	hashvalue& = 0
	i& = len(name$)
	while i&
	   hashvalue& = hashvalue& + asc(mid$(name$,i&,1)) * (i& * 2 + 1)
	   i& = i&-1
	endwh
	return (hashvalue& and KThreadMask%) + 1
ENDP



	
PROC numberq:(number$)
	local startchar%,testchar%,currentchar%
	testchar% = len(number$)	
	startchar% = (asc(left$(number$,1)) <> %-) + 1
	do
	   currentchar%	= asc(mid$(number$,testchar%,1))
	   temp& (currentchar% <= 57) and (currentchar% >= 48)
	   testchar% = testchar% - 1
	until (testchar% = startchar%) or (not temp&)
	return temp&
ENDP




PROC digit:
	temp& = mod&:(tos&,xbase&)
	tos& = tos&/xbase&
	if ( temp& > 9 )
	   temp& = temp&+7
	endif
	hold:(temp&+48)
ENDP



PROC hold:(char&)
	temp& = dp&+KPadsize&-KCell&
	pokel temp&,peekl(temp&)-1
	pokeb peekl(temp&),char&
ENDP




PROC debug:
	local inwp&
	inwp& = 0
	print "ip=";ip&,
	if ip&
	   print	"(ip)=";peekl(ip&),
	endif
	print "wp=";wp&,
	print "sp=";sp&,"rp=";rp&,
	print "dp=";dp&,"latest=";last&
ENDP




PROC string:(string$,addr&)
	sp& = sp&-K2Cells&
	pokel sp&+KCell&,tos&	
	move:(string$,addr&+1)
	tos& = len(string$)
	pokeb addr&,tos&
	pokel sp&,addr&+1
ENDP




PROC move:(string$,addr&)
	temp& = len(string$)
	i& = 0
	while ( i& < temp& )
	   pokeb addr&+i&,asc(mid$(string$,i&+1,1))
	   i& = i&+1
	endwh
ENDP




PROC packed$:
	local string$(KMaxStringLen%)
	temp& = peekl(sp&)
	while tos&
	   string$ = string$+chr$(peekb(temp&))
	   tos& = tos&-1
	   temp& = temp&+1
	endwh
	tos& = peekl(sp&+KCell&)
	sp& = sp&+K2Cells&
	return string$
ENDP





PROC lineedit$:(line$,len%)
	local editcmd$(32)
	local line1$(KMaxStringLen%)
	local key%
	local cursor%
	local temp%

	editcmd$ = chr$(KKeyDel%)+chr$(KKeyLeftArrow%)
	editcmd$ = editcmd$ + chr$(KKeyRightArrow%)
	editcmd$ = editcmd$ + chr$(KGetMenu%)
	editcmd$ = editcmd$ + chr$(KKeyPageLeft%) + chr$(KKeyPageRight%)
	editcmd$ = editcmd$ + chr$(KKeyEsc%)
	editcmd$ = editcmd$ + chr$(KKeySidebarMenu%+3)
	editcmd$ = editcmd$ + chr$(KKeySidebarMenu%+4)
	
	line1$ = line$
	cursor% = len(line1$)+1
	print
	showline:(line1$,cursor%)
	key% = get
	while ( key% <> KKeyEnter% )
	   if ( (key% >= Kbl&) and (key% < 256) )
	      if ( len(line1$) < len% )
	         line1$ = left$(line1$,cursor%-1)+chr$(key%)+mid$(line1$,cursor%,KMaxStringLen%)
	         cursor% = cursor%+1		
	         showline:(line1$,cursor%)
	      else
	         beep 2,500
	      endif
	   else	
	      vector loc(editcmd$,chr$(key%))
	         backspace
	         cursorleft
	         cursorright
	         menubutton
	         cursorhome
	         cursorend
	         wipe
	         zoomin
	         zoomout
	      endv
	      goto unknown
backspace::
	      if ( kmod = KKmodShift% )
	         if ( cursor% <= len(line1$) )
	            line1$ = deletechar$:(line1$,cursor%)
	         endif
	      elseif ( cursor% > 1 )
	         cursor% = cursor%-1
	         line1$ = left$(line1$,strip%:(line1$,cursor%))					
	         line1$ = deletechar$:(line1$,cursor%)
	         if ( cursor% > len(line1$) )
	            print chr$(Kbl&);
	         endif
	      endif			
	      goto unknown

cursorleft::
	      cursor% = max(cursor%-1,1)
	      goto showline
cursorright::
	      cursor% = min(cursor%+1,len(line1$)+1)
	      goto showline
cursorhome::
	      cursor% = 1
	      goto showline
	
cursorend::
	      cursor% = len(line1$)+1
	      goto showline
wipe::
	      showline:(rept$(" ",len(line1$)+1),-1)
	      line1$ = ""
	      cursor% = 1
	      goto showline
menubutton::
	      DisplayTaskList:
	      goto unknown
zoomin::
	      temp% = min(font%+1,KFonts%)
	      goto showfont
zoomout::
	      temp% = max(font%-1,1)
showfont::
	      setfont: (temp%,fontattr%)
	      hello:
	      print "font",font%,"of",KFonts%;":",screeninfo%(4);"×";screeninfo%(3)
showline::
	      line1$ = left$(line1$,strip%:(line1$,cursor%))
	      showline:(line1$,cursor%)
unknown::
	   endif
	   key% = get
	endwh
	showline:(line1$,not(cursor%))
	print chr$(Kbl&);
	return line1$
ENDP




PROC deletechar$:(line$,cursor%)
	local line1$(KMaxStringLen%)			
	line1$ = left$(line$,cursor%-1)+mid$(line$,cursor%+1,KMaxStringLen%)
	showline:(line1$,cursor%)
	return line1$
ENDP




PROC strip%:(line$,cursor%)
	local i%
	i% = len(line$)
	if i%
	   while ( (i% > cursor%) and (asc(mid$(line$,i%,1)) = Kbl&) )
	      i% = i%-1
	   endwh
	endif
	return i%
ENDP




PROC showline:(line$,cursor%)
	print chr$(KKeyEnter%);
	if ( cursor% < 0 )
	   print line$;
	else	
	   print left$(line$,cursor%-1);
	   style KgStyleInverse%
	   if ( cursor% <= len(line$) )
	      print mid$(line$,cursor%,1);
	      style fontattr%
	      print right$(line$,max(len(line$)-cursor%,0)),				
	   endif
	   print chr$(Kbl&);
	   style fontattr%
	endif
ENDP




PROC indicate:(string$)
	if ( string$ <> indicator$ )
	   indicator$ = string$
	   if ( len(indicator$) )
	      busy indicator$,KBusyBottomRight%
	   else
	      busy off
	   endif
	endif
ENDP



PROC aligned&:(addr&,boundary&)
	return (addr& + boundary&-1) and (not boundary&-1)
ENDP




PROC elapsed:(starttime&,stoptime&)
	print "elapsed:",DTMicrosDiff&:(start&,end&)y
ENDP





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




rem ***** gpl terms
PROC hello:
	cls
	print "PsiForth32 v";KVersion%;".";KRevision%
	print "Copyright © 1999 by"
	print "Integrated Services"
	print "Arnhem, The Netherlands"
	print
ENDP





PROC report_error:(error$)
	local errorlocation%
	errorlocation% = len(history$(1)) - len(tib$) - len(word$)
	if len(tib$)
	   errorlocation% = errorlocation%-1
	endif	
	print
	if xloading&
	   print history$(1)
	endif
	print rept$(" ",errorlocation%);rept$("^",len(word$))
	print "error:",error$
ENDP




PROC close_file:(handle&)
	if ioclose(handle&)
	   report_error:("error closing file")
	endif
ENDP




PROC loadline$:(handle&,delimiter&)
	local linebuffer$(254)
	i& = loc(filebuffer$,chr$(delimiter&))
	if ( i&=0 )
	   linebuffer$ = linebuffer$ + filebuffer$
	   filebuffer$ = ""
	endif

	if ( filebuffer$ = "" )
	   temp& = ioread(handle&,addr(filebuffer$)+1,255)
	   if ( temp& < 0 )
	      close_file:(handle&)
	      indicate:("")
	      xloading& = 0
	   else
	      pokeb addr(filebuffer$),temp&
	   endif
	endif	

	if ( len(filebuffer$) )
	   i& = loc(filebuffer$,chr$(delimiter&))
	   if i&
	      linebuffer$ = linebuffer$ + left$(filebuffer$,i&)
	      if ( i& = len(filebuffer$) )
	         filebuffer$ = ""
	      else
	         filebuffer$ = mid$(filebuffer$,i&+1,255)
	      endif
	   endif
	endif
	return linebuffer$
ENDP