forth5mx_fvm.opp
Descripción del contenido de la página
Uno de los ficheros fuentes principales (la máquina virtual) de Forth 5mx, un Forth para la computadora Psion 5mx, escrito en OPL+.
Código fuente
// forth5mx_fvm.opp
// Copyright (C) 2004-2010 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>.
// -------------------------------------------------------
// Comment marks
// -------------------------------------------------------
// :!!! = not finished
// ?!!! = to be explored
// *!!! = temporal for debugging
// x!!! = obsolete
// b!!! = benchmark to decide
// -------------------------------------------------------
// Forth Virtual Machine
// -------------------------------------------------------
onerr oplerror // *!!!
// Virtual machine init
xcold::
// cold \ Common use
// ( -- )
randomize day*86400.0+hour*1440.0+minute*60.0+second
#ifndef _DSOURCE
ib_opl_addr& = addr(ib$)
ib_addr& = ib_opl_addr&+1
temp% = KMaxSourceRecursions%
while temp% // :!!! ?!!!
recursive_ib$(temp%) = ""
recursive_path$(temp%) = ""
temp% = temp%-1
endwh
#endif
dp& = dp0&
// Autoexec
ip& = xcoldstart& // point to the address of the next xt of the next word
wp& = xautoexec& // ?!!!
if wp&
goto xvector
endif
gcls
cls
setfont:(font%,fontattr%)
hello:
goto xnext
// EXIT is placed here for speed, to save one "goto xnext" in every high level word.
xexit::
// EXIT \ Core
// ( -- ) ( R: nest-sys -- )
ip& = peekl(rp&)
_RDROP
// this goes on to xnext...
// Some primitives that ***do nothing***
xnoop::
// noop \ Common use
// ( -- )
xchars::
// CHARS \ Core
// ( n -- n )
// Primitive dispatch
xnext::
// NEXT \ PsiForth
// ( -- )
//_DEBUG_NEXT?("en NEXT antes de actualizar wp&")
wp& = peekl(ip&) // xt of the word to execute
//_DEBUG_NEXT?("en NEXT antes de actualizar ip&")
ip& = ip&+KCell& // point to the address of the next xt
// Input: wp& has the xt of the word to execute.
xvector::
//_DEBUG_VECTOR?("xvector")
vector peekl(wp&) // nt of the word to execute
xbrcolonbr
xbrvariablebr
xbrprimitivevariablebr
xbrconstantbr
xbr2constantbr
xbrdoesbr
xbrdeferbr
xdouser
xdoarray
xdotable
xdocode
xbrcreatebr
xbrvaluebr
xbrmarkerbr
xcold
xexit
xbrliteralbr
xsliteral
xnext
xnoop
xdup
xdrop
xswap
xover
xnip
xtuck
xqdup
xpick
xroll
xrfetch
xbranch
x0branch
xtor
xrfrom
x0equal
x0notequal
ximmediate
ximmediateq
xexecute
xequal
xnot
xlatest
xleftbracket
xrightbracket
xfetch
xstore
xkey
xemit
xdot
xcr
xtype
xrefill
xword
xhere
xfind
xnamefrom
xname
xallot
xerror
xbye
xinclude
xnumberq
xnumber
xabort
xplus
xminus
xdepth
xstarslash
x_and
x_or
x_xor
xless
xrot
xminusrot
xcmove
xfill
xatxy
xemit
x2drop
x0less
x1minus
x1plus
xcharminus
xcharplus
xcellminus
xcellplus
x2star
x2div
x2dup
xexchange
xcfetch
xcstore
xccomma
xpad
xtobody
xscomma
xmin
xmax
xdotname
xbrdobr
xbrloopbr
xi
xj
xk
xleave
xbrplusloopbr
xbrminusloopbr
xthread
xdown
label00
label01
label02
label03 // evaluate :!!!
xinterpret
xbrdebugquotebr
xdebugquote
xdebugnumber
xdebug
xcomma
xcreate
xcolon
xsemicolon
xprompt
xcount
xskim
xspace
xspaces
xgat
xgline
xsquote
xcompile
xhome
xfont
xgbox
xgcircle
xgcolor
xgellipse
xgfill
xgmode
xgmove
xgxy
xbracketnumber
xnumbersign
xnumbersigns
xnumberbracket
xhold
xsign
xexit
xkeyq
xcells
xchars
xstar
xdivide
xnotequal
xgreater
xqabort
xtasks
xlookup
xmod
xslashmod
xcolormode
xaccept
xcatch
xthrow
xbeep
xbusy
xabs
xdays
xday
xmonth
xyear
xhour
xminute
xsecond
xscreen
xscreeninfo
xgcls
xsetcontrast
xweek
xthrow0
xpluck
xrp
xsp
xr0
xs0
xqcompiling
xqexecuting
xnegate
xbold
xthin
xdotr
xplusstore
xcplusstore
x0greater
xunused
xbodyfrom
xindicator
xplay
x2over
x2swap
xdump
xopenfile
xclosefile
xreadfile
xwritefile
xseekfile
xmkdir
xparsefile
xpath
xdeletefile
xdirectory
xallocate
xresize
xfree
xdinit
xdbutton
xdbuttons
xdcheckbox
xdialog
xdposition
xdtext
xdchoice
xgetevent
xevent
xbrofbr
xalign
xaligned
xrun
xbacklight
xbacklightq
xrnd
xminustrailing
xsearch
xcompare
xparenthesis
xbackslash
xdotparenthesis
xreadline
xwriteline
xcreatefile
xrenamefile
x2tor
x2rfrom
x2rfetch
xdatetosecs
xsecstodate
xudot
xpage
xinvert
x2plus
x2minus
xcompilecomma
xlessorequal
xgreaterorequal
xsourceid
xsource
xsourcestore
xsaveinput
xrestoreinput
xparse
xupper
xlower
xincluded
xincludefile
xchdir
xchdirq
xdirstr
xsetpath
xbrsliteralbr
xtosbuffer
xplussbuffer
xsbuffer
xsbufferplusstore
xsbufferplus
xuless
xmove
xbrcompilebr
xpostpone
xsmove
xbrleavebr
xquit
xudotr
xumore
xparseword
xvariable
xconstant
xextend
xcquote
xbrcsliteralbr
xnumbertib
xtib
xexpect
xcolonnoname
xlshift
xrshift
xstarstar
xmarker
xunloop
xfilestatus
xgetfilesize
xbrqdobr
xssquote
xalias
xquery
xevaluate
xcmoveback
// xstarslashmod // */MOD
xrdrop
x2rdrop
xtoupper
xtolower
xmcdrop
x2constant
xsbufferfree
xms
xfindname
xdequal
// new_primitives_here
endv
_REPORT_ERROR?("execution attempt of undefined primitive "+num$(peekl(wp&),5))
goto xabort
// Primitives
xms::
// MS \ Facility Ext
// ( u -- )
// :!!! Provisional implementation:
// The OPL pause parameter is 1/20 seconds!
// The Forth MS parameter is 1/1000 seconds!
// No sign check (the action of pause depends on the sign)!
// This word should be implemented in assembler.
#ifdef _TOS
pause max(1,tos&/50)
#else
pause max(1,peekl(sp&)/50)
#endif
goto xdrop
xswap::
// SWAP \ Core
// ( x1 x2 -- x2 x1 )
#ifdef _TOS
temp& = peekl(sp&)
pokel sp&,tos&
tos& = temp&
#else
#ifdef _ASM
_FETCH_SP
temp& = MCPeekL&:(sp&+KCell&)
MCPokeL&:(sp&+KCell&,MCPeekl&:(sp&))
MCPokeL&:(sp&,temp&)
#else
temp& = peekl(sp&+KCell&)
pokel sp&+KCell&,peekl(sp&)
pokel sp&,temp&
#endif
#endif
goto xnext
xtor::
// >R \ Core
// ( x -- )
// ( R: -- x )
#ifdef _TOS
_RPUSH?(tos&)
#else
#ifdef _ASM
_FETCH_SP
_RPUSH?(MCPeekL&:(sp&))
#else
_RPUSH?(peekl(sp&))
#endif
#endif
xdrop::
// DROP \ Core
// ( x -- )
_DROP
goto xnext
xmcdrop::
#ifdef _ASM
print MCCall&:(mc_handle&,mc_xdrop&,0,0,0,0)
#endif
goto xnext
xnip::
// NIP \ Core Ext
// ( x1 x2 -- x2 )
_NIP
goto xnext
x2tor::
// 2>R \ Core Ext
// ( x1 x2 -- )
// ( R: -- x1 x2 )
_2INCREASE_RSTACK
#ifdef _TOS
pokel rp&,tos&
pokel rp&+KCell&,peekl(sp&)
#else
#ifdef _ASM
_FETCH_SP :\
pokel rp&,MCPeekL&:(sp&)
pokel rp&+KCell&,MCPeekL&:(sp&+KCell&)
#else
pokel rp&,peekl(sp&)
pokel rp&+KCell&,peekl(sp&+KCell&)
#endif
#endif
_2DROP
#ifdef _ASM
_STORE_SP
#endif
goto xnext
xrfrom::
// R> \ Core
// ( -- x )
// ( R: x -- )
_PUSH?(peekl(rp&))
_RDROP
goto xnext
x2rfrom::
// 2R> \ Core Ext
// ( -- x1 x2 )
// ( R: x1 x2 -- )
_2INCREASE_STACK
#ifdef _TOS
pokel sp&,peekl(rp&+KCell&)
tos& = peekl(rp&)
#else
#ifdef _ASM
MCPokeL&:(sp&+KCell&,peekl(rp&+KCell&))
MCPokeL&:(sp&,peekl(rp&))
#else
pokel sp&+KCell&,peekl(rp&+KCell&)
pokel sp&,peekl(rp&)
#endif
#endif
_2RDROP
goto xnext
xi::
// I \ Core
// ( R: branch limit index -- )
// ( -- index )
xrfetch::
// R@ \ Core
// ( -- x )
// ( R: x -- x )
_PUSH?(peekl(rp&))
goto xnext
x2rfetch::
// 2R@ \ Core Ext
// ( -- x1 x2 )
// ( R: x1 x2 -- x1 x2 )
_2INCREASE_STACK
#ifdef _TOS
pokel sp&,peekl(rp&+KCell&)
tos& = peekl(rp&)
#else
#ifdef _ASM
// note: sp is already fetched by _2INCREASE_STACK
MCPokeL&:(sp&+KCell&,peekl(rp&+KCell&))
MCPokeL&:(sp&,peekl(rp&))
#else
pokel sp&+KCell&,peekl(rp&+KCell&)
pokel sp&,peekl(rp&)
#endif
#endif
goto xnext
xqdup::
// ?DUP \ Core
// ( x -- 0 | x x )
#ifdef _TOS
if tos&
_DUP
endif
#else
#ifdef _ASM
_FETCH_SP
if MCPeekL&:(sp&)
_INCREASE_STACK_KERNEL
MCPokeL&:(sp&,MCPeekL&:(sp&+KCell&))
_STORE_SP
endif
#else
if peekl(sp&)
_DUP
endif
#endif
#endif
goto xnext
xdup::
// DUP \ Core
// ( x -- x x )
_DUP
goto xnext
xover::
// OVER \ Core
// ( x1 x2 -- x1 x2 x1 )
#ifdef _TOS
_PUSH?(peekl(sp&+KCell&))
#else
#ifdef _ASM
_FETCH_SP :\
_INCREASE_STACK_KERNEL :\
MCPokeL&:(sp&,MCPeekL&:(sp&+K2Cells&)) :\
_STORE_SP
#else
_PUSH?(peekl(sp&+K2Cells&))
#endif
#endif
goto xnext
xrot::
// ROT \ Core
// ( x1 x2 x3 -- x2 x3 x1 )
#ifdef _TOS
temp& = tos&
tos& = peekl(sp&+KCell&)
pokel sp&+KCell&,peekl(sp&)
pokel sp&,temp&
#else
#ifdef _ASM
_FETCH_SP
temp& = MCPeekL&:(sp&) // save x3
MCPokeL&:(sp&, MCPeekL&:(sp&+K2Cells&)) // store x1
MCPokeL&:(sp&+K2Cells&,MCPeekL&:(sp&+KCell&)) // store x2
MCPokeL&:(sp&+KCell&,temp&) // store x3
#else
temp& = peekl(sp&) // save x3
pokel sp&, peekl(sp&+K2Cells&) // store x1
pokel sp&+K2Cells&,peekl(sp&+KCell&) // store x2
pokel sp&+KCell&,temp& // store x3
#endif
#endif
goto xnext
xminusrot::
// -rot \ PsiForth
// ( x1 x2 x3 -- x3 x1 x2 )
#ifdef _TOS
temp& = tos&
tos& = peekl(sp&)
pokel sp&,peekl(sp&+KCell&)
pokel sp&+KCell&,temp&
#else
#ifdef _ASM
_FETCH_SP
temp& = MCPeekL&:(sp&) // save x3
MCPokeL&:(sp&,MCPeekL&:(sp&+KCell&)) // store x2
MCPokeL&:(sp&+KCell&,MCPeekL&:(sp&+K2Cells&)) // store x1
MCPokeL&:(sp&+K2Cells&,temp&) // store x3
#else
temp& = peekl(sp&) // save x3
pokel sp&,peekl(sp&+KCell&) // store x2
pokel sp&+KCell&,peekl(sp&+K2Cells&) // store x1
pokel sp&+K2Cells&,temp& // store x3
#endif
#endif
goto xnext
xtuck::
// TUCK \ Core Ext
// ( x1 x2 -- x2 x1 x2 )
#ifdef _TOS
sp& = sp&-KCell&
pokel sp&,peekl(sp&+KCell&)
pokel sp&+KCell&,tos&
#else
#ifdef _ASM
_FETCH_SP
temp&=MCPeekL&:(sp&)
_INCREASE_STACK_KERNEL
_STORE_SP
MCPokeL&:(sp&,temp&)
MCPokeL&:(sp&+KCell&,MCPeekL&:(sp&+K2Cells&))
MCPokeL&:(sp&+K2Cells&,temp&)
#else
temp&=peekl(sp&)
_INCREASE_STACK
pokel sp&,temp&
pokel sp&+KCell&,peekl(sp&+K2Cells&)
pokel sp&+K2Cells&,temp&
#endif
#endif
goto xnext
xpluck::
// pluck \ PsiForth
// ( x1 x2 x3 -- x1 x2 x3 x1 )
// ?!!! test
#ifdef _TOS
_PUSH?(peekl(sp&+K2Cells&))
#else
#ifdef _ASM
_PUSH?(MCPeekL&:(sp&+K3Cells&))
#else
_PUSH?(peekl(sp&+K3Cells&))
#endif
#endif
goto xnext
xpick::
// PICK \ Core Ext
// ( +n -- x )
#ifdef _TOS
tos& = peekl(sp&+tos&*KCell&)
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&,MCPeekL&:(sp&+(MCPeekL&:(sp&)*KCell&)+KCell&))
#else
pokel sp&,peekl(sp&+(peekl(sp&)*KCell&)+KCell&)
#endif
#endif
goto xnext
xroll::
// ROLL \ Core Ext
// ( +n -- )
#ifdef _TOS
temp& = tos&
tos& = peekl(sp&+tos&*KCell&)
while temp&
pokel sp&+temp&*KCell&,peekl(sp&+(temp&-1)*KCell&)
temp&--
endwh
_NIP
#else
#ifdef _ASM
_FETCH_SP
i& = MCPeekL&:(sp&)
_DECREASE_STACK_KERNEL
temp& = MCPeekL&:(sp&+i&*KCell&)
while i&
MCPokeL&:(sp&+i&*KCell&,MCPeekL&:(sp&+(i&-1)*KCell&))
i&--
endwh
MCPokeL&:(sp&, temp&)
#else
i& = peekl(sp&)
_DROP
temp& = peekl(sp&+i&*KCell&)
while i&
pokel sp&+i&*KCell&,peekl(sp&+(i&-1)*KCell&)
i&--
endwh
pokel sp&, temp&
#endif
#endif
goto xnext
xbrliteralbr::
// (literal) \ Forth 5mx
// ( -- x )
_PUSH?(peekl(ip&))
ip& = ip&+KCell&
goto xnext
xvariable::
// VARIABLE \ Core
// ( "<spaces>name" -- )
_PARSED_WORD
_VALUE?(parsed_word$,0,xbrvariablebr&)
goto xnext
xbrvariablebr::
// (variable)
// Run time code for words created by VARIABLE .
_PUSH?(wp&+KCell&)
goto xnext
xconstant::
// CONSTANT \ Core
// ( "<spaces>name" n -- )
_PARSED_WORD
#ifdef _TOS
_CONSTANT?(parsed_word$,tos&)
#else
#ifdef _ASM
_FETCH_SP
_CONSTANT?(parsed_word$,MCPeekL&:(sp&))
#else
_CONSTANT?(parsed_word$,peekl(sp&))
#endif
#endif
_DROP
goto xnext
x2constant::
// 2CONSTANT \ Double
// ( "<spaces>name" n1 n2 -- )
_PARSED_WORD
header&:(parsed_word$,0)
_COMMA?(xbr2constantbr&)
#ifdef _TOS
_COMMA?(tos&)
_COMMA?(peekl(sp&))
#else
#ifdef _ASM
_FETCH_SP
_COMMA?(MCPeekL&:(sp&))
_COMMA?(MCPeekL&:(sp&+KCell&))
#else
_COMMA?(peekl(sp&))
_COMMA?(peekl(sp&+KCell&))
#endif
#endif
_2DROP
goto xnext
xbrprimitivevariablebr::
// (primitive-variable)
// Run time code for variables created by the OPL proc variable:().
// It uses the code of (constant) :
xbrconstantbr::
// (constant)
// ( -- x )
// Run time code for words created by CONSTANT .
_PUSH?(peekl(wp&+KCell&))
goto xnext
xbr2constantbr::
// (2constant)
// ( -- x1 x2 )
// Run time code for words created by 2CONSTANT .
_PUSH?(peekl(wp&+K2Cells&))
_PUSH?(peekl(wp&+KCell&))
goto xnext
xbrvaluebr::
// (value)
// ( -- x )
// Run time code for words created by VALUE .
_PUSH?(peekl(wp&+K2Cells&)) // extra cell of CREATE
goto xnext
xdotable::
// dotable \ PsiForth
// ?!!!
// tos& = peekl(wp& + (tos&+1) * KCell&)
// :!!!create
#ifdef _TOS
tos& = peekl(wp& + (tos&+2) * KCell&)
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&,peekl(wp& + (MCPeekL&:(sp&)+2) * KCell&))
#else
pokel sp&,peekl(wp& + (peekl(sp&)+2) * KCell&)
#endif
#endif
goto xnext
xdoarray::
// doarray \ PsiForth
// ?!!!
// tos& = wp& + (tos&+1) * KCell&
// :!!!create
#ifdef _TOS
tos& = wp& + (tos&+2) * KCell&
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&, wp& + (MCPeekL&:(sp&)+2) * KCell&)
#else
pokel sp&, wp& + (peekl(sp&)+2) * KCell&
#endif
#endif
goto xnext
xbrdoesbr::
// (does>) \ Forth 5mx
// Run time of words modified by DOES> .
_PUSH?(wp&+K2Cells&) // pfa
_RPUSH?(ip&)
ip& = peekl(wp&+KCell&)
goto xnext
xbrdeferbr::
// brdeferbr \ Forth 5mx
wp& = peekl(wp&+K2Cells&)
goto xvector
xdouser::
// douser \ PsiForth
// ?!!!
_PUSH?(peekl(wp&+KCell&) + xuser&)
goto xnext
xbrcolonbr::
// (:)
// ( -- ) ( R: -- nest-sys )
// Run time code for words created by : .
_RPUSH?(ip&)
ip& = wp&+KCell&
goto xnext
xj::
// J \ Core
// ( R: branch1 limit1 index1 branch2 limit2 index2 -- )
// ( -- index1 )
_PUSH?(peekl(rp&+K3Cells&))
goto xnext
xk::
// k \ PsiForth
// ( R: branch1 limit1 index1 branch2 limit2 index2 branch3 limit3 index3 -- )
// ( -- index1 )
_PUSH?(peekl(rp&+K6Cells&))
goto xnext
xplus::
// + \ Core
// ( n1 n2 -- n3 )
#ifdef _TOS
tos& = tos&+peekl(sp&)
_NIP
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&+KCell&, MCPeekL&:(sp&)+MCPeekL&:(sp&+KCell&))
_DECREASE_STACK_KERNEL
_STORE_SP
#else
pokel sp&+KCell&, peekl(sp&)+peekl(sp&+KCell&)
_DECREASE_STACK_KERNEL
#endif
#endif
goto xnext
xminus::
// - \ Core
// ( n1 n2 -- n3 )
#ifdef _TOS
tos& = peekl(sp&)-tos&
_NIP
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&+KCell&, MCPeekL&:(sp&+KCell&)-MCPeekL&:(sp&))
_DECREASE_STACK_KERNEL
_STORE_SP
#else
pokel sp&+KCell&, peekl(sp&+KCell&)-peekl(sp&)
_DECREASE_STACK_KERNEL
#endif
#endif
goto xnext
xbodyfrom::
// body> \ PsiForth
// ( pfa -- xt )
// An ambiguous condition exists if pfa is not for a word defined via CREATE.
#ifdef _TOS
tos& = tos&-K2Cells&
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&,MCPeekL(sp&)-K2Cells&)
#else
pokel sp&,peekl(sp&)-K2Cells&
#endif
#endif
goto xnext
xcellminus::
// cell- \ PsiForth
// ( a-addr1 -- a-addr2 )
#ifdef _TOS
tos& = tos&-KCell&
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&,MCPeekL&:(sp&)-KCell&)
#else
pokel sp&,peekl(sp&)-KCell&
#endif
#endif
goto xnext
xcharminus::
// char- \ Forth 5mx
// ( n1 -- n2 )
x1minus::
// 1- \ Core
// ( n1 -- n2 )
#ifdef _TOS
tos& = tos&-1
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&,MCPeekL&:(sp&)-1)
#else
pokel sp&,peekl(sp&)-1
#endif
#endif
goto xnext
x2minus::
// 2- \ Core
// ( n1 -- n2 )
#ifdef _TOS
tos& = tos&-2
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&,MCPeekL&:(sp&)-2)
#else
pokel sp&,peekl(sp&)-2
#endif
#endif
goto xnext
xtobody::
// >BODY \ Core
// ( xt -- pfa )
// Note from the ANS Standard: An ambiguous condition exists if xt is not for a word defined via CREATE.
#ifdef _TOS
tos& = tos&+K2Cells&
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&,MCPeekL&:(sp&)+K2Cells&)
#else
pokel sp&,peekl(sp&)+K2Cells&
#endif
#endif
goto xnext
xcellplus::
// CELL+ \ Core
// ( a-addr1 -- a-addr2 )
#ifdef _TOS
tos& = tos&+KCell&
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&,MCPeekL&:(sp&)+KCell&)
#else
pokel sp&,peekl(sp&)+KCell&
#endif
#endif
goto xnext
xcharplus::
// CHAR+ \ Core
// ( n1 -- n2 )
x1plus::
// 1+ \ Core
// ( n1 -- n2 )
#ifdef _TOS
tos& = tos&+1
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&,MCPeekL&:(sp&)+1)
#else
pokel sp&,peekl(sp&)+1
#endif
#endif
goto xnext
x2plus::
// 2+ \ Forth 5mx
// ( n1 -- n2 )
#ifdef _TOS
tos& = tos&+2
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&,MCPeekL&:(sp&)+2)
#else
pokel sp&,peekl(sp&)+2
#endif
#endif
goto xnext
x2star::
// 2* \ Core
// ( x1 -- x2 )
#ifdef _TOS
tos& = tos&+tos&
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&,MCPeekL&:(sp&)+MCPeekL&:(sp&))
#else
pokel sp&,peekl(sp&)+peekl(sp&)
#endif
#endif
goto xnext
x2div::
// 2/ \ Core
// ( x1 -- x2 )
#ifdef _TOS
tos& = tos&/2
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&,MCPeekL&:(sp&)/2)
#else
pokel sp&,peekl(sp&)/2
#endif
#endif
goto xnext
xcells::
// CELLS \ Core
// ( n1 -- n2 )
#ifdef _TOS
tos& = tos&*KCell&
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&,MCPeekL&:(sp&)*KCell&)
#else
pokel sp&,peekl(sp&)*KCell&
#endif
#endif
goto xnext
xstarslash::
// */ \ Core
// ( n1 n2 n3 -- n4 )
#ifdef _TOS
tos& = peekl(sp&+KCell&)*peekl(sp&)/tos&
sp& = sp&+K2Cells&
#else
#ifdef _ASM
_FETCH_SP
temp& = MCPeekL&:(sp&+K2Cells&)*MCPeekL&:(sp&+KCell&)/MCPeekL&:(sp&)
_2DROP_KERNEL
MCPokeL&:(sp&,temp&)
_STORE_SP
#else
temp& = peekl(sp&+K2Cells&)*peekl(sp&+KCell&)/peekl(sp&)
_2DROP
pokel sp&,temp&
#endif
#endif
goto xnext
xstar::
// * \ Core
// ( n1 n2 -- n3 )
#ifdef _TOS
tos& = peekl(sp&)*tos&
_NIP
#else
#ifdef _ASM
_FETCH_SP
temp& = MCPeekL&:(sp&+KCell&)*MCPeekL&:(sp&)
_DECREASE_STACK_KERNEL
MCPokeL&:(sp&,temp&)
_STORE_SP
#else
temp& = peekl(sp&+KCell&)*peekl(sp&)
_DROP
pokel sp&,temp&
#endif
#endif
goto xnext
xdivide::
// / \ Core
// ( n1 n2 -- n3 )
#ifdef _TOS
tos& = peekl(sp&)/tos&
_NIP
#else
#ifdef _ASM
_FETCH_SP
temp& = MCPeekL&:(sp&+KCell&)/MCPeekL&:(sp&)
_DECREASE_STACK_KERNEL
MCPokeL&:(sp&,temp&)
_STORE_SP
#else
temp& = peekl(sp&+KCell&)/peekl(sp&)
_DROP
pokel sp&,temp&
#endif
#endif
goto xnext
xslashmod::
// /MOD \ Core
// ( n1 n2 -- n3 n4 )
#ifdef _TOS
temp& = peekl(sp&)
pokel sp&,mod&:(temp&,tos&)
tos& = temp&/tos&
#else
#ifdef _ASM
_FETCH_SP
temp& = MCPeekL&:(sp&+KCell&)
MCPokeL&:(sp&+KCell&,mod&:(temp&,MCPeekL&:(sp&)))
MCPokeL&:(sp&,temp&/MCPeekL&:(sp&))
#else
temp& = peekl(sp&+KCell&)
pokel sp&+KCell&,mod&:(temp&,peekl(sp&))
pokel sp&,temp&/peekl(sp&)
#endif
#endif
goto xnext
xmod::
// MOD \ Core
// ( n1 n2 -- n3 )
#ifdef _TOS
tos& = mod&:(peekl(sp&),tos&)
_NIP
#else
#ifdef _ASM
_FETCH_SP
temp& = mod&:(MCPeekL&:(sp&+KCell&),MCPeekL&:(sp&))
_DECREASE_STACK_KERNEL
MCPokeL&:(sp&,temp&)
_STORE_SP
#else
temp& = mod&:(peekl(sp&+KCell&),peekl(sp&))
_DROP
pokel sp&,temp&
#endif
#endif
goto xnext
// xstarslashmod::
// */MOD \ Core
// ( n1 n2 n3 -- n4 n5 )
// print "*/MOD not implemented yet" // :!!!
// goto xnext
xmin::
// MIN \ Core
// ( n1 n2 -- n3 )
#ifdef _TOS
tos& = min(tos&,peekl(sp&))
_NIP
#else
#ifdef _ASM
_FETCH_SP
temp&=min(MCPeekL&:(sp&),MCPeekL&:(sp&+KCell&))
_DECREASE_STACK_KERNEL
MCPokeL&:(sp&,temp&)
_STORE_SP
#else
temp&=min(peekl(sp&),peekl(sp&+KCell&))
_DROP
pokel sp&,temp&
#endif
#endif
goto xnext
xmax::
// MAX \ Core
// ( n1 n2 -- n3 )
#ifdef _TOS
tos& = max(tos&,peekl(sp&))
_NIP
#else
#ifdef _ASM
_FETCH_SP
temp&=max(MCPeekL&:(sp&),MCPeekL&:(sp&+KCell&))
_DECREASE_STACK_KERNEL
MCPokeL&:(sp&,temp&)
_STORE_SP
#else
temp&=max(peekl(sp&),peekl(sp&+KCell&))
_DROP
pokel sp&,temp&
#endif
#endif
goto xnext
xabs::
// ABS \ Core
// ( n -- +n )
#ifdef _TOS
tos& = unsigned:(tos&)
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&,unsigned:(MCPeekL&:(sp&))
#else
pokel sp&,unsigned:(peekl(sp&))
#endif
#endif
goto xnext
x_and::
// AND \ Core
// ( x1 x2 -- x3 )
#ifdef _TOS
tos& = tos& and peekl(sp&)
_NIP
#else
#ifdef _ASM
_FETCH_SP
temp& = MCPeekL&:(sp&) and MCPeekL&:(sp&+KCell&)
_DECREASE_STACK_KERNEL
MCPokeL&:(sp&,temp&)
_STORE_SP
#else
temp& = peekl(sp&) and peekl(sp&+KCell&)
_DROP
pokel sp&,temp&
#endif
#endif
goto xnext
x_or::
// OR \ Core
// ( x1 x2 -- x3 )
#ifdef _TOS
tos& = tos& or peekl(sp&)
_NIP
#else
#ifdef _ASM
_FETCH_SP
temp& = MCPeekL&:(sp&) or MCPeekL&:(sp&+KCell&)
_DECREASE_STACK_KERNEL
MCPokeL&:(sp&,temp&)
_STORE_SP
#else
temp& = peekl(sp&) or peekl(sp&+KCell&)
_DROP
pokel sp&,temp&
#endif
#endif
goto xnext
x_xor::
// XOR \ Core
// ( x1 x2 -- x3 )
#ifdef _TOS
tos& = xor&:(tos&,peekl(sp&))
_NIP
#else
#ifdef _ASM
_FETCH_SP
temp& = xor&:(MCPeekL&:(sp&),MCPeekL&:(sp&+KCell&))
_DECREASE_STACK_KERNEL
MCPokeL&:(sp&,temp&)
_STORE_SP
#else
temp& = xor&:(peekl(sp&),peekl(sp&+KCell&))
_DROP
pokel sp&,temp&
#endif
#endif
goto xnext
xcfetch::
// C@ \ Core
// ( c-addr -- b )
#ifdef _TOS
tos& = peekb(tos&)
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&, peekb(MCPeekL&:(sp&)))
#else
pokel sp&, peekb(peekl(sp&))
#endif
#endif
goto xnext
xfetch::
// @ \ Core
// ( a-addr -- x )
#ifdef _TOS
tos& = peekl(tos&)
#else
#ifdef _ASM
_FETCH_SP
MCPokeL&:(sp&, peekl(MCPeekL&:(sp&)))
#else
// print "Fetched=";peekl(peekl(sp&)) // d!!!
pokel sp&,peekl(peekl(sp&))
// print "ReFetched=";peekl(sp&) // d!!!
#endif
#endif
goto xnext
xcstore::
// C! \ Core
// ( b c-addr -- )
#ifdef _TOS
pokeb tos&,peekb(sp&)
_2DROP
#else
#ifdef _ASM
_FETCH_SP
pokeb MCPeekL&:(sp&),MCPeekB(sp&+KCell&)
_2DROP_KERNEL
_STORE_SP
#else
// print peekl(sp&),peekb(sp&+KCell&) // d!!!
pokeb peekl(sp&),peekb(sp&+KCell&)
_2DROP
#endif
#endif
goto xnext
xstore::
// ! \ Core
// ( x a-addr -- )
#ifdef _TOS
pokel tos&,peekl(sp&)
#else
#ifdef _ASM
_FETCH_SP
poke MCPeekL&:(sp&),MCPeekL(sp&+KCell&)
_2DROP_KERNEL
_STORE_SP
goto xnext
#else
pokel peekl(sp&),peekl(sp&+KCell&)
#endif
#endif
x2drop::
// 2DROP \ Core
// ( x1 x2 -- )
_2DROP
goto xnext
xplusstore::
// +! \ Core
// ( n a-addr -- )
#ifdef _TOS
pokel tos&,peekl(sp&)+peekl(tos&)
_2DROP
#else
#ifdef _ASM
_FETCH_SP
pokel MCPeekl&:(sp&),MCPeekL&:(sp&+KCell&)+peekl(MCPeekL&:(sp&))
_2DROP_KERNEL
_STORE_SP
#else
// print peekl(sp&+KCell&);"+";peekl(peekl(sp&));"=";peekl(sp&+KCell&)+peekl(peekl(sp&)) // d!!!
// temp1&=peekl(sp&+KCell&)
// temp2&=peekl(peekl(sp&))
// temp3&=temp1&+temp2&
// print temp1&;"+";temp2&;"+";temp3&
pokel peekl(sp&),peekl(sp&+KCell&)+peekl(peekl(sp&))
_2DROP
#endif
#endif
goto xnext
xcplusstore::
// C+! \ Commn Use
// ( b c-addr -- )
#ifdef _TOS
pokeb tos&,peekb(sp&)+peekb(tos&)
_2DROP
#else
#ifdef _ASM
_FETCH_SP
// d!!! test
pokeb MCPeekL&:(sp&),MCPeekB&:(sp&+KCell&)+peekb(MCPeekL&:(sp&))
_2DROP_KERNEL
_STORE_SP
#else
pokeb peekl(sp&),peekb(sp&+KCell&)+peekb(peekl(sp&))
_2DROP
#endif
#endif
goto xnext
xcount::
// COUNT \ Core
// ( addr1 -- addr2 n ) ?!!!
// ( c-addr1 -- c-addr2 n )
#ifdef _TOS
sp& = sp&-KCell&
pokel sp&,tos&+1
tos& = peekb(tos&)
#else
#ifdef _ASM
_FETCH_SP
temp&=MCPeekL&:(sp&)
_INCREASE_STACK_KERNEL
MCPokeL&:(sp&+KCell&,temp&+1)
MCPokeL&:(sp&,peekb(temp&))
_STORE_SP
#else
temp&=peekl(sp&)
_INCREASE_STACK
pokel sp&+KCell&,temp&+1
pokel sp&,peekb(temp&)
#endif
#endif
goto xnext
xskim::
// skim \ PsiForth
// ( a-addr1 -- a-addr2 n )
// a-addr2 = a-addr1 + cell
// n = (a-addr)
#ifdef _TOS
_INCREASE_STACK_KERNEL
pokel sp&,tos&+KCell&
tos& = peekl(tos&)
#else
#ifdef _ASM
_FETCH_SP
temp&=MCPeekL&:(sp&)
_INCREASE_STACK_KERNEL
MCPokeL&:(sp&+KCell&,temp&+KCell&)
MCPokel&:(sp&,peekl(temp&))
_STORE_SP
#else
temp&=peekl(sp&)
_INCREASE_STACK
pokel sp&+KCell&,temp&+KCell&
pokel sp&,peekl(temp&)
#endif
#endif
goto xnext
xexchange::
// exchange \ PsiForth
// ( addr1 addr2 -- u2 )
// ?!!! used only in the unused LINK
#ifdef _TOS
temp& = peekl(tos&)
pokel tos&,peekl(sp&)
tos& = temp&
_NIP
#else
#ifdef _ASM
print "EXCHANGE not implemented" // :!!!
#else
temp&=peekl(peekl(sp&))
pokel peekl(sp&),peekl(sp&+KCell&)
pokel sp&,temp&
_NIP
#endif
#endif
goto xnext
x2dup::
// 2DUP \ Core
// ( x1 x2 -- x1 x2 x1 x2 )
#ifdef _TOS
_2INCREASE_STACK_KERNEL
pokel sp&,peekl(sp&+K2Cells&)
pokel sp&+KCell&,tos&
#else
#ifdef _ASM
_FETCH_SP
_2INCREASE_STACK_KERNEL
MCPokeL&:(sp&,MCPeekL&:(sp&+K2Cells&))
MCPokeL&:(sp&+KCell&,MCPeekL&:(sp&+K3Cells&))
_STORE_SP
#else
_2INCREASE_STACK_KERNEL
pokel sp&,peekl(sp&+K2Cells&)
pokel sp&+KCell&,peekl(sp&+K3Cells&)
#endif
#endif
goto xnext
xbrcsliteralbr::
// (csliteral) \ Forth 5mx
// ( -- c-addr )
_PUSH?(ip&) // string address
#ifdef _TOS
ip& = _ALIGNED?(ip&+peekb(tos&)+1)
#else
#ifdef _ASM
ip& = _ALIGNED?(ip&+peekb(MCPeekL&:(sp&))+1)
#else
ip& = _ALIGNED?(ip&+peekb(peekl(sp&))+1)
#endif
#endif
goto xnext
xbrsliteralbr::
// (sliteral) \ Forth 5mx
// ( -- c-addr u )
#ifdef _TOS
_2INCREASE_STACK
pokel sp&,ip&+1 // string address
tos& = peekb(ip&) // string length
ip& = _ALIGNED?(ip&+tos&+1)
#else
#ifdef _ASM
_PUSH?(ip&+1) // string address
_PUSH?(peekb(ip&)) // string length
ip& = _ALIGNED?(ip&+MCPeekL&:(sp&)+1)
#else
_PUSH?(ip&+1) // string address
_PUSH?(peekb(ip&)) // string length
ip& = _ALIGNED?(ip&+peekl(sp&)+1)
#endif
#endif
goto xnext
xsliteral::
// SLITERAL \ String
// Compile time: ( c-addr u -- )
// Run time: ( -- c-addr u )
#ifdef _TOS
if state& // compiling
// compile (SLITERAL) into the dicionary:
pokel dp&,xbrsliteralbr&
dp& = dp&+KCell&
// store the string into the dictionary:
// (this is the same code of S, , but we have to duplicate it here
// because S, does not align the dicionary pointer)
_PUSH?(dp&)
dp& = _ALIGNED?(dp&+peekl(sp&)+1)
goto xsmove
endif
#else
#ifdef _ASM
// :!!! this code is the same than the #else part
if state& // compiling
// compile (SLITERAL) into the dicionary:
pokel dp&,xbrsliteralbr&
dp& = dp&+KCell&
// store the string into the dictionary:
// (this is the same code of S, , but we have to duplicate it here
// because S, does not align the dicionary pointer)
_PUSH?(dp&)
// sp& is already fetched by _PUSH
dp& = _ALIGNED?(dp&+MCPeekL&:(sp&+KCell&)+1)
goto xsmove
endif
#else
if state& // compiling
// compile (SLITERAL) into the dicionary:
pokel dp&,xbrsliteralbr&
dp& = dp&+KCell&
// store the string into the dictionary:
// (this is the same code of S, , but we have to duplicate it here
// because S, does not align the dicionary pointer)
_PUSH?(dp&)
dp& = _ALIGNED?(dp&+peekl(sp&+KCell&)+1)
goto xsmove
endif
#endif
#endif
goto xnext
xssquote::
// s' \ Forth 5mx
// ( -- c-addr u )
_PARSED?(39) // 39 = char code of '
goto xsquote0
xsquote::
// S" \ Core
// ( -- c-addr u )
_PARSED?(34) // 34 = double quote char code
xsquote0::
// Input: parsed$ = text parsed
if state& = KInterpreting&
string$=parsed$
#include "forth5mx_inc_to_sbuffer.opp"
goto xnext
endif
_COMMA?(xbrsliteralbr&)
_COMPILE_PARSED
goto xnext
xcquote::
// C" \ Core Ext
// ( -- c-addr )
_PARSED?(34) // 34 = double quote char code
if state& = KInterpreting&
string$=parsed$
#include "forth5mx_inc_to_sbuffer.opp"
#ifdef _TOS
tos& = peekl(sp&)-1
_NIP
#else
#ifdef _ASM
_FETCH_SP
_DECREASE_STACK_KERNEL
MCPokeL&:(sp&,MCPeekL&:(sp&+KCell&)-1)
_STORE_SP
#else
pokel sp&,peekl(sp&+KCell&)-1
_NIP
#endif
#endif
goto xnext
endif
_COMMA?(xbrcsliteralbr&)
_COMPILE_PARSED
goto xnext
xscomma::
// S, \ Forth 5mx
// ( c-addr u -- )
_PUSH?(dp&)
#ifdef _TOS
dp& = dp&+peekl(sp&)+1
#else
#ifdef _ASM
_FETCH_SP
dp& = dp&+MCPeekL&:(sp&+KCell&)+1
#else
dp& = dp&+peekl(sp&+KCell&)+1
#endif
#endif
xsmove::
// smove \ Forth 5mx
// ( c-addr1 u1 c-addr2 -- )
#ifdef _TOS
source& = peekl(sp&+KCell&)
destination& = tos&+1
i& = peekl(sp&) // char count
temp% = i& // keep
temp& = tos& // keep
#else
#ifdef _ASM
_FETCH_SP
source& = MCPeekL&:(sp&+K2Cells&)
destination& = MCPeekL&:(sp&)+1
i& = MCPeekL&:(sp&+KCell&) // char count
temp% = i& // keep
temp& = MCPeekL&:(sp&) // keep
#else
source& = peekl(sp&+K2Cells&)
destination& = peekl(sp&)+1
i& = peekl(sp&+KCell&) // char count
temp% = i& // keep
temp& = peekl(sp&) // keep
#endif
#endif
if destination&<source&
while i&
pokeb destination&,peekb(source&)
destination&++
source&++
i&--
endwh
else
source& = source&+i&
destination& = destination&+i&
while i&
destination&--
source&--
pokeb destination&,peekb(source&)
i&--
endwh
endif
pokeb temp&,temp%
_3DROP
goto xnext
xmove::
// MOVE \ Core
// ( addr1 addr2 u -- )
// :!!! In practice, this does the same as CMOVE
/*
#ifdef _TOS
destination& = peekl(sp&)
source& = peekl(sp&+KCell&)
if destination&<source&
while tos&
pokeb destination&,peekb(source&)
destination&++
source&++
tos&--
endwh
else
source& = source&+tos&
destination& = destination&+tos&
while tos&
destination&--
source&--
pokeb destination&,peekb(source&)
tos&--
endwh
endif
#else
destination& = peekl(sp&+KCell&)
source& = peekl(sp&+K2Cells&)
i& = peekl(sp&)
if destination&<source&
while i&
pokeb destination&,peekb(source&)
destination&++
source&++
i&--
endwh
else
source& = source&+i&
destination& = destination&+i&
while i&
destination&--
source&--
pokeb destination&,peekb(source&)
i&--
endwh
endif
#endif
_3DROP
goto xnext
*/
xcmove::
// CMOVE \ String
// ( c-addr1 c-addr2 u -- )
#ifdef _TOS
source& = peekl(sp&+KCell&)
destination& = peekl(sp&)
while tos&
pokeb destination&,peekb(source&)
destination&++
source&++
tos&--
endwh
_3DROP
#else
source& = peekl(sp&+K2Cells&)
destination& = peekl(sp&+KCell&)
temp& = peekl(sp&)
while temp&
pokeb destination&,peekb(source&)
destination&++
source&++
temp&--
endwh
#ifdef _ASM
_DECREASE
_STORE_SP
#else
_3DROP
#endif
#endif
goto xnext
xcmoveback::
// CMOVE> \ String
// ( c-addr1 c-addr2 u -- )
#ifdef _TOS
source& = peekl(sp&+KCell&)+tos&
destination& = peekl(sp&)+tos&
while tos&
destination&--
source&--
pokeb destination&,peekb(source&)
tos&--
endwh
#else
source& = peekl(sp&+K2Cells&)+peekl(sp&)
destination& = peekl(sp&+KCell&)+peekl(sp&)
temp&=peekl(sp&)
while temp&
destination&--
source&--
pokeb destination&,peekb(source&)
temp&--
endwh
#endif
_3DROP
goto xnext
xfill::
// FILL \ Core
// ( c-addr u b -- )
#ifdef _TOS
i& = peekl(sp&)
temp& = peekl(sp& + KCell&)
while i&
pokeb temp&,tos&
temp&++
i&--
endwh
#else
i& = peekl(sp&+KCell&)
temp& = peekl(sp& + K2Cells&)
char% = peekb(sp&)
while i&
pokeb temp&,char%
temp&++
i&--
endwh
#endif
_3DROP
goto xnext
xlatest::
// latest \ PsiForth
// ( -- nt )
_PUSH?(last_nt&)
goto xnext
ximmediate::
// IMMEDIATE \ Core
// ( -- )
pokeb _CONTROL_BITS_ADDRESS?(last_nt&), _CONTROL_BITS?(last_nt&) or KImmediate%
goto xnext
ximmediateq::
// immediate? \ PsiForth
// ( nt -- flag )
#ifdef _TOS
tos& = (_CONTROL_BITS?(tos&) and KImmediate%) <> 0
#else
pokel sp&,(_CONTROL_BITS?(peekl(sp&)) and KImmediate%) <> 0
#endif
goto xnext
xequal::
// = \ Core
// ( n1 n2 -- flag )
#ifdef _TOS
tos& = (tos&=peekl(sp&))
#else
pokel sp&, (peekl(sp&)=peekl(sp&+KCell&))
#endif
_NIP
goto xnext
xnotequal::
// <> \ Core
// ( n1 n2 -- flag )
#ifdef _TOS
tos& = (tos&<>peekl(sp&))
#else
pokel sp&,(peekl(sp&)<>peekl(sp&+KCell&))
#endif
_NIP
goto xnext
xlessorequal::
// <= \ Forth 5mx
// ( n1 n2 -- flag )
#ifdef _TOS
tos& = (peekl(sp&)<=tos&)
#else
pokel sp&,(peekl(sp&+KCell&)<=peekl(sp&))
#endif
_NIP
goto xnext
xgreaterorequal::
// >= \ Forth 5mx
// ( n1 n2 -- flag )
#ifdef _TOS
tos& = (peekl(sp&)>=tos&)
#else
pokel sp&,(peekl(sp&+KCell&)>=peekl(sp&))
#endif
_NIP
goto xnext
xnot::
// not \ Forth 5mx
x0equal::
// 0= \ Core
// (flag1 -- flag2 )
#ifdef _TOS
tos& = (tos&=0)
#else
pokel sp&,(peekl(sp&)=0)
#endif
goto xnext
x0notequal::
// 0<> \ Core Ext
// (flag1 -- flag2 )
#ifdef _TOS
tos& = (tos&<>0)
#else
pokel sp&, (peekl(sp&)<>0)
#endif
goto xnext
xuless::
// U< \ Core
// ( u1 u2 -- flag )
#ifdef _TOS
temp1 = unsigned:(peekl(sp&))
temp2 = unsigned:(tos&)
tos& = temp1<temp2
#else
temp1 = unsigned:(peekl(sp&+KCell&))
temp2 = unsigned:(peekl(sp&))
pokel sp&, temp1<temp2
#endif
_NIP
goto xnext
xumore::
// U> \ Core Ext
// ( u1 u2 -- flag )
#ifdef _TOS
temp1 = unsigned:(peekl(sp&))
temp2 = unsigned:(tos&)
tos& = temp1>temp2
#else
temp1 = unsigned:(peekl(sp&+KCell&))
temp2 = unsigned:(peekl(sp&))
pokel sp&, temp1>temp2
#endif
_NIP
goto xnext
xless::
// < \ Core
// ( n1 n2 -- flag )
#ifdef _TOS
tos& = (peekl(sp&) < tos&)
#else
pokel sp&, (peekl(sp&+KCell&) < peekl(sp&))
#endif
_NIP
goto xnext
xgreater::
// > \ Core
#ifdef _TOS
tos& = (peekl(sp&) > tos&)
#else
pokel sp&, (peekl(sp&+KCell&) > peekl(sp&))
#endif
_NIP
goto xnext
x0less::
// 0< \ Core
// (flag1 -- flag2 )
#ifdef _TOS
tos& = (tos& < 0)
#else
pokel sp&, (peekl(sp&) < 0)
#endif
goto xnext
x0greater::
// 0> \ Core Ext
// (flag1 -- flag2 )
#ifdef _TOS
tos& = (tos& > 0)
#else
pokel sp&, (peekl(sp&) > 0)
#endif
goto xnext
x0branch::
// 0branch \ PsiForth
// ( flag -- )
// ?!!!
#ifdef _TOS
temp& = tos&
#else
temp& = peekl(sp&)
#endif
_DROP
if temp&
ip& = ip&+KCell&
goto xnext
endif
xbranch::
// branch \ PsiForth
// ?!!!
ip& = ip&+peekl(ip&)+KCell&
goto xnext
xbrofbr::
// (of) \ PsiForth
// ?!!!
// runtime code for OF
#ifdef _TOS
if peekl(sp&) = tos&
#else
if peekl(sp&+KCell&)=peekl(sp&)
#endif
_2DROP
ip& = ip&+KCell&
else
_DROP
ip& = ip&+peekl(ip&)+KCell&
endif
goto xnext
xbrqdobr::
// (?do) \ Forth 5mx
// ( limit first -- )
#ifdef _TOS
if peekl(sp&)=tos&
#else
if peekl(sp&+KCell&)=peekl(sp&)
#endif
_2DROP
ip& = ip&+peekl(ip&)+KCell&
goto xnext
endif
xbrdobr::
// (do) \ PsiForth
// ( limit first -- )
// ( R: -- branch limit first )
temp& = peekl(ip&)
ip& = ip&+KCell&
rp& = rp&-K3Cells&
pokel rp&+K2Cells&,temp&+ip&
#ifdef _TOS
pokel rp&+KCell&,peekl(sp&)
pokel rp&,tos&
#else
pokel rp&+KCell&,peekl(sp&+KCell&)
pokel rp&,peekl(sp&)
#endif
_2DROP
goto xnext
xbrloopbr::
// (loop) \ Forth 5mx
// ( R: branch limit first -- )
// ?!!!
pokel rp&,peekl(rp&)+1
if peekl(rp&) = peekl(rp&+KCell&)
// limit reached
_UNLOOP
ip& = ip&+KCell&
else
ip& = ip&+peekl(ip&)+KCell&
endif
goto xnext
xunloop::
// UNLOOP \ Core
// (R: x1 x2 x3 -- )
_UNLOOP
goto xnext
xbrplusloopbr::
// (+loop) \ Forth 5mx
// ( n -- )
#ifdef _TOS
pokel rp&,peekl(rp&)+tos&
#else
pokel rp&,peekl(rp&)+peekl(sp&)
#endif
_DROP
if peekl(rp&) > (peekl(rp&+KCell&)-1)
// boundary crossed
_UNLOOP
ip& = ip&+KCell&
else
ip& = ip&+peekl(ip&)+KCell&
endif
goto xnext
xbrminusloopbr::
// (-loop) \ Forth 5mx
// ( n -- )
// :!!! *!!! experimental
#ifdef _TOS
pokel rp&,peekl(rp&)-tos&
#else
pokel rp&,peekl(rp&)-peekl(sp&)
#endif
_DROP
if peekl(rp&) < (peekl(rp&+KCell&)+1)
// boundary crossed
_UNLOOP
ip& = ip&+KCell&
else
ip& = ip&+peekl(ip&)+KCell&
endif
goto xnext
xleave::
// LEAVE \ Core
// ( -- )
if state& = KInterpreting&
goto compile_only
endif
_COMMA?(xbrleavebr&)
goto xnext
xbrleavebr::
// (leave) \ Forth 5mx
// ( -- )
// ( R: branch limit index -- )
ip& = peekl(rp&+K2Cells&)
_UNLOOP
goto xnext
xccomma::
// C, \ Core
// ( b -- )
#ifdef _TOS
pokeb dp&,tos& AND 255
#else
pokeb dp&,peekb(sp&)
#endif
dp& = dp&+1
_DROP
goto xnext
xcompilecomma::
// COMPILE, \ Core
// ( xt -- )
if state& = KInterpreting&
goto compile_only
endif
xcomma::
// , \ Core
// ( x -- )
#ifdef _TOS
_COMMA?(tos&)
#else
_COMMA?(peekl(sp&))
#endif
_DROP
goto xnext
xkeyq::
// KEY? \ Facility
// ( -- flag )
_INCREASE_STACK
if keywaiting% = 0
keywaiting% = key
endif
#ifdef _TOS
tos& = (keywaiting%<>0)
#else
pokel sp&, (keywaiting%<>0)
#endif
goto xnext
xkey::
// KEY \ Core
// ( -- b )
_PUSH?(keywaiting%)
#ifdef _TOS
if tos&
keywaiting% = 0
else
tos& = get
endif
#else
if peekl(sp&)
keywaiting% = 0
else
pokel sp&,get
endif
#endif
goto xnext
xemit::
// EMIT \ Core
// ( b -- )
#ifdef _TOS
print chr$(tos&);
#else
print chr$(peekb(sp&));
#endif
_DROP
goto xnext
xemits::
// emits \ PsiForth
// ( b n -- )
#ifdef _TOS
print rept$(chr$(peekb(sp&)),tos&);
#else
print rept$(chr$(peekb(sp&+KCell&)),peekl(sp&));
#endif
_2DROP
goto xnext
xatxy::
// AT-XY \ Facility
// ( u1 u2 -- )
// u1 = x = column
// u2 = y = row
#ifdef _TOS
at peekl(sp&)+1,tos&+1
#else
at peekl(sp&+KCell&)+1,peekl(sp&)+1
#endif
_2DROP
goto xnext
xbracketnumber::
// <# \ Core
// ?!!!
// ( ud -- ud ) ( n ud -- n ud )
#ifdef _TOS
temp& = pad&
pokel temp&,temp&
_INCREASE_STACK
#else
temp& = pad&
pokel temp&,temp&
temp& = peekl(sp&)
_PUSH?(temp&)
#endif
goto xnext
xnumbersign::
// # \ Core
// ?!!!
// ( ud1 -- ud2 )
digit:
goto xnext
xnumbersigns::
// #S \ Core
// ( ud1 -- ud2 )
#ifdef _TOS
while tos&
digit:
endwh
#else
while peekl(sp&)
digit:
endwh
#endif
goto xnext
xnumberbracket::
// #> \ Core
// ?!!!
// ( ud -- c-addr u )
#ifdef _TOS
temp& = pad&
tos& = temp& - peekl(temp&)
pokel sp&,peekl(temp&)
#else
temp& = pad&
pokel sp&, temp& - peekl(temp&)
pokel sp&+KCell&,peekl(temp&)
#endif
goto xnext
xhold::
// HOLD \ Core
// ( char -- )
// ?!!!
#ifdef _TOS
temp& = pad&
hold: (tos&)
#else
temp& = pad&
hold: (peekb(sp&))
#endif
_DROP
goto xnext
xsign::
// SIGN \ Core
// ?!!!
// ( n1 n2 -- )
#ifdef _TOS
if peekl(sp&) < 0
hold:(%-)
endif
#else
if peekl(peekl(sp&+KCell&)) < 0
hold:(%-)
endif
#endif
goto xnext
xudot::
// U. \ Core
// ( u -- )
_PUSH?(0)
temp1$=" " // trailing space
goto udotr2
xudotr::
// U.R / Core Ext
// ( u +n -- )
temp1$="" // trailing space
#ifdef _TOS
udotr2::
temp = unsigned:(peekl(sp&))
temp$="" // output string
do
temp1 = temp
temp = intf(temp1/base&)
temp1 = temp1-temp*base&
temp1 = temp1+%0
temp1 = temp1+(temp1>%9 and 39)
temp$ = chr$(temp1)+temp$
until (temp=0)
print rept$(" ",max(0,tos&-len(temp$)));temp$;temp1$;
#else
udotr2::
temp = unsigned:(peekl(sp&+KCell&))
temp$="" // output string
do
temp1 = temp
temp = intf(temp1/base&)
temp1 = temp1-temp*base&
temp1 = temp1+%0
temp1 = temp1+(temp1>%9 and 39)
temp$ = chr$(temp1)+temp$
until (temp=0)
print rept$(" ",max(0,peekl(sp&)-len(temp$)));temp$;temp1$;
#endif
_2DROP
goto xnext
xdot::
// . \ Core
// ( n -- )
_PUSH?(0)
temp1$=" " // trailing space
goto dotr2
xdotr::
// .R / Core Ext
// ( n1 +n2 -- )
temp1$="" // trailing space
dotr2::
#ifdef _TOS
// temp = unsigned:(peekl(sp&))
temp& = abs(peekl(sp&))
number$="" // output string
do
digit& = temp&
// print digit&;"->";
temp& = digit&/base&
digit& = digit&-temp&*base&
// print digit&;"->";
digit& = digit&+%0
// print "'";chr$(digit&);"'->";
digit& = digit&+(digit&>%9 and 39)
// print "'";chr$(digit&);"'"
number$ = chr$(digit&)+number$
until (temp&=0)
if peekl(sp&)<0
number$ = "-"+number$
endif
print rept$(" ",max(0,tos&-len(number$)));number$;temp1$;
#else
// temp = unsigned:(peekl(sp&+KCell&))
temp& = abs(peekl(sp&+KCell&))
number$="" // output string
do
digit& = temp&
// print digit&;"->";
temp& = digit&/base&
digit& = digit&-temp&*base&
// print digit&;"->";
digit& = digit&+%0
// print "'";chr$(digit&);"'->";
digit& = digit&+(digit&>%9 and 39)
// print "'";chr$(digit&);"'"
number$ = chr$(digit&)+number$
until (temp&=0)
if peekl(sp&+KCell&)<0
number$ = "-"+number$
endif
print rept$(" ",max(0,peekl(sp&)-len(number$)));number$;temp1$;
#endif
_2DROP
goto xnext
xcr::
// CR \ Core
// ( -- )
print
goto xnext
xdotparenthesis::
// .( \ Core Ext
// ( -- )
_PARSE?(41) // 41 = char code of )
// _DEBUG2?(".(")
xtype::
// TYPE \ Core
// ( c-addr u -- )
// print packed$:; // original PsiForth version
// New version without strings (no length limit, although slower):
#ifdef _TOS
temp&=peekl(sp&)
while tos&
print chr$(peekb(temp&));
temp&++
tos&--
endwh
#else
temp&=peekl(sp&+KCell&)
i& = peekl(sp&)
while i&
print chr$(peekb(temp&));
temp&++
i&--
endwh
#endif
_2DROP
goto xnext
xspace::
// SPACE \ Core
// ( -- )
print " ";
goto xnext
xspaces::
// SPACES \ Core
// ( u -- )
#ifdef _TOS
print rept$(" ",tos&);
#else
print rept$(" ",peekl(sp&));
#endif
_DROP
goto xnext
xgcls::
// gcls \ OPL
// ( -- )
gcls
goto xnext
xpage::
// PAGE \ Facility
// ( -- )
cls
xhome::
// home \ PsiForth
at 1,1
goto xnext
xextend::
// extend \ Forth 5mx
// ( -- )
//*!!!
temp$=KExtendFile$
goto include0
xincluded::
// INCLUDED \ File
// ( c-addr u -- )
_GET_PACKED
temp$ = packed$
goto include0
xinclude::
// include \ Forth 5mx
// ( -- )
_PARSED_WORD
temp$ = parsed_word$
include0::
// Input: temp$ = file name
temp$ = whole_path$:(temp$)
include_path$ = only_path$:(temp$)
#ifdef _DSOURCE
if ioopen(file_id%,temp$,KIoOpenModeOpen%+KIoOpenFormatBinary%+KIoOpenAccessRandom%)
#else
if ioopen(file_id%,temp$,KIoOpenModeOpen%+KIoOpenFormatText%)
#endif
_REPORT_ERROR?("can't open "+temp$)
goto xabort
endif
goto includefile0
xincludefile::
// INCLUDE-FILE \ File
// ( fid -- )
#ifdef _TOS
file_id% = tos&
#else
file_id% = peekl(sp&)
#endif
_DROP
include_path$ = path$ // ?!!! why?
includefile0::
// Input: file_id%
#include "forth5mx_inc_save_source.opp"
path$ = include_path$
setpath path$
sourceid& = file_id%
// blk& = 0 :!!!
_INDICATE_SOURCE
#ifdef _DSOURCE
// new way
// Just interpret the input buffer,where the whole file has been read.
// No need for REFILL.
_CALL_XT?(xinterpret&,label01)
#else
// classic way
toin&=ib_len& // for REFILL to load a line of the opened file.
while00::
#include "forth5mx_inc_refill.opp"
// output: successful&
if successful&
_CALL_XT?(xinterpret&,label01)
goto while00 // :!!! use a good control structure here
endif
#endif
if ioclose(file_id%)
_REPORT_ERROR?("error closing source file")
endif
#include "forth5mx_inc_restore_source.opp"
goto xnext
xrefill::
// REFILL \ File Ext
// ( -- flag )
#include "forth5mx_inc_refill.opp"
// output: successful&
_PUSH?(successful&)
goto xnext
xaccept::
// ACCEPT \ Core
// (c-addr +n1 -- +n2 )
#ifdef _TOS
temp$ = lineedit$:("",tos&,KFalse&)
move:(temp$,peekl(sp&))
tos& = len(temp$)
#else
temp$ = lineedit$:("",peekl(sp&),KFalse&)
move:(temp$,peekl(sp&+KCell&))
pokel sp&,len(temp$)
#endif
_NIP
goto xnext
xexpect::
// EXPECT \ Core Ext
// (c-addr +n -- )
#ifdef _TOS
temp$ = lineedit$:("",tos&,KFalse&)
span& = len(temp$) // update SPAN
move:(temp$,peekl(sp&))
#else
temp$ = lineedit$:("",peekl(sp&),KFalse&)
span& = len(temp$) // update SPAN
move:(temp$,peekl(sp&+KCell&))
#endif
_2DROP
goto xnext
xquery::
// QUERY \ Core Ext
// ( -- )
// :!!! no source save and restore!!!
sourceid&=KSourceIDKeyboard%
ib$ = lineedit$:("",KMaxStringLen%,KFalse&)
ib_len& = len(ib$)
toin& = 0
_2DROP // ?!!!
goto xnext
xword::
// WORD \ Core
// ( char -- c-addr )
#ifdef _TOS
delimiter% = tos&
#else
delimiter% = peekb(sp&)
#endif
#ifdef _DSOURCE
string$=""
do
tmp%=LexGet%:(lex&)
until tmp%<>delimiter%
if tmp%<>0
do
string$=string$+chr$(char%) // :!!! test speed, compare to pokeb inside the string
tmp%=LexGet%:(lex&)
until tmp%=delimiter% or tmp%=0
endif
#else
// old way
first_char%=0
len%=0
while peekb(ib_addr&+toin&)=delimiter%
toin&++
endwh
if toin&<ib_len&
first_char% = toin&
while peekb(ib_addr&+toin&)<>delimiter% and toin&<ib_len&
toin&++
endwh
len% = toin&-first_char%
toin&++ // point to the char after the delimiter or after the buffer
endif
#ifdef _DEBUG_WORD
print ">>";ib$;"<<"
print "first_char%+1=";first_char%+1
print "len%=";len%
#endif
string$=mid$(ib$,first_char%+1,len%)
#endif // _DSOURCE
// input: string$
#include "forth5mx_inc_to_sbuffer.opp"
#ifdef _TOS
tos& = peekl(sp&)-1
sp& = sp&+K2Cells&
#else
sp& = sp&+K2Cells&
pokel sp&, peekl(sp&-KCell&)-1
#endif
goto xnext
xparseword::
// parse-word \ Forth 5mx
// ( -- c-addr u )
_PARSED_WORD
string$=parsed_word$
#include "forth5mx_inc_to_sbuffer.opp"
goto xnext
xhere::
// HERE \ Core
// ( -- addr )
_PUSH?(dp&)
goto xnext
xpad::
// PAD \ Core Ext
// ( -- addr )
_PUSH?(pad&)
goto xnext
xallot::
// ALLOT \ Core
// ( n -- )
#ifdef _TOS
dp& = dp&+tos&
#else
dp& = dp&+peekl(sp&)
#endif
_DROP
goto xnext
xcreate::
// CREATE \ Core
// ( "<spaces>name" -- )
_PARSED_WORD
header&:(parsed_word$,0)
_COMMA?(xbrcreatebr&) // (create)
_COMMA?(0) // extra cell used by DOES> .
goto xnext
xbrcreatebr::
// (create) \ Forth 5mx
// ( -- pfa )
// Run time code for words created by CREATE .
_PUSH?(wp&+K2Cells&)
goto xnext
xcolonnoname::
// :NONAME \ Core Ext
// ( -- xt )
dp& = _ALIGNED?(dp&)
_PUSH?(dp&)
goto xcolon0
xcolon::
// : \ Core
// ( -- )
if state& // compiling
goto interpret_only
endif
_PARSED_WORD
// print parsed_word$, // d!!!
header&:(parsed_word$,0)
xcolon0::
_COMMA?(xbrcolonbr&)
xrightbracket::
// ] \ Core
// ( -- )
state& = KTrue&
goto xnext
xsemicolon::
// ; \ Core
// ( -- )
_COMMA?(xexit&)
xleftbracket::
// [ \ Core
// ( -- )
state& = KInterpreting&
goto xnext
xfind::
// FIND \ Core
// ( c-addr -- c-addr 0 | xt 1 | xt -1 )
#ifdef _TOS
nametofind$=peek$(tos&)
#else
nametofind$=peek$(peekl(sp&))
#endif
// input:nametofind$
#include "forth5mx_inc_find.opp"
// output: nt& = nt or 0
_INCREASE_STACK
#ifdef _TOS
if nt&
pokel sp&,_XT?(nt&)
tos& = 1+2*((_CONTROL_BITS?(nt&) and KImmediate%)=0)
else
tos& = 0
endif
#else
if nt&
pokel sp&+KCell&,_XT?(nt&)
pokel sp&,1+2*((_CONTROL_BITS?(nt&) and KImmediate%)=0)
else
pokel sp&, 0
endif
#endif
goto xnext
xfindname::
// find-name \ Gforth
// ( c-addr u -- nt | 0 )
_GET_PACKED
nametofind$=packed$
// input:nametofind$
#include "forth5mx_inc_find.opp"
// output: nt& = nt or 0
_PUSH?(nt&)
goto xnext
xnamefrom::
// name> \ PsiForth
// ( nt -- xt )
#ifdef _TOS
tos& = _XT?(tos&)
#else
pokel sp&, _XT?(peekl(sp&))
#endif
goto xnext
xname::
// name \ PsiForth
// ( nt -- c-addr u )
#ifdef _TOS
sp& = sp&-KCell&
pokel sp&,_NAME_ADDRESS?(tos&)+1
tos& = peekb(_NAME_ADDRESS?(tos&))
#else
temp&=peekl(sp&)
_INCREASE_STACK
pokel sp&+KCell&,_NAME_ADDRESS?(temp&)+1
pokel sp&,peekb(_NAME_ADDRESS?(temp&))
#endif
goto xnext
xdotname::
// .name \ PsiForth
// ( nt -- )
#ifdef _TOS
print _NAME?(tos&);
#else
print _NAME?(peekl(sp&));
#endif
_DROP
goto xnext
xdepth::
// DEPTH \ Core
// ( -- +n )
#ifdef _TOS
_PUSH?(_DEPTH)
#else
_PUSH?(_DEPTH-1)
#endif
goto xnext
xcatch::
// CATCH \ Exception
// It does not the same in ANS: ?!!!
_2INCREASE_RSTACK
pokel rp&,ip&
pokel rp&+KCell&,sp&
ip& = xthrow0&+KCell&
xexecute::
// EXECUTE \ Core
// ( i*x xt -- j*x )
#ifdef _TOS
wp& = tos&
#else
wp& = peekl(sp&)
#endif
_DROP
goto xvector
xthrow::
// THROW \ Exception
// ( R: x -- )
// It does not the same in ANS: ?!!!
_RDROP
goto xthrow1
xthrow0::
#ifdef _TOS
tos& = 0
#else
pokel sp&,0
#endif
xthrow1::
ip& = peekl(rp&)
sp& = peekl(rp&+KCell&)
_2RDROP
goto xnext
xnumberq::
// number? \ PsiForth
// ( c-addr u -- flag )
_GET_PACKED
_PUSH?(numberq%:(packed$))
goto xnext
xnumber::
// number \ PsiForth
// ( c-addr u -- n )
_GET_PACKED
_PUSH?(number&:(packed$))
goto xnext
xqabort::
// ?abort \ Forth 5mx
// ( flag c-addr u -- )
_GET_PACKED
#ifdef _TOS
temp& = tos&
#else
temp& = peekl(sp&)
#endif
_DROP
if temp&
packed$ = gen$(temp&,3)+" "+packed$
goto error0
endif
goto xnext
xerror::
// error \ PsiForth
// ?!!!
// ( i*x c-addr u -- )
_GET_PACKED
error0::
// Input: packed$ = error message
_REPORT_ERROR?(packed$)
xabort::
// ABORT \ Core
// ( i*x -- ) ( R: j*x -- )
xquit::
// QUIT \ Core Ext
// ( i*x -- ) ( R: j*x -- )
sp& = sp0&
rp& = rp0&
state& = KInterpreting&
// print "let's close all" // *!!!
// press_key:
while source_recursion% >1
// print "source_recursion% =",source_recursion% // *!!!
// press_key:
if sourceid&>0
// print "closing sourceid&=",sourceid& // *!!!
// press_key:
if ioclose(sourceid&)
_REPORT_ERROR?("error closing source file in QUIT")
endif
endif
#include "forth5mx_inc_restore_source.opp"
endwh
source_recursion%=1
#ifdef _DSOURCE
_NEW_TERMINAL_IB
#else
sourceid&=KSourceIDKeyboard%
#endif
do
// _DEBUG?("in QUIT before refill")
#include "forth5mx_inc_refill.opp"
// output: successful&
// _DEBUG?("in QUIT after refill, before INTERPRET")
_CALL_XT?(xinterpret&,label02)
// _DEBUG?("in QUIT after INTERPRET")
_PROMPT
until KFalse% // endless loop
xdebugnumber::
// debug# \ Forth 5mx
// ( n -- )
#ifdef _TOS
temp& = tos&
#else
temp& = peekl(sp&)
#endif
_DROP
_DEBUG?(gen$(temp&,7))
// output: aborted%
if aborted%
goto xabort
endif
goto xnext
xdebug::
// debug \ Forth 5mx
// ( -- )
_DEBUG?("")
// output: aborted%
if aborted%
goto xabort
endif
goto xnext
xbrdebugquotebr::
// (debug") \ Forth 5mx
// ( c-addr u -- )
_GET_PACKED
_DEBUG?(packed$)
// output: aborted%
if aborted%
goto xabort
endif
goto xnext
xdebugquote::
// debug" \ Forth 5mx
// ( "<spaces>name<quote>" -- )
_PARSED?(34) // 34 = code of "
if state& // compiling
_COMMA?(xbrsliteralbr&)
_COMPILE_PARSED
_COMMA?(xbrdebugquotebr&)
goto xnext
endif
_DEBUG?(parsed$)
// output: aborted%
if aborted%
goto xabort
endif
goto xnext
xprompt::
// prompt \ PsiForth
// ( -- )
_PROMPT
goto xnext
xgat::
// gat \ OPL
// ( u1 u2 -- )
// u1 = x
// u2 = y
#ifdef _TOS
gat peekl(sp&),tos&
#else
gat peekl(sp&+KCell&),peekl(sp&)
#endif
_2DROP
goto xnext
xgline::
// gline \ OPL
// ( u1 u2 -- )
// u1 = x
// u2 = y
#ifdef _TOS
glineto peekl(sp&),tos&
#else
glineto peekl(sp&+KCell&),peekl(sp&)
#endif
_2DROP
goto xnext
xpostpone::
// POSTPONE \ Core
// Compile time: ( <stream> -- )
if state& = KInterpreting&
print "POSTPONE no está en compilación"
goto compile_only
endif
_PARSED_WORD
nametofind$ = parsed_word$
//input: nametofind$
#include "forth5mx_inc_find.opp"
// output: nt& = nt or 0
if nt&=0
_REPORT_ERROR?("not found")
goto xabort
endif
if (_CONTROL_BITS?(nt&) and KImmediate%) = 0
_COMMA?(xcompile&)
endif
_COMMA?(_XT?(nt&))
goto xnext
xcompile::
// COMPILE \ Not ANS
// ( -- )
if state& = KInterpreting&
goto compile_only
endif
pokel dp&,peekl(ip&)
ip& = ip&+KCell&
dp& = dp&+KCell&
goto xnext
xbrcompilebr::
// [COMPILE] \ Core Ext
if state& = KInterpreting&
goto compile_only
endif
_PARSED_WORD
nametofind$ = parsed_word$
// input: nametofind$
#include "forth5mx_inc_find.opp"
// output: nt& = nt or 0
if nt&=0
_REPORT_ERROR?("not found")
goto xabort
endif
_COMMA?(_XT?(nt&))
goto xnext
xfont::
// font \ OPL
// ( u1 u2 -- )
#ifdef _TOS
font% = peekl(sp&)
fontattr% = tos&
#else
font% = peekl(sp&+KCell&)
fontattr% = peekl(sp&)
#endif
setfont:(font%,fontattr%)
_2DROP
goto xnext
xbold::
// bold \ OPL
// ( -- )
setfont:(font%,fontattr% or 1)
goto xnext
xthin::
// thin \ OPL
// ( -- )
setfont:(font%,0)
goto xnext
xgbox::
// gbox \ OPL
// ( u1 u2 -- )
// u1 = width
// u2 = height
#ifdef _TOS
gbox peekl(sp&),tos&
#else
gbox peekl(sp&+KCell&),peekl(sp&)
#endif
_2DROP
goto xnext
xgcircle::
// gcircle \ OPL
// ( n flag -- )
// n = radius
// flag = fill?
#ifdef
gcircle peekl(sp&),tos&
#else
gcircle peekl(sp&+KCell&),peekl(sp&)
#endif
_2DROP
goto xnext
xgcolor::
// gcolor \ OPL
// ( n1 n2 n3 -- )
// n1 = red
// n2 = green
// n3 = blue
#ifdef _TOS
gcolor peekl(sp&+KCell&),peekl(sp&),tos&
#else
gcolor peekl(sp&+K2Cells&),peekl(sp&+KCell&),peekl(sp&)
#endif
_3DROP
goto xnext
xgellipse::
// gellipse \ OPL
// ( n1 n2 flag -- )
// n1 = horizontal radius
// n2 = vertical radius
// flag = fill?
#ifdef _TOS
gellipse peekl(sp&+KCell&),peekl(sp&),tos&
#else
gellipse peekl(sp&+K2Cells&),peekl(sp&+KCell&),peekl(sp&)
#endif
_3DROP
goto xnext
xgfill::
// gfill \ OPL
// ( n1 n2 n3 -- )
// n1 = width
// n2 = height
// n3 = graphics mode
#ifdef _TOS
gfill peekl(sp&+KCell&),peekl(sp&),tos&
#else
gfill peekl(sp&+K2Cells&),peekl(sp&+KCell&),peekl(sp&)
#endif
_3DROP
goto xnext
xgmode::
// gmode \ OPL
// ( n -- )
// n = 0 = pixels will be set
// n = 1 = pixels will be cleared
// n = 2 = pixels will be inverted
#ifdef _TOS
ggmode tos&
#else
ggmode peekl(sp&)
#endif
_DROP
goto xnext
xgmove::
// gmove \ OPL
// ( n1 n2 -- )
// n1 = x offset
// n2 = y offset
#ifdef _TOS
gmove peekl(sp&),tos&
#else
gmove peekl(sp&+KCell&),peekl(sp&)
#endif
_2DROP
goto xnext
xgxy::
// gxy \ OPL
// ( -- n1 n2 )
// n1 = x
// n2 = y
_2INCREASE_STACK
#ifdef _TOS
pokel sp&,gx
tos& = gy
#else
pokel sp&+KCell&,gx
pokel sp&,gy
#endif
goto xnext
xtasks::
// tasks \ OPL
DisplayTaskList:
goto xnext
xlookup::
// lookup \ PsiForth
// ?!!!
#ifdef _TOS
i& = peekl(tos&)
temp& = tos&+KCell&
tos& = 0
while i& and (tos&=0)
if peekl(temp&) = peekl(sp&)
tos& = peekl(temp&+KCell&)
endif
i&--
temp& = temp&+K2Cells&
endwh
#else
i& = peekl(peekl(sp&))
temp& = peekl(sp&)+KCell&
pokel sp&, 0
while i& and (peekl(sp&)=0)
if peekl(temp&) = peekl(sp&+KCell&)
pokel sp&, peekl(temp&+KCell&)
endif
i&--
temp& = temp&+K2Cells&
endwh
#endif
_NIP
goto xnext
xcolormode::
// colormode \ OPL
// ( n -- )
// n = 0 = 2-colour mode
// n = 1 = 4-colour mode (default)
// n = 2 = 16-color mode
#ifdef _TOS
defaultwin tos&
#else
defaultwin peekl(sp&)
#endif
_DROP
goto xnext
xbeep::
// ?!!!
// beep \ OPL
// ( n1 n2 -- )
// n1 = time = 1/32 seconds
// n2 = pitch = 512/(pitch+1) KHz
// beep (tos&-1)/50+1,512000/(peekl(sp&)+1) // ?!!!
#ifdef _TOS
beep peekl(sp&),tos&
#else
beep peekl(sp&+KCell&),peekl(sp&)
#endif
_2DROP
goto xnext
xbusy::
// busy \ OPL
// ( c-addr u -- )
_GET_PACKED
indicate:(packed$)
goto xnext
xindicator::
// indicator \ PsiForth
// ( -- c-addr u )
_2INCREASE_STACK
#ifdef _TOS
pokel sp&,addr(indicator$)+1
tos& = len(indicator$)
#else
pokel sp&+KCell&,addr(indicator$)+1
pokel sp&,len(indicator$)
#endif
goto xnext
xdays::
// days \ OPL
// ( n1 n2 n3 -- )
#ifdef _TOS
tos& = days(peekl(sp&+KCell&),peekl(sp&),tos&)
sp& = sp&+K2Cells&
#else
temp& = days(peekl(sp&+K2Cells&),peekl(sp&+KCell&),peekl(sp&))
_2DROP
pokel sp&,temp&
#endif
goto xnext
xday::
// day \ OPL
// ( -- n )
_PUSH?(day)
goto xnext
xmonth::
// month \ OPL
// ( -- n )
_PUSH?(month)
goto xnext
xyear::
// year \ OPL
// ( -- n )
_PUSH?(year)
goto xnext
xhour::
// hour \ OPL
// ( -- n )
_PUSH?(hour)
goto xnext
xminute::
// minute \ OPL
// ( -- n )
_PUSH?(minute)
goto xnext
xsecond::
// second \ OPL
// ( -- n )
_PUSH?(second)
goto xnext
xscreen::
// screen \ OPL
// ( n1 n2 n3 n4 -- )
// n1 = width
// n2 = height
// n3 = x = column
// n4 = y = line
#ifdef _TOS
screen peekl(sp&+K2Cells&),peekl(sp&+KCell&),peekl(sp&),tos&
tos& = peekl(sp&+K3Cells&)
sp& = sp&+K4Cells&
#else
screen peekl(sp&+K3Cells&),peekl(sp&+K2Cells&),peekl(sp&+KCell&),peekl(sp&)
sp& = sp&+K4Cells&
#endif
goto xnext
xscreeninfo::
// screeninfo \ OPL
// ( -- n1 n2 n3 n4 n5 n6 n7 n8 n9 n10 )
// ?!!!
#ifdef _TOS
sp& = sp& - 10*KCell&
pokel sp&+9*KCell&,tos&
screeninfo screeninfo%()
pokel sp&+8*KCell&,screeninfo%(10)
pokel sp&+7*KCell&,screeninfo%(9)
pokel sp&+K6Cells&,screeninfo%(8)
pokel sp&+K5Cells&,screeninfo%(7)
pokel sp&+K4Cells&,screeninfo%(6)
pokel sp&+K3Cells&,screeninfo%(5)
pokel sp&+K2Cells&,screeninfo%(4)
pokel sp&+KCell&,screeninfo%(3)
pokel sp&,screeninfo%(2)
tos& = screeninfo%(1)
#else
sp& = sp& - 10*KCell&
screeninfo screeninfo%()
pokel sp&+9*KCell&,screeninfo%(10)
pokel sp&+8*KCell&,screeninfo%(9)
pokel sp&+7*KCell&,screeninfo%(8)
pokel sp&+K6Cells&,screeninfo%(7)
pokel sp&+K5Cells&,screeninfo%(6)
pokel sp&+K4Cells&,screeninfo%(5)
pokel sp&+K3Cells&,screeninfo%(4)
pokel sp&+K2Cells&,screeninfo%(3)
pokel sp&+KCell&,screeninfo%(2)
pokel sp&,screeninfo%(1)
#endif
goto xnext
xsetcontrast::
// setcontrast \ OPL
// ( n -- )
#ifdef _TOS
setdisplaycontrast:(tos&)
#else
setdisplaycontrast:(peekl(sp&))
#endif
_DROP
goto xnext
xweek::
// week \ OPL
// ( -- n )
_PUSH?(week(day,month,year))
goto xnext
xrp::
// rp \ PsiForth
// ( -- addr )
_PUSH?(rp&)
goto xnext
xsp::
// sp \ PsiForth
// ( -- addr )
_PUSH?(sp&)
// this PsiForth word returned the address of the element under top of stack
goto xnext
xr0::
//
// r0 \ PsiForth
// ( -- addr )
_PUSH?(rp0&)
goto xnext
xs0::
// s0 \ PsiForth
// ( -- addr )
_PUSH?(sp0&)
goto xnext
xqcompiling::
// ?compiling \ PsiForth
// ( -- )
if state& = KInterpreting&
goto compile_only
endif
goto xnext
xqexecuting::
// ?executing \ PsiForth
// ( -- )
if state& // compiling
goto interpret_only
endif
goto xnext
xnegate::
// NEGATE \ Core
// ( n -- -n )
#ifdef _TOS
tos& = (not tos&) + 1
#else
pokel sp&,(not peekl(sp&)) + 1
#endif
goto xnext
xinvert::
// INVERT \ Core
// ( x1 -- x2 )
#ifdef _TOS
tos& = not tos&
#else
pokel sp&,not peekl(sp&)
#endif
goto xnext
xunused::
// UNUSED \ Core Ext
// ( -- u )
_PUSH?((sp0& - KStackSize&) - dp&)
goto xnext
xplay::
// play \ OPL
// ( c-addr u -- )
// ?!!!
_GET_PACKED
playsound:(packed$,volume&)
goto xnext
x2over::
// 2OVER \ Core
// ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 )
_2INCREASE_STACK
#ifdef _TOS
pokel sp&,peekl(sp&+K4Cells&)
tos& = peekl(sp&+K3Cells&)
#else
pokel sp&+KCell&,peekl(sp&+K5Cells&)
pokel sp&,peekl(sp&+K4Cells&)
#endif
goto xnext
x2swap::
// 2SWAP \ Core
// ( x1 x2 x3 x4 -- x3 x4 x1 x2 )
#ifdef _TOS
temp& = tos&
tos& = peekl(sp&+KCell&)
pokel sp&+KCell&,temp&
temp& = peekl(sp&+K2Cells&)
pokel sp&+K2Cells&,peekl(sp&)
pokel sp&,temp&
#else
temp& = peekl(sp&)
pokel sp&, peekl(sp&+K2Cells&)
pokel sp&+K2Cells&,temp&
temp& = peekl(sp&+K3Cells&)
pokel sp&+K3Cells&,peekl(sp&+KCell&)
pokel sp&+KCell&,temp&
#endif
goto xnext
xdump::
// DUMP \ Tools
// ( addr +n -- )
print
#ifdef _TOS
dump:(peekl(sp&),tos&)
#else
dump:(peekl(sp&+KCell&),peekl(sp&))
#endif
_2DROP
goto xnext
xrenamefile::
// RENAME-FILE \ File Ext
// ( c-addr1 u1 c-addr2 u2 -- ior )
// :!!! ior is not yet calculated
_GET_PACKED
temp2$ = packed$
_GET_PACKED
rename packed$,temp2$
_PUSH?(KFalse&) // false ior :!!!
goto xnext
xcreatefile::
// CREATE-FILE \ Core
// ( c-addr u fam -- fileid ior )
#ifdef _TOS
tos& = tos& and $ff0 or KIoOpenModeReplace% or KIoOpenAccessUpdate%
#else
pokel sp&, peekl(sp&) and $ff0 or KIoOpenModeReplace% or KIoOpenAccessUpdate%
#endif
xopenfile::
// OPEN-FILE \ File
// ( c-addr u fam -- fileid ior )
#ifdef _TOS
fam% = tos&
_DROP
_GET_PACKED
_2INCREASE_STACK
tos& = ioopen(temp%,packed$,fam%)
pokel sp&,temp% // fileid
#else
fam% = peekl(sp&)
_DROP
_GET_PACKED
_2INCREASE_STACK
pokel sp&, ioopen(temp%,packed$,fam%)
pokel sp&+KCell&,temp% // fileid
#endif
goto xnext
xclosefile::
// CLOSE-FILE \ File
// ( fileid -- ior )
#ifdef _TOS
tos& = ioclose(tos&)
#else
pokel sp&, ioclose(peekl(sp&))
#endif
goto xnext
xfilestatus::
// FILE-STATUS \ File Ext
// ( c-addr u -- x ior )
_GET_PACKED
_2INCREASE_STACK
#ifdef _TOS
if exist(filename$)
temp0% = iabs(isreadonly&:(packed$))
temp1% = iabs(ishidden&:(packed$))
temp2% = iabs(issystem&:(packed$))
pokel(sp&),temp0%+2*temp1%+4*temp2%
tos& = 0
else
tos& = -33 // "File does not exist" OPL error code
endif
#else
if exist(filename$)
temp0% = iabs(isreadonly&:(packed$))
temp1% = iabs(ishidden&:(packed$))
temp2% = iabs(issystem&:(packed$))
pokel(sp&+KCell&),temp0%+2*temp1%+4*temp2%
pokel sp&,0
else
pokel sp&, -33 // "File does not exist" OPL error code
endif
#endif
goto xnext
xreadline::
// READ-LINE \ File
// ( c-addr u1 fileid -- u2 flag ior )
#ifndef _DEBUG_DSOURCE // d!!!
// Note from the OPL documentation for files opened in text mode:
// If maxLen% exceeds the current record length, data only up to the end of the record is read into the buffer. No error is returned and the file position is set to the next record.
// If a record is longer than maxLen%, the error value ‘Record too large’ (-43) is returned. In this case the data read is valid but is truncated to length maxLen%, and the file position is set to the next record.
// Note from the OPL documentation for files opened in binary mode:
// If you request more bytes than are left in the file, the number of bytes actually read (even zero) will be less than the number requested.
// So if ret%<maxLen%, end of file has been reached. No error is returned by IOREAD in this case, but the next IOREAD would return the error value ‘End of file’ (-36).
// First version, for files opened in text mode:
// tos& = ioread(tos&,peekl(sp&+KCell&),peekl(sp&))
// pokel sp&+KCell&,tos&*iabs(tos&>=0) // u2
// pokel sp&,tos&<>-36 // flag
// tos& = tos&*iabs(tos&<0 and tos&<>-36) // ior
// goto xnext
// Second version, for files opened in binary mode:
#ifdef _TOS
temp& = tos& // fileid
a1& = peekl(sp&+KCell&)
u1& = peekl(sp&)
#else
temp& = peekl(sp&) // fileid
a1& = peekl(sp&+K2Cells&)
u1& = peekl(sp&+KCell&)
#endif
u2& = 0 // char count
temp1& = KFalse& // line terminator first char found?
temp2& = -1 // offset
do
#ifdef _TOS
tos& = ioread(temp&,a1&+u2&,1)
if tos&<0
#else
pokel sp&, ioread(temp&,a1&+u2&,1)
if peekl(sp&)<0
#endif
break
endif
temp1$ = chr$(peekb(a1&+u2&)) // char read
if temp1&
// The first line terminator char was found in the past loop.
if temp1$<>right$(line_terminator$,1)
// This char is not the second terminator char.
// It can be the first line terminator char again or any other char.
ioseek(temp&,3,temp2&) // one char back
endif
break
else
// The first line terminator char was not found yet.
if temp1$=left$(line_terminator$,1)
// This char is the first line terminator char.
temp1&=KTrue&
elseif temp1$=right$(line_terminator$,1)
// This char is the second line terminator char.
break
else
// This char is not part of the line terminator.
u2&=u2&+1
endif
endif
until u2&=u1&
#ifdef _TOS
pokel sp&+KCell&,u2& // u2
pokel sp&,tos&<>-36 // flag
tos& = tos&*iabs(tos&<0 and tos&<>-36) // ior
#else
pokel sp&+K2Cells&,u2& // u2
pokel sp&+KCell&,peekl(sp&)<>-36 // flag
pokel sp&,peekl(sp&)*iabs(peekl(sp&)<0 and peekl(sp&)<>-36) // ior
#endif
#endif // _DEBUG_DSOURCE
goto xnext
xreadfile::
// READ-FILE \ File
// ( c-addr u1 fileid -- u2 ior )
// Notes from the OPL documentation:
// No more than 16K bytes can be read at a time.
// And for files opened in binary mode:
// If you request more bytes than are left in the file,
// the number of bytes actually read (even zero)
// will be less than the number requested.
// So if ret%<maxLen%, end of file has been reached.
// No error is returned by IOREAD in this case,
// but the next IOREAD would return the error value ‘End of file’ (-36).
#ifdef _TOS
// tos& = ioread(tos&,peekl(sp&+KCell&),peekl(sp&))
tos& = unlimited_ioread&:(tos&,peekl(sp&+KCell&),peekl(sp&))
_NIP
pokel sp&,tos&*iabs(tos&>=0) // u2
tos& = tos&*iabs(tos&<0) // ior
#else
// temp& = ioread(peekl(sp&),peekl(sp&+K2Cells&),peekl(sp&+KCell&))
temp& = unlimited_ioread&:(peekl(sp&),peekl(sp&+K2Cells&),peekl(sp&+KCell&))
_DROP
pokel sp&+KCell&,temp&*iabs(temp&>=0) // u2
pokel sp&,temp&*iabs(temp&<0) // ior
#endif
goto xnext
xwriteline::
// WRITE-LINE \ File
// ( c-addr u fileid -- ior )
// Note from the OPL documentation:
// When a file is opened as a binary file, the data written by IOWRITE overwrites data at the current position.
// When a file is opened as a text file, IOWRITE writes a single record; the closing CR/LF is automatically added.
// All files (but the source files) are opened by Forth 5mx in binary mode,
// so we have to write the line terminator.
#ifdef _TOS
temp& = tos&
tos& = iowrite(temp&,peekl(sp&+KCell&),peekl(sp&))
sp& = sp& + K2Cells&
if not tos&
tos& = iowrite(temp&,addr(line_terminator$)+1,len(line_terminator$))
endif
#else
temp1& = peekl(sp&)
temp2& = iowrite(temp1&,peekl(sp&+K2Cells&),peekl(sp&+KCell&))
if not temp2&
temp2& = iowrite(temp1&,addr(line_terminator$)+1,len(line_terminator$))
endif
_2DROP
pokel sp&,temp2&
#endif
goto xnext
xwritefile::
// WRITE-FILE \ File
// ( c-addr u fileid -- ior )
// Note from the OPL documentation:
// When a file is opened as a binary file, the data written by IOWRITE overwrites data at the current position.
// When a file is opened as a text file, IOWRITE writes a single record; the closing CR/LF is automatically added.
// All files are opened by Forth 5mx in binary mode,
// so write-file doesn't add the line terminator. That is right.
#ifdef _TOS
tos& = iowrite(tos&,peekl(sp&+KCell&),peekl(sp&))
sp& = sp& + K2Cells&
#else
temp& = iowrite(peekl(sp&),peekl(sp&+K2Cells&),peekl(sp&+KCell&))
_2DROP
pokel sp&,temp&
#endif
goto xnext
xseekfile::
// seek-file \ OPL
// ( n1 n2 fileid -- +n ior )
// ( offset mode fileid -- absolute-position ior )
// Mode can be one of these:
// 1= Set position in a binary file to the absolute value specified in offset, with 0 for the first byte in the file
// 2= Set position in a binary file to offset bytes from the end of the file
// 3= Set position in a binary file to offset bytes relative to the current position
// 6= Rewind a text file to the first record. offset is not used, but you must still pass it as a argument, for compatibility with the other cases.
#ifdef _TOS
temp1& = peekl(sp&+KCell&) // offset
temp& = ioseek(tos&,peekl(sp&),temp1&)
_NIP
pokel sp&,temp1&
tos& = temp&
#else
temp1& = peekl(sp&+K2Cells&) // offset
temp& = ioseek(peekl(sp&),peekl(sp&+KCell&),temp1&)
_DROP
pokel sp&+KCell&,temp1&
pokel sp&,temp&
#endif
goto xnext
xmkdir::
// MKDIR \ OPL
// ( c-addr u -- )
_GET_PACKED
mkdir file_name$:(packed$)
goto xnext
xparsefile::
// parse-file \ PsiForth
// ?!!!
// ( handle addr n delimiter -- n status )
#ifdef _TOS
temp% = tos& // delimiter
i& = peekl(sp&) // max len
temp& = peekl(sp& + KCell&) // addr
_NIP
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&
#else
print "SP CODE MISSING"
#endif
goto xnext
xdeletefile::
// DELETE-FILE \ File
// ( c-addr u -- ior )
_GET_PACKED
delete packed$
_PUSH?(KFalse&) // false ior
goto xnext
xdirectory::
// directory \ PsiForth, OPL dir$
// ( c-addr u -- )
_GET_PACKED
print
packed$ = dir$(packed$)
while len(packed$)
print packed$
packed$ = dir$("")
endwh
goto xnext
xdocode::
// ?!!!
print "would execute code at addr",wp&+KCell&
goto xnext
xpath::
// path \ Forth 5mx
// ( -- c-addr u )
_2INCREASE_STACK
#ifdef _TOS
pokel sp&,addr(path$)+1
tos& = len(path$)
#else
pokel sp&+KCell&,addr(path$)+1
pokel sp&,len(path$)
#endif
goto xnext
xchdirq::
// chdir" \ Forth 5mx
// ( -- )
_PARSED?(34) // 34 = code of "
// :!!! ?!!! _PARSE could be used here instead, and save the following two lines:
packed$ = parsed$
goto xchdir0::
xchdir::
// chdir \ Forth 5mx
// ( c-addr u -- )
_GET_PACKED
xchdir0::
path$=whole_path$:(packed$)
if right$(path$,1)<>"\" // :!!! perhaps with temp$ before whole_path$
path$=path$+"\"
endif
goto xnext
xdinit::
// dinit \ OPL
// ( c-addr u n -- )
#ifdef _TOS
i& = tos&
#else
i& = peekl(sp&)
#endif
_DROP
_GET_PACKED
dinit packed$,i&
nbuttons% = 0
goto xnext
xdbutton::
// dbutton \ OPL
// ?!!!
nbuttons% = nbuttons% + 1
#ifdef _TOS
dbutton%(nbuttons%) = tos&
#else
dbutton%(nbuttons%) = peekl(sp&)
#endif
_DROP
_GET_PACKED
dbutton$(nbuttons%) = packed$
goto xnext
xdbuttons::
// dbuttons \ OPL
// ?!!!
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::
// dcheckbox \ OPL
// ?!!!
#ifdef _TOS
temp% = tos&
#else
temp% = peekl(sp&)
#endif
_DROP
_GET_PACKED
dcheckbox temp%,packed$
goto xnext
xdialog::
// dialog \ OPL
// ?!!!
_PUSH?(dialog)
goto xnext
xdposition::
// position \ OPL
// ?!!!
#ifdef _TOS
dposition peekl(sp&),tos&
#else
dposition peekl(sp&+KCell&),peekl(sp&)
#endif
_2DROP
goto xnext
xdtext::
// dtext \ OPL
// ?!!!
#ifdef _TOS
i& = tos&
#else
i& = peekl(sp&)
#endif
_DROP
_GET_PACKED
temp$ = packed$
_GET_PACKED
dtext temp$,packed$,i&
goto xnext
xdchoice::
// dchoice \ OPL
// ?!!!
#ifdef _TOS
temp% = tos&
#else
temp% = peekl(sp&)
#endif
_DROP
_GET_PACKED
temp$=packed$
_GET_PACKED
dchoice temp%,temp$,packed$
goto xnext
xallocate::
// ALLOCATE \ Memory
// ( u -- a-addr ior )
#ifdef _TOS
sp& = sp&-KCell&
temp& = alloc(tos&)
pokel(sp&), temp&
tos& = (temp&=0)
#else
temp& = alloc(peekl(sp&))
_INCREASE_STACK
pokel(sp&+KCell&), temp&
pokel sp&, (temp&=0)
#endif
goto xnext
xresize::
// RESIZE \ Memory
// ( a-addr1 u -- a-addr2 ior )
#ifdef _TOS
temp& = realloc(peekl(sp&),tos&)
pokel (sp&),temp&
tos& = (temp&=0)
#else
temp& = realloc(peekl(sp&+KCell&),peekl(sp&))
pokel sp&+KCell&,temp&
pokel sp&, (temp&=0)
#endif
goto xnext
xfree::
// FREE \ Memory
// ( a-addr -- ior )
#ifdef _TOS
freealloc tos&
tos& = 0
#else
freealloc peekl(sp&)
pokel sp&,0
#endif
goto xnext
xgetevent::
// getevent \ OPL
// ?!!!
geteventa32 eventstat%,eventbuf&()
goto xnext
xevent::
// event \ OPL
// ?!!!
#ifdef _TOS
if tos&
tos& = eventbuf&(tos&)
else
tos& = eventstat%
eventstat% = 0
endif
#else
if peekl(sp&)
pokel sp&,eventbuf&(peekl(sp&))
else
pokel sp&, eventstat%
eventstat% = 0
endif
#endif
goto xnext
xalign::
// ALIGN \ Core
// ( -- )
dp& = _ALIGNED?(dp&)
goto xnext
xaligned::
// ALIGNED \ Core
// ( addr -- a-addr )
#ifdef _TOS
tos& = _ALIGNED?(tos&)
#else
pokel sp&,_ALIGNED?(peekl(sp&))
#endif
goto xnext
xrun::
// run \ OPL
// ( c-addr u -- )
// ?!!!
_GET_PACKED
runapp&:(packed$,"","",2)
goto xnext
xbacklight::
// backlight \ OPL
// ( flag -- )
#ifdef _TOS
setbacklighton:((tos&<>0) and 1)
#else
setbacklighton:((peekl(sp&)<>0) and 1)
#endif
_DROP
goto xnext
xbacklightq::
// backlight? \ OPL
// ( -- flag )
_PUSH?(backlighton&:)
goto xnext
xrnd::
// rnd \ OPL
// ( x1 -- x2 )
// ?!!!
#ifdef _TOS
tos& = int(rnd*tos&)
#else
pokel sp&,int(rnd*peekl(sp&))
#endif
goto xnext
xthread::
// thread
// ( +u1 -- u2 )
#ifdef _TOS
tos& = thread&(tos&)
#else
pokel sp&,thread&(peekl(sp&))
#endif
goto xnext
xdown::
// down \ OPL
// ( -- )
off
goto xnext
xbye::
// BYE
// ( -- )
bye:
xminustrailing::
// -TRAILING \ String
// ( c-addr u1 -- c-addr2 u2 )
// 2005.01.13, version with strings (max 255 chars):
/*
pad$=packed$:
while right$(pad$,1)=" "
pad$=left$(pad$,len(pad$)-1)
endwh
string$ = pad$
addr& = dp&+KPadSize&
// input: string$ to store
// input: addr& to store the string in
// stack output: ( -- c-addr u )
_STORE_STRING
goto xnext
*/
// 2005.01.28, version without strings (no length limit):
#ifdef _TOS
temp& = peekl(sp&)-1
i% = tos&
#else
temp& = peekl(sp&+KCell&)-1
i%=peekl(sp&)
#endif
// while i% and (peekb(temp&+i%)=KKeySpace%)
while i% and CharIsSpace%:(peekb(temp&+i%))
i% = i% - 1
endwh
#ifdef _TOS
tos& = i%
#else
pokel sp&,i%
#endif
goto xnext
xsearch::
// SEARCH \ String
// ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag )
// version with strings (max 255 chars):
#ifdef _TOS
a1&=peekl(sp&+K2Cells&)
u1&=peekl(sp&+KCell&)
u2&=tos&
_GET_PACKED
temp2$ = packed$ // searched string
_GET_PACKED
temp1$ = packed$ // longer string to search in
temp& = loc(temp1$,temp2$)
sp& = sp&-K3Cells&
pokel sp&+K2Cells&,tos&
if temp&
pokel sp&+KCell&,a1&+temp&-1
pokel sp&,u1&-temp&+1
tos& = KTrue&
else
pokel sp&+KCell&,a1&
pokel sp&,u1&
tos& = KFalse&
endif
#else
a1&=peekl(sp&+K3Cells&)
u1&=peekl(sp&+K2Cells&)
u2&=peekl(sp&)
_GET_PACKED
temp2$ = packed$ // searched string
_GET_PACKED
temp1$ = packed$ // longer string to search in
temp& = loc(temp1$,temp2$)
sp& = sp&-K3Cells&
if temp&
pokel sp&+K2Cells&,a1&+temp&-1
pokel sp&+KCell&,u1&-temp&+1
pokel sp&,KTrue&
else
pokel sp&+K2Cells&,a1&
pokel sp&+KCell&,u1&
pokel sp&,KFalse&
endif
#endif
goto xnext
xcompare::
// COMPARE \ String
// ( c-addr1 u1 c-addr u2 -- n )
#ifndef _DEBUG_DSOURCE
// 2004.01.13, version with strings (max 255 chars):
/*
u1&=peekl(sp&+KCell&)
u2&=tos&
temp2$ = packed$:
temp1$ = packed$:
_INCREASE_STACK
// are the two strings identical?
if temp1$=temp2$
tos& = 0
goto xnext
endif
// are they identical up to the length of the shorter string?
temp&=min(u1&,u2&)
temp1$=left$(temp1$,temp&)
temp2$=left$(temp2$,temp&)
if temp1$=temp2$
tos& = -1 + 2*iabs(u1&>=u2&)
goto xnext
endif
// they are different up to the length of the shorter one
i&=1
while i&<=temp&
if mid$(temp1$,i&,1)<>mid$(temp2$,i&,1)
tos& = -1 + 2*iabs(mid$(temp1$,i&,1)>mid$(temp2$,i&,1))
break
endif
i&=i&+1
endwh
goto xnext
*/
// 2005.01.29, version without strings (no length limit):
#ifdef _TOS
a1&=peekl(sp&+K2Cells&)
u1&=peekl(sp&+KCell&)
a2&=peekl(sp&)
u2&=tos&
sp& = sp&+K3Cells&
tos& = 0
temp1& = min(u1&,u2&)
temp2& = max(u1&,u2&)
i& = 0
while i&<temp2&
if peekb(a1&+i&)<>peekb(a2&+i&)
tos& = -1 + 2*iabs(peekb(a1&+i&)>peekb(a2&+i&))
break
endif
i& = i&+1
if i&=temp1& and i&<>temp2&
tos& = -1 + 2*iabs(u1&>u2&)
break
endif
endwh
#else
a1&=peekl(sp&+K3Cells&)
u1&=peekl(sp&+K2Cells&)
a2&=peekl(sp&+KCell&)
u2&=peekl(sp&)
sp& = sp&+K3Cells&
pokel sp&,0
temp1& = min(u1&,u2&)
temp2& = max(u1&,u2&)
i& = 0
while i&<temp2&
if peekb(a1&+i&)<>peekb(a2&+i&)
pokel sp&, -1 + 2*iabs(peekb(a1&+i&)>peekb(a2&+i&))
break
endif
i& = i&+1
if i&=temp1& and i&<>temp2&
pokel sp&, -1 + 2*iabs(u1&>u2&)
break
endif
endwh
#endif
#endif // _DEBUG_DSOURCE
goto xnext
xparenthesis::
// ( \ Core
// ( -- )
_PARSE_OFF?(41) // 41 = code of the char )
goto xnext
xbackslash::
// \ \ Core Ext
// ( -- )
_PARSE_OFF?(0)
goto xnext
xdatetosecs::
// date>secs \ OPL
// ( second minute hour day month year -- secs )
// secs = seconds since 1970.01.01 00:00
#ifdef _TOS
tos& = datetosecs(tos&,peekl(sp&),peekl(sp&+KCell&),peekl(sp&+K2Cells&),peekl(sp&+K3Cells&),peekl(sp&+K4Cells&))
sp& = sp&+K5Cells&
#else
temp&=datetosecs(peekl(sp&),peekl(sp&+KCell&),peekl(sp&+K2Cells&),peekl(sp&+K3Cells&),peekl(sp&+K4Cells&),peekl(sp&+K5Cells&))
sp& = sp&+K5Cells&
pokel sp&,temp&
#endif
goto xnext
xsecstodate::
// secs>date \ OPL
// ( secs -- second minute hour day month year)
// secs = seconds since 1970.01.01 00:00
#ifdef _TOS
secstodate tos&,temp0%,temp1%,temp2%,temp3%,temp4%,temp5%,temp6%
tos& = temp0%
sp& = sp&-K5Cells&
pokel sp&,temp1%
pokel sp&+KCell&,temp2%
pokel sp&+K2Cells&,temp3%
pokel sp&+K3Cells&,temp4%
pokel sp&+K4Cells&,temp5%
#else
secstodate peekl(sp&),temp0%,temp1%,temp2%,temp3%,temp4%,temp5%,temp6%
sp& = sp&-K5Cells&
pokel sp&,temp0%
pokel sp&+KCell&,temp1%
pokel sp&+K2Cells&,temp2%
pokel sp&+K3Cells&,temp3%
pokel sp&+K4Cells&,temp4%
pokel sp&+K5Cells&,temp5%
#endif
goto xnext
xsourceid::
// SOURCE-ID \ Core Ext
// ( -- n )
_PUSH?(sourceid&)
goto xnext
xsource::
// SOURCE \ Core
// ( -- c-addr u )
_2INCREASE_STACK
#ifdef _TOS
pokel sp&,ib_addr&
tos& = ib_len&
#else
pokel sp&+KCell&,ib_addr&
pokel sp&, ib_len&
#endif
goto xnext
xsourcestore::
// SOURCE! \ Forth 5mx
// ( c-addr u -- )
#ifdef _TOS
ib_addr& = peekl(sp&)
ib_len& = tos&
#else
ib_addr& = peekl(sp&+KCell&)
ib_len& = peekl(sp&)
#endif
_2DROP
goto xnext
xsaveinput::
// SAVE-INPUT \ Core Ext
// ( -- n1 n2 n3 n4 4 )
// n1 = ib_addr&
// n2 = ib_len&
// n3 = >IN = toin&
// n4 = SOURCE-ID
_SAVE_INPUT
goto xnext
xrestoreinput::
// RESTORE-INPUT \ Core Ext
// ( n1 n2 n3 n4 4 -- flag )
// n1 = ib_addr&
// n2 = ib_len&
// n3 = >IN = toin&
// n4 = SOURCE-ID
_RESTORE_INPUT
goto xnext
xparse::
// PARSE \ Core Ext
// ( char "ccc<char>" -- c-addr u )
#ifndef _DEBUG_DSOURCE // d!!!
_PARSE_TOS
#endif // _DEBUG_DSOURCE
goto xnext
xtoupper::
// toupper \ gforth
// ( c1 -- c2 )
#ifdef _TOS
tos&=asc(upper$(chr$(tos&)))
#else
pokel sp&,asc(upper$(chr$(peekb(sp&))))
#endif
goto xnext
xupper::
// upper \ Forth 5mx
// ( c-addr1 u -- )
#ifdef _TOS
temp&=peekl(sp&)
while tos&
tos&--
pokeb temp&+tos&,asc(upper$(chr$(peekb(temp&+tos&))))
endwh
_2DROP
// old version until 2006-12-30:
// ( c-addr1 u -- c-addr2 u )
// _GET_PACKED
// to_sbuffer:(upper$(packed$))
#else
temp&=peekl(sp&+KCell&)
i&=peekl(sp&)
while i&
i&--
pokeb temp&+i&,asc(upper$(chr$(peekb(temp&+i&))))
endwh
_2DROP
#endif
goto xnext
xtolower::
// tolower \ gforth
// ( c1 -- c2 )
#ifdef _TOS
tos&=asc(lower$(chr$(tos&)))
#else
pokel sp&,asc(lower$(chr$(peekb(sp&))))
#endif
goto xnext
xlower::
// lower \ Forth 5mx
// ( c-addr u -- )
#ifdef
temp&=peekl(sp&)
while tos&
tos&--
pokeb temp&+tos&,asc(lower$(chr$(peekb(temp&+tos&))))
endwh
_2DROP
// old version until 2006-12-31:
// ( c-addr1 u -- c-addr2 u )
// _GET_PACKED
// to_sbuffer:(lower$(packed$))
#else
temp&=peekl(sp&+KCell&)
i&=peekl(sp&)
while i&
i&--
pokeb temp&+i&,asc(lower$(chr$(peekb(temp&+i&))))
endwh
_2DROP
#endif
goto xnext
xdirstr::
// dir$ \ OPL
// ( c-addr1 u1 -- c-addr2 u2 )
_GET_PACKED
string$ = dir$(packed$)
#include "forth5mx_inc_to_sbuffer.opp"
goto xnext
xsetpath::
// setpath \ OPL
// ( c-addr u -- )
_GET_PACKED
path$ = whole_path$:(packed$)
setpath path$
goto xnext
xtosbuffer::
// >sbuffer \ Forth 5mx
// ( c-addr1 u -- c-addr2 u )
// Store a string in the string buffer and return it with its new address.
_GET_PACKED
string$=packed$
#include "forth5mx_inc_to_sbuffer.opp"
goto xnext
xplussbuffer::
// +sbuffer \ Forth 5mx
// ( u -- c-addr )
#ifdef _TOS
_PLUS_SBUFFER?(tos&)
#else
_PLUS_SBUFFER?(peekl(sp&))
#endif
#ifdef _DSBUFFER
#ifdef _TOS
tos&=sbuffer_start&+DesLength&:(sbuffer_descriptor&)
#else
pokel sp&,sbuffer_start&+DesLength&:(sbuffer_descriptor&)
#endif
#else
#ifdef _TOS
tos&=sbuffer_current&
#else
pokel sp&,sbuffer_current&
#endif
#endif
goto xnext
xsbuffer::
// sbuffer \ Forth 5mx
// ( -- c-addr)
#ifdef _DSBUFFER
_PUSH?(sbuffer_start&+DesLength&:(sbuffer_descriptor&))
#else
_PUSH?(sbuffer_current&)
#endif
goto xnext
xsbufferfree::
// sbuffer-free \ Forth 5mx
// ( -- u)
_PUSH?(_SBUFFER_FREE)
goto xnext
xsbufferplusstore::
// sbuffer+! \ Forth 5mx
// ( u -- )
#ifdef _DSBUFFER
#ifdef _TOS
DesSetLength:(sbuffer_descriptor&,DesLength&:(sbuffer_descriptor&)+tos&)
#else
DesSetLength:(sbuffer_descriptor&,DesLength&:(sbuffer_descriptor&)+peekl(sp&))
#endif
#else
#ifdef _TOS
sbuffer_current&=sbuffer_current&+tos&
#else
sbuffer_current&=sbuffer_current&+peekl(sp&)
#endif
#endif
_DROP
goto xnext
xsbufferplus::
// sbuffer+ \ Forth 5mx
// ( -- )
_SBUFFER_PLUS
goto xnext
xnumbertib::
// #TIB \ Core Ext
// ( -- a-addr)
_INCREASE_STACK
numbertib& = len(ib$)
#ifdef _TOS
tos& = addr(numbertib&)
#else
pokel sp&,addr(numbertib&)
#endif
goto xnext
xtib::
// TIB \ Core Ext
// ( -- c-addr)
_INCREASE_STACK
#ifdef _TOS
tos& = ib_addr&
#else
pokel sp&,ib_addr&
#endif
goto xnext
xlshift::
// LSHIFT \ Core
// ( x1 u -- x2 )
// first try:
#ifdef _TOS
temp& = tos&
temp = peekl(sp&)
while temp&
temp = temp*2
temp&=temp&-1
endwh
tos& = signed&:(temp)
#else
temp& = peekl(sp&)
temp = peekl(sp&+KCell&)
while temp&
temp = temp*2
temp&=temp&-1
endwh
// print signed&:(temp)
pokel sp&, signed&:(temp)
#endif
_NIP
goto xnext
xrshift::
// RSHIFT \ Core
// ( x1 u -- x2 )
// fisrt try:
#ifdef _TOS
temp& = tos&
tos& = peekl(sp&)
while temp&
tos& = tos&/2
temp&=temp&-1
endwh
#else
temp& = peekl(sp&)
temp1& = peekl(sp&+Kcell&)
while temp&
temp1& = temp1&/2
temp&=temp&-1
endwh
pokel sp&,temp1&
#endif
_NIP
goto xnext
xstarstar::
// ** \ Forth 5mx
// ( n1 n2 -- n3 )
#ifdef _TOS
tos& = peekl(sp&)**tos&
_NIP
#else
pokel sp&+KCell&, peekl(sp&+KCell&)**peekl(sp&)
_DROP
#endif
goto xnext
xmarker::
// MARKER \ Core Ext
// ( "<spaces>name" -- )
temp& = dp&
temp1& = last_nt&
temp2& = thread_pointer%
// Store also the threads:
temp3& = alloc(KThreads%*KCell&)
if temp3&=0
raise KErrNoMemory%
endif
temp0&=temp3&
i%=KThreads%
while i%
pokel temp0&,thread&(i%)
temp0&+=KCell&
i%--
endwh
_PARSED_WORD
header&:(parsed_word$,0)
_COMMA?(xbrmarkerbr&) // (marker)
_COMMA?(temp&)
_COMMA?(temp1&)
_COMMA?(temp2&)
_COMMA?(temp3&)
goto xnext
xbrmarkerbr::
// (marker) \ Forth 5mx
// Run time code for words created by MARKER .
dp& = peekl(wp&+KCell&)
last_nt& = peekl(wp&+K2Cells&)
thread_pointer% = peekl(wp&+K3Cells&)
// Restore the threads:
temp0&=peekl(wp&+K4Cells&)
temp&=temp0&
i%=KThreads%
while i%
thread&(i%)=peekl(temp&)
temp&+=KCell&
i%--
endwh
freealloc temp0&
goto xnext
xgetfilesize::
// getfilesize \ OPL
// ( c-addr u -- u2 )
_GET_PACKED
temp$ = whole_path$:(packed$)
_PUSH?(GetFileSize&:(temp$))
goto xnext
xalias::
// alias \ Common use
// ( xt "<spaces>name" -- )
_PARSED_WORD
header&:(parsed_word$,0)
#ifdef _TOS
pokel _XT_ADDRESS?(last_nt&), tos&
#else
pokel _XT_ADDRESS?(last_nt&), peekl(sp&)
#endif
_DROP
goto xnext
xevaluate::
// EVALUATE \ Core
// ( i*x c-addr u -- j*x )
_GET_PACKED
#include "forth5mx_inc_save_source.opp"
#ifdef _DSOURCE
_NEW_EVALUATE_IB?(packed$)
#else
ib$=packed$
ib_len& = len(ib$)
sourceid& = KSourceIDString%
toin&=0
#endif
_INDICATE_SOURCE
_CALL_XT?(xinterpret&,label03)
#include "forth5mx_inc_restore_source.opp"
goto xnext
xinterpret::
// interpret \ Forth 5mx
// ( -- )
do
_PARSED_WORD
if len(parsed_word$)
nametofind$=parsed_word$
// input: nametofind$
#include "forth5mx_inc_find.opp"
// output: nt& = nt or 0
if nt&
// found
if state& and ((_CONTROL_BITS?(nt&) and KImmediate%)=0)
// compile
_COMMA?(_XT?(nt&))
else
// execute
_CALL_NT?(nt&,label00)
endif
if sp0&-sp& < 0
_REPORT_ERROR?("stack underflow")
goto xabort
endif
elseif numberq%:(parsed_word$)
if state& // compiling
pokel dp&,xbrliteralbr&
pokel dp&+KCell&,number&:(parsed_word$)
dp& = dp& + K2Cells&
// maybe faster with _COMMA? b!!!
else
// interpreting
_PUSH?(number&:(parsed_word$))
endif
else
_REPORT_ERROR?("not found")
goto xabort
endif
endif
until toin&>=ib_len&
ib_len&=0
// _DEBUG?("en INTERPRET ante goto xnext")
goto xnext
xrdrop::
// rdrop \ Common use
// ( R: x -- )
_RDROP
goto xnext
x2rdrop::
// 2rdrop \ Common use
// ( R: x1 x2 -- )
_2RDROP
goto xnext
xdequal::
// D= \ Double
// ( d1 d2 -- f )
// :!!!
goto xnext
// new_primitives_here
oplerror::
onerr off // :!!! *!!!
_REPORT_ERROR?( err$(err) + " (opl error #" + num$(iabs(err),4) + ")" )
onerr oplerror // :!!! *!!!
goto xabort
interpret_only::
_REPORT_ERROR?("use only during interpretation")
goto xabort
compile_only::
_REPORT_ERROR?("use only during compilation")
goto xabort
// End of the file forth5mx_fvm.opp