(!*******************************************************
* Mosel Example Programs *
* ====================== *
* *
* file mdbg.mos *
* ````````````` *
* Example for the use of the Mosel language *
* (use of the Remote Invocation Ptotocol) *
* *
* Implements a debugger written in Mosel *
* *
* (c) 2015 Fair Isaac Corporation *
* author: Y. Colombani, 2015 *
*******************************************************!)
model mdbg
uses 'mmjobs','mmsystem'
parameters
SRC="qsort.mos"
end-parameters
declarations
LINEMASK=16777215
FILESHIFT=-24
EVENT_DBG=32770
MO:Mosel
M:Model
lineset:range
modset:range
s_src=record
fname:string
nbl:integer
lines:array(lineset) of text
end-record
s_msrc=record
nbi:integer
lndx:array(lineset) of integer
src:array(modset) of s_src
end-record
allmods:range
allsrc:dynamic array(allmods) of s_msrc
end-declarations
forward procedure intcmd(stat:integer)
forward procedure cmdprint(m:integer,toprint:text)
forward procedure cmdbreak(m:integer,toprint:text)
forward procedure cmdstack(m:integer,args:text)
forward procedure cmdstat
forward procedure cmdfct(m:integer,fct:text)
forward procedure cmdinfo(m:integer,args:text)
forward procedure cmdlsloc(m:integer,args:text)
forward procedure cmdlsattr
forward procedure lslib
forward function dbgopcode(v:real):integer
forward function dbgoparg(v:real):integer
forward function loadfile(f:string):s_src
forward procedure showlocation(m:integer)
forward procedure loadsrc(m:integer)
forward procedure lndxlist(m:integer)
forward function vers2str(sv:string):string
forward function vers2str(v:integer):string
forward function str2date(sd:string):string
forward function getndx(v:integer):integer
forward procedure showtyp(typs:array(range) of string, args:string, ta:textarea)
forward procedure showhelp
if connect(MO,"")<0 then
exit(1)
end-if
if compile("G",SRC,"tmp:bimfile")<>0 then
writeln("Compilation failed")
exit(1)
end-if
nid:=getid(MO)
load(MO,M,"rmt:[-1]tmp:bimfile")
loadsrc(0)
! switch model to debug mode
setcontrol(M,"runmode","1")
run(M)
! execution will stop just before 1st statement
repeat
wait
ev:=getnextevent
if ev.class=EVENT_DBG then
case dbgopcode(ev.value) of
1: do ! submodel starting
writeln("model ",dbgoparg(ev.value)," starting")
end-do
2: do ! submodel ending
writeln("model ",dbgoparg(ev.value)," ending")
if exists(allsrc(dbgoparg(ev.value))) then
delcell(allsrc(dbgoparg(ev.value)))
end-if
end-do
3: intcmd(dbgoparg(ev.value)) ! Interruption
else
writeln("Unexpected DBG event: ",dbgopcode(ev.value),"-",dbgoparg(ev.value))
end-case
end-if
until ev.class=EVENT_END
!**********************************
! Interactive command interpreter
!**********************************
! Model flow control is achieved using the 'dbgctrl' parameter that
! can be set using 'setcontrol':
! dbgctrl=B => suspend execution
! dbgctrl=E => terminate execution
! Following can be used only on a suspended model:
! dbgctrl=C => continue
! dbgctrl=N [s] => next statement (on submodel 's')
! dbgctrl=S [s] => step into (on submodel 's')
! dbgctrl=F [s] => continue up to end of routine (on submodel 's')
! dbgctrl=T s lndx => continue up to 'lndx' on submodel 's'
! Other useful parameters:
! flushdso => force unloading of unused modules
! realfmt=string => change format used for displaying reals
! zerotol=real => zero tolerance for real comparison
procedure intcmd(stat:integer)
declarations
l:text
RT_OK=0
RT_ENDING=2
RT_BREAK=14
RT_NIFCT=15
end-declarations
case stat of
RT_OK : showlocation(0)
RT_ENDING : writeln("Ending...")
RT_BREAK : do writeln("Breakpoint at:"); showlocation(0); end-do
RT_NIFCT : do writeln("In NIFct:"); showlocation(0); end-do
else
write("Stat: ",stat," at:")
showlocation(0)
end-case
repeat
write("> "); fflush
nbc:=readtextline(l)
trim(l,SYS_RIGHT)
if nbc<=0 or l="end" then
setcontrol(M,"dbgctrl","E")
break
elif l="cont" then
setcontrol(M,"dbgctrl","C")
break
elif l="next" then
setcontrol(M,"dbgctrl","N")
break
elif l="step" then
setcontrol(M,"dbgctrl","S")
break
elif l="fin" then
setcontrol(M,"dbgctrl","F")
break
elif startswith(l,"to ") then
setcontrol(M,"dbgctrl","T 0 "+copytext(l,4,l.size))
break
elif startswith(l,"info") then
cmdinfo(0,copytext(l,5,l.size))
elif startswith(l,"lsloc") then
cmdlsloc(0,copytext(l,6,l.size))
elif l="lsattr" then
cmdlsattr
elif l="list" then
lndxlist(0)
elif l="lslib" then
lslib
elif l="flushdso" then
setcontrol(MO,"flushdso","")
elif startswith(l,"print ") then
cmdprint(0,copytext(l,7,l.size))
elif startswith(l,"break") then
cmdbreak(0,copytext(l,6,l.size))
elif startswith(l,"stack") then
cmdstack(0,copytext(l,6,l.size))
elif l="status" then
cmdstat
elif startswith(l,"fct ") then
cmdfct(0,copytext(l,4,l.size))
elif l="help" then
showhelp
else
writeln("Unknown command (try 'help')")
end-if
until false
end-procedure
!******************
!* Command 'print'
!******************
! Request 'eval' (evaluate an expression):
! mcmd:eval@M[.s] lab:expr lab:expr...
! M: master model
! s: submodel (0<=>master model)
! if 'lab'=='.' => label is expression itself
! expression may be ended with 1 or several data amount limit(s)
! [ maxelt ] : return at most 'maxelt' entries
! [ maxelt skip ] : return at most 'maxelt' entries after skipping 'skip'
procedure cmdprint(m:integer,toprint:text)
declarations
v:text
end-declarations
trim(toprint)
(!
setparam("ioctrl",true)
initialisations from "rmt:["+nid+"]mcmd:eval-t@1."+m+" v:"+toprint
v
end-initialisations
setparam("ioctrl",false)
if getparam("iostatus")=0 then
writeln(" ",v)
else
writeln("Evaluation failed or value cannot be displayed")
end-if
!)
fcopy("rmt:["+nid+"]mcmd:eval-t@1."+m+" :"+toprint,"")
end-procedure
!******************
!* Command 'break'
!******************
! Request 'dbgbrkp' (get/set/update/delete breakpoint):
! mcmd:dbgbrkp@M[.s]
! mcmd:dbgbrkp@M[.s] lndx
! mcmd:dbgbrkp@M[.s] lndx cond
! M: master model
! s: submodel (0<=>master model)
! no parameter: return list of breakpoints
! lndx: delete breakpoint. if lndx=*: delete all breakpoints
! lndx cond: add or modify breakpoint at lndx (cond='*' <=> no cond)
procedure cmdbreak(m:integer,args:text)
declarations
Rlndx:range
lndx:dynamic array(Rlndx) of integer
cond:dynamic array(Rlndx) of string
end-declarations
trim(args)
setparam("ioctrl",true)
initialisations from "bin:rmt:["+nid+"]mcmd:dbgbrkp@1."+m+" "+args
Rlndx
lndx
cond
end-initialisations
setparam("ioctrl",false)
if getparam("iostatus")=0 then
loadsrc(m)
forall(b in Rlndx) do
l:=bittest(allsrc(m).lndx(lndx(b)),LINEMASK)
f:=bitshift(allsrc(m).lndx(lndx(b)),FILESHIFT)
write("Break at (",lndx(b),") ",allsrc(m).src(f).fname,":",l)
if cond(b)<>"" then
writeln(" if ",cond(b))
else
writeln
end-if
end-do
else
writeln("Failed to set breakpoint")
end-if
end-procedure
!******************
!* Command 'stack'
!******************
! Request 'dbgstlev' (get/set stack level):
! mcmd:dbgstlev@M[.s]
! mcmd:dbgstlev@M[.s] stlev [maxlev]
! M: master model
! s: submodel (0<=>master model)
! stlev=='*' => get current stack level
! stlev>=0 => set stack level
! if 'maxlev' not provided => maxlev=10
procedure cmdstack(m:integer,args:text)
declarations
Rlndx:range
lndx:dynamic array(Rlndx) of integer
end-declarations
trim(args)
setparam("ioctrl",true)
initialisations from "bin:rmt:["+nid+"]mcmd:dbgstlev@1."+m+" "+args
Rlndx
lndx
end-initialisations
setparam("ioctrl",false)
if getparam("iostatus")=0 then
loadsrc(m)
forall(b in Rlndx) do
write(" ",b,": ")
i:=lndx(b)
if i<0 then
writeln("no location information")
else
l:=bittest(allsrc(m).lndx(i),LINEMASK)
f:=bitshift(allsrc(m).lndx(i),FILESHIFT)
if l=0 then
writeln("in package ",allsrc(m).src(f).fname)
else
writeln(allsrc(m).src(f).fname,":",l," ",allsrc(m).src(f).lines(l))
end-if
end-if
end-do
else
writeln("Failed to get stack trace")
end-if
end-procedure
!***************************************
!* Display status of all running models
!***************************************
! Request 'dbgstat' (status and location):
! mcmd:dbgstat@M
! mcmd:dbgstat@M.s
! M: master model (if no submodel => status of all running models)
! s: submodel (0<=>master model)
procedure cmdstat
declarations
Rid:range
id,stat,stlev,lndx:array(Rid) of integer
end-declarations
initialisations from "bin:rmt:["+nid+"]mcmd:dbgstat@1"
Rid
id
stat
stlev
lndx
end-initialisations
forall(j in Rid) do
m:=id(j)
i:=lndx(j)
if stat(j)=2 then
writeln("[",m,"] ending")
elif stat(j)=15 then
writeln("[",m,"] in native function")
elif i<0 then
writeln("[",m,"] no location information")
else
loadsrc(m)
l:=bittest(allsrc(m).lndx(i),LINEMASK)
f:=bitshift(allsrc(m).lndx(i),FILESHIFT)
if l=0 then
writeln("[",m,"] in package ",allsrc(m).src(f).fname)
else
writeln("[",m,"] ",allsrc(m).src(f).fname,":",l," ",allsrc(m).src(f).lines(l))
end-if
end-if
end-do
end-procedure
!*****************
!* Command 'fct'
!*****************
! Request 'dbgflndx' (line index of a subroutine):
! mcmd:dbgflndx@M[.s] [fctname|*]
! M: master model
! s: submodel (0<=>master model)
! several line indices are returned if the function is overloaded
! with option 'N', result is sorted by function names
! with option 'L', result is sorted by line indices
procedure cmdfct(m:integer,fct:text)
declarations
Rsign:range
sign:array(Rsign) of string
lndx:array(Rsign) of integer
name:array(Rsign) of string
end-declarations
setparam("ioctrl",true)
initialisations from "bin:rmt:["+nid+"]mcmd:dbgflndx-N@1."+m+fct
Rsign
sign
lndx
name
end-initialisations
setparam("ioctrl",false)
trim(fct)
if getparam("iostatus")=0 then
forall(i in Rsign)
writeln(" ",name(i),"(",sign(i),") -> ",lndx(i))
else
writeln("Subroutine '",fct,"' not found")
end-if
end-procedure
!******************
!* Command 'info'
!******************
! Request 'info' (model/package/module/Mosel information):
! mcmd:info@M[.s]
! mcmd:info
! mcmd:info modulename
! M: master model
! s: submodel (0<=>master model)
! 1st form is for a loaded model/package
! 2d form returns Mosel information
! 3d form is used for a module (the module is loaded if necessary)
procedure cmdinfo(m:integer,args:text)
declarations
fmt:integer
hdr:array(Rhdr:range) of string
deps:array(Rdeps:range) of string
depsvers,depstyp:array(Rdeps) of integer
typs:array(Rtyps:range) of string
typscod:array(Rtyps) of integer
parms,parmsdesc:array(Rparms:range) of string
parmsval:array(Rparms) of integer
consts:array(Rconsts:range) of string
conststyp:array(Rconsts) of integer
cstint:array(Rcstint:range) of integer
cststr:array(Rcststr:range) of string
cstdbl:array(Rcstdbl:range) of real
vars:array(Rvars:range) of string
varstyp:array(Rvars) of integer
arrndx:array(Rarrndx:range) of string
fct,fctsign:array(Rfct:range) of string
fcttyp:array(Rfct) of integer
dtyp:array(Rdtyp:range) of string
dtyptyp:array(Rdtyp) of integer
recsstart:array(Rrecsstart:range) of integer
recfield:array(Rrecfield:range) of string
recftype:array(Rrecfield) of integer
iodrv,iodrvinfo:array(Riodrv:range) of string
annsident:array(Rannsident:range) of string
annsstart:array(Rannsstart:range) of integer
anns: array(Ranns:range) of string
! Format decoding
SYMB_FMT_MOD=0
SYMB_FMT_PKG=1
SYMB_FMT_DSO=2
SYMB_FMT_MOS=3
SYMB_MSK_FMT=3
! Format options (for models/packages)
SYMB_FMT_CRYPTED=4
SYMB_FMT_SIGNED=8
SYMB_FMT_VERIFIED=16
SYMB_FMT_UNVERIFIED=32
! Basic types
SYMB_TYP_NOT=0
SYMB_TYP_INT=1
SYMB_TYP_REAL=2
SYMB_TYP_STRING=3
SYMB_TYP_BOOL=4
SYMB_TYP_MPVAR=5
SYMB_TYP_LINCTR=6
! Masks for type decoding
SYMB_MSK_TYP=4095 ! 0xFFF 12 bits [ 0-11]
SYMB_MSK_STR=61440 ! 0xF000 4 bits [12-15]
SYMB_MSK_OPT=983040 ! 0xF0000 4 bits [16-19]
SYMB_MSK_NDX=-1048576 ! 0xFFF00000 12 bits [20-31]
! Shift length for type decoding
SYMB_SHT_STR=12
SYMB_SHT_OPT=16
SYMB_SHT_NDX=20
! Entity structure
SYMB_STR_SCA=0 ! (0<<SYMB_SHT_STR)
SYMB_STR_ARR=4096 ! (1<<SYMB_SHT_STR)
SYMB_STR_SET=8192 ! (2<<SYMB_SHT_STR)
SYMB_STR_LST=12288 ! (3<<SYMB_SHT_STR)
SYMB_STR_REC=16384 ! (4<<SYMB_SHT_STR)
SYMB_STR_PROB=20480 ! (5<<SYMB_SHT_STR)
! Parameter flags
SYMB_OPT_READ=65536 ! (1<<SYMB_SHT_OPT)
SYMB_OPT_WRITE=131072 ! (2<<SYMB_SHT_OPT)
! variable/subroutine flags (to tag requirements)
SYMB_OPT_REQMT=65536 ! (1<<SYMB_SHT_OPT)
! Native type properties
SYMB_MTP_CREAT=1
SYMB_MTP_DELET=2
SYMB_MTP_TOSTR=4
SYMB_MTP_FRSTR=8
SYMB_MTP_PRTBL=16
SYMB_MTP_RFCNT=32
SYMB_MTP_COPY=64
SYMB_MTP_APPND=128
SYMB_MTP_ORSET=256
SYMB_MTP_PROB=512
SYMB_MTP_CMP=1024
ta:textarea
end-declarations
trim(args)
if args.size=0 then
fname:="rmt:["+nid+"]mcmd:info-t@1"
elif args="*" then
fname:="rmt:["+nid+"]mcmd:info-t"
else
fname:="rmt:["+nid+"]mcmd:info-t "+args
end-if
setparam("ioctrl",true)
! fcopy(fname,"")
initialisations from fname
fmt
Rhdr hdr
Rdeps deps depsvers depstyp
Rtyps typs typscod
Rparms parms parmsval parmsdesc
Rconsts consts conststyp
Rcstint cstint
Rcststr cststr
Rcstdbl cstdbl
Rvars vars varstyp
Rarrndx arrndx
Rfct fct fctsign fcttyp
Rdtyp dtyp dtyptyp
Rrecsstart recsstart
Rrecfield recfield recftype
Riodrv iodrv iodrvinfo
Rannsident annsident
Rannsstart annsstart
Ranns anns
end-initialisations
setparam("ioctrl",false)
if getparam("iostatus")=0 then
!------------------- Header ----------
case bittest(fmt,SYMB_MSK_FMT) of
SYMB_FMT_MOD,SYMB_FMT_PKG: do ! Model or Package
writeln(if(bittest(fmt,SYMB_MSK_FMT)=SYMB_FMT_MOD,"Model ","Package "),
hdr(0)," version ",vers2str(hdr(4)))
writeln(" sys.com: ",hdr(1))
writeln(" date:",str2date(hdr(6)))
writeln(" usr.com: ",hdr(2))
write(" security: ")
if bittest(fmt,SYMB_FMT_CRYPTED+SYMB_FMT_SIGNED)=0 then
writeln("none")
else
if bittest(fmt,SYMB_FMT_CRYPTED)<>0 then write(" encrypted"); end-if
if bittest(fmt,SYMB_FMT_SIGNED)<>0 then
write(" signed ",hdr(3))
if bittest(fmt,SYMB_FMT_VERIFIED)<>0 then write(" verified")
elif bittest(fmt,SYMB_FMT_UNVERIFIED)<>0 then write(" unverified")
else write(" unchecked")
end-if
end-if
writeln
end-if
if Rdeps.size>0 then
j:=0
forall(i in Rdeps) do
if depstyp(i)=0 and j=0 then
write(" modules:")
j:=1
elif depstyp(i)<2 and j<2 then
if i>0 then writeln; end-if
write(" pkg. req.:")
j:=2
elif depstyp(i)>1 and j<3 then
if i>0 then writeln; end-if
write(" pkg. imp.:")
j:=3
end-if
write(" ",deps(i)," (",vers2str(depsvers(i)),")")
end-do
writeln
end-if
end-do
SYMB_FMT_DSO: do ! Module
writeln("Module ",hdr(0)," version ",vers2str(hdr(4))," (",hdr(1),")")
writeln(" file:",hdr(5)+"/"+hdr(0)+".dso")
writeln(" date:",str2date(hdr(6)))
writeln(" priority:",hdr(7))
if Rdeps.size>0 then
write(" modules:")
forall(i in Rdeps) do
write(" ",deps(i))
end-do
writeln
end-if
end-do
SYMB_FMT_MOS: do ! Mosel core functionality
writeln("Mosel ",hdr(7),"-bit version ",vers2str(hdr(4)))
writeln(" Link date: ",hdr(2))
writeln(" Libpath: ",hdr(5))
writeln(" dsopath: ",hdr(1))
end-do
end-case
writeln
!------------------- Constants --------
if Rconsts.size>0 then
writeln("Constants:")
forall(i in Rconsts) do
write(" ",consts(i),"=")
j:=getndx(conststyp(i))-1
case bittest(conststyp(i),SYMB_MSK_TYP) of
SYMB_TYP_INT: writeln(cstint(j))
SYMB_TYP_REAL: writeln(cstdbl(j))
SYMB_TYP_STRING: writeln(cststr(j))
SYMB_TYP_BOOL: writeln(if(cstint(j)<>0,"true","false"))
end-case
end-do
writeln
end-if
!------------------- Types ------------
if Rdtyp.size>0 then
writeln("Types:")
forall(i in Rdtyp) do
type:=bittest(dtyptyp(i),SYMB_MSK_TYP)
if type=0 then ! dso type
write(" ",dtyp(i)," (")
flag:=bitshift(dtyptyp(i),-SYMB_SHT_STR)
if bittest(flag,SYMB_MTP_PROB)<>0 then
write("problem")
if bittest(flag,SYMB_MTP_CREAT)<>0 then write(",create"); end-if
else
if bittest(flag,SYMB_MTP_CREAT)<>0 then write("create"); end-if
end-if
if bittest(flag,SYMB_MTP_DELET)<>0 then write(",delete"); end-if
if bittest(flag,SYMB_MTP_RFCNT)<>0 then write(",refcnt"); end-if
if bittest(flag,SYMB_MTP_TOSTR)<>0 then write(",tostring"); end-if
if bittest(flag,SYMB_MTP_PRTBL)<>0 then write("+"); end-if
if bittest(flag,SYMB_MTP_FRSTR)<>0 then write(",fromstring"); end-if
if bittest(flag,SYMB_MTP_ORSET)<>0 then write(",reset"); end-if
if bittest(flag,SYMB_MTP_COPY)<>0 then write(",copy"); end-if
if bittest(flag,SYMB_MTP_APPND)<>0 then write("+"); end-if
if bittest(flag,SYMB_MTP_CMP)<>0 then write(",cmp"); end-if
writeln(")")
else
write(" ",dtyp(i),"=")
if bittest(typscod(type),SYMB_MSK_STR)=SYMB_STR_REC then
j:=getndx(typscod(type))
writeln("record")
forall(k in recsstart(j)..(recsstart(j+1)-1))
writeln(" ",recfield(k),":",typs(bittest(recftype(k),SYMB_MSK_TYP)))
writeln(" end-record");
elif bittest(typscod(type),SYMB_MSK_STR)=SYMB_STR_PROB then
writeln("problem:",typs(type))
else
writeln(typs(type))
end-if
end-if
end-do
writeln
end-if
!------------------- Parameters -------
if Rparms.size>0 then
writeln("Control Parameters:")
forall(i in Rparms) do
type:=parmsval(i)
write(" ",parms(i)," (",typs(bittest(type,SYMB_MSK_TYP)))
if bittest(type,SYMB_OPT_READ)<>0 then
if bittest(type,SYMB_OPT_WRITE)<>0 then write(",read/write")
else write(",read only"); end-if
else
if bittest(type,SYMB_OPT_WRITE)<>0 then write(",write only"); end-if
end-if
if parmsdesc(i)<>"" then
write(",",parmsdesc(i),")")
else
write(")")
end-if
j:=getndx(type)-1
if j>=0 then
case bittest(type,SYMB_MSK_TYP) of
SYMB_TYP_INT: writeln("=",cstint(j))
SYMB_TYP_REAL: writeln("=",cstdbl(j))
SYMB_TYP_STRING: writeln("=",cststr(j))
SYMB_TYP_BOOL: writeln("=",if(cstint(j)<>0,"true","false"))
end-case
else
writeln
end-if
end-do
writeln
end-if
!------------------- Variables --------
if Rvars.size>0 then
writeln("Variables:")
forall(i in Rvars) do
write(" ",vars(i),":")
case bittest(varstyp(i),SYMB_MSK_STR) of
SYMB_STR_ARR: do
j:=getndx(varstyp(i))
if j>0 then
write("array (",arrndx(j-1),") of ")
else
write("array of ")
end-if
end-do
SYMB_STR_SET: write("set of ")
SYMB_STR_LST: write("list of ")
end-case
writeln(typs(bittest(varstyp(i),SYMB_MSK_TYP)),if(bittest(varstyp(i),SYMB_OPT_REQMT)<>0," [reqmt]",""))
end-do
writeln
end-if
!------------------- Subroutines ------
if Rfct.size>0 then
writeln("Procedures and Functions:")
forall(i in Rfct) do
write(" ",if(bittest(fcttyp(i),SYMB_MSK_TYP)=0,"procedure ","function "),fct(i))
if fctsign(i)<>"" then
write("(");
ta.start:=1
ta.succ:=1
showtyp(typs,fctsign(i),ta)
while(ta.succ<fctsign(i).size) do
write(",")
showtyp(typs,fctsign(i),ta)
end-do
write(")");
end-if
if bittest(fcttyp(i),SYMB_MSK_TYP)<>0 then
write(":",typs(bittest(fcttyp(i),SYMB_MSK_TYP)))
end-if
if bittest(fcttyp(i),SYMB_OPT_REQMT)<>0 then write(" [reqmt]"); end-if
writeln
end-do
writeln
end-if
!------------------- IO drivers -------
if Riodrv.size>0 then
writeln("I/O drivers:")
forall(i in Riodrv) do
writeln(" ",iodrv(i),":",iodrvinfo(i))
end-do
writeln
end-if
!------------------- Annotations ------
if Rannsident.size>0 then
writeln("Annotations:")
forall(i in Rannsident) do
writeln(" ",if(annsident(i)<>"",annsident(i),"[global]"),"->")
forall(k in annsstart(i)..(annsstart(i+1)-1) div 2,kk=2*k) do
writeln(" ",anns(kk),":",anns(kk+1))
end-do
end-do
writeln
end-if
else
writeln("Operation failed")
end-if
end-procedure
!******************
!* Command 'lsloc'
!******************
! Request 'lsloc' (list of local variables):
! mcmd:info@M[.s]
! M: master model
! s: submodel (0<=>master model)
procedure cmdlsloc(m:integer,args:text)
declarations
typs:array(Rtyps:range) of string
typscod:array(Rtyps) of integer
vars:array(Rvars:range) of string
varstyp:array(Rvars) of integer
arrndx:array(Rarrndx:range) of string
! Basic types
SYMB_TYP_NOT=0
SYMB_TYP_INT=1
SYMB_TYP_REAL=2
SYMB_TYP_STRING=3
SYMB_TYP_BOOL=4
SYMB_TYP_MPVAR=5
SYMB_TYP_LINCTR=6
! Masks for type decoding
SYMB_MSK_TYP=4095 ! 0xFFF 12 bits [ 0-11]
SYMB_MSK_STR=61440 ! 0xF000 4 bits [12-15]
SYMB_MSK_OPT=983040 ! 0xF0000 4 bits [16-19]
SYMB_MSK_NDX=-1048576 ! 0xFFF00000 12 bits [20-31]
! Shift length for type decoding
SYMB_SHT_STR=12
SYMB_SHT_OPT=16
SYMB_SHT_NDX=20
! Entity structure
SYMB_STR_SCA=0 ! (0<<SYMB_SHT_STR)
SYMB_STR_ARR=4096 ! (1<<SYMB_SHT_STR)
SYMB_STR_SET=8192 ! (2<<SYMB_SHT_STR)
SYMB_STR_LST=12288 ! (3<<SYMB_SHT_STR)
SYMB_STR_REC=16384 ! (4<<SYMB_SHT_STR)
SYMB_STR_PROB=20480 ! (5<<SYMB_SHT_STR)
ta:textarea
end-declarations
setparam("ioctrl",true)
! fcopy(fname,"")
initialisations from "rmt:["+nid+"]mcmd:lsloc-t@1"
Rtyps typs typscod
Rvars vars varstyp
Rarrndx arrndx
end-initialisations
setparam("ioctrl",false)
if getparam("iostatus")=0 then
!------------------- Variables --------
if Rvars.size>0 then
writeln("Variables:")
forall(i in Rvars) do
write(" ",vars(i),":")
case bittest(varstyp(i),SYMB_MSK_STR) of
SYMB_STR_ARR: do
j:=getndx(varstyp(i))
if j>0 then
write("array (",arrndx(j-1),") of ")
else
write("array of ")
end-if
end-do
SYMB_STR_SET: write("set of ")
SYMB_STR_LST: write("list of ")
end-case
writeln(typs(bittest(varstyp(i),SYMB_MSK_TYP)))
end-do
writeln
end-if
else
writeln("Operation failed")
end-if
end-procedure
!******************
!* Command 'lsattr'
!******************
! Request 'lsattr' (list of attributes):
! mcmd:lsattr@M[.s]
! M: master model
! s: submodel (0<=>master model)
procedure cmdlsattr
declarations
typs:array(Rtyps:range) of string
attrs:array(Rattrs:range) of string
attrsntyp:array(Rattrs) of integer
attrsatyp:array(Rattrs) of integer
end-declarations
setparam("ioctrl",true)
initialisations from "rmt:["+nid+"]mcmd:lsattr-t@1"
Rattrs attrs attrsntyp attrsatyp
end-initialisations
! Get the type names (from lsloc)
initialisations from "rmt:["+nid+"]mcmd:lsloc-t@1"
Rtyps typs
end-initialisations
setparam("ioctrl",false)
lasttyp:=0;
forall(a in Rattrs) do
if attrsntyp(a)<>lasttyp then
writeln(typs(attrsntyp(a)),":")
lasttyp:=attrsntyp(a)
end-if
writeln(" ",attrs(a),":",typs(attrsatyp(a)))
end-do
end-procedure
!******************
!* Command 'lslib'
!******************
! Request 'lslib' (list of available libraries [packages+modules]):
! mcmd:lslib
! with option 'p', packages are listed with their full path
procedure lslib
declarations
pkgs:array(Rpkgs:range) of string
dsos:array(Rdsos:range) of string
end-declarations
initialisations from "rmt:["+nid+"]mcmd:lslib-pt"
Rpkgs
pkgs
Rdsos
dsos
end-initialisations
if pkgs.size>0 then
writeln(" Packages:")
forall(p in Rpkgs)
writeln(" ",pkgs(p))
end-if
if pkgs.size>0 then
writeln(" Modules:")
forall(p in Rdsos)
writeln(" ",dsos(p))
end-if
end-procedure
!**********************************************
!* Return operation code of a dbg event value
!**********************************************
function dbgopcode(v:real):integer
returned:=bitshift(integer(v),-16)
end-function
!**********************************************
!* Return operation arg of a dbg event value
!**********************************************
function dbgoparg(v:real):integer
returned:=bittest(integer(v),65535)
end-function
!**********************
!* Load a source file
!**********************
function loadfile(f:string):s_src
declarations
l:text
end-declarations
returned.fname:=f
setparam("ioctrl",true)
fopen(f,F_INPUT+F_SILENT)
setparam("ioctrl",false)
if getparam("iostatus")=0 then
while(readtextline(l)>=0) do
returned.nbl+=1
trim(l,SYS_RIGHT)
returned.lines(returned.nbl):=l
end-do
fclose(F_INPUT)
end-if
end-function
!***************************************
!* Display current location of a model
!***************************************
! Request 'dbgstat' (status and location):
! mcmd:dbgstat@M
! mcmd:dbgstat@M.s
! M: master model (if no submodel => status of all running models)
! s: submodel (0<=>master model)
procedure showlocation(m:integer)
declarations
Rid:range
id,stat,stlev,lndx:array(Rid) of integer
end-declarations
initialisations from "bin:rmt:["+nid+"]mcmd:dbgstat@1."+m
Rid
id
stat
stlev
lndx
end-initialisations
i:=lndx(0)
if stat(0)=2 then
writeln("[",m,"] ending")
elif i<0 then
writeln("[",m,"] no location information")
else
loadsrc(m)
l:=bittest(allsrc(m).lndx(i),LINEMASK)
f:=bitshift(allsrc(m).lndx(i),FILESHIFT)
if l=0 then
writeln("[",m,"] in package ",allsrc(m).src(f).fname)
else
writeln("[",m,"] ",allsrc(m).src(f).fname,":",l," ",allsrc(m).src(f).lines(l))
end-if
end-if
end-procedure
!***************************
!* Load source for a model
!***************************
! Request 'dbglndx' (all line indices):
! mcmd:dbglndx@M[.s]
! M: master model
! s: submodel (0<=>master model)
procedure loadsrc(m:integer)
declarations
lines:array(Rlines:range) of integer
files:array(Rfiles:range) of string
end-declarations
if not exists(allsrc(m)) then
initialisations from "bin:rmt:["+nid+"]mcmd:dbglndx@1."+m
Rfiles
files
Rlines
lines
end-initialisations
allsrc(m).nbi:=Rlines.size
forall(i in Rlines) allsrc(m).lndx(i):=lines(i)
forall(f in Rfiles) do
allsrc(m).src(f):=loadfile(files(f))
end-do
end-if
end-procedure
!**********************************************************
!* Display correspondance between line indices and source
!**********************************************************
procedure lndxlist(m:integer)
loadsrc(m)
forall(i in 0..allsrc(m).nbi-1) do
l:=bittest(allsrc(m).lndx(i),LINEMASK)
f:=bitshift(allsrc(m).lndx(i),FILESHIFT)
if l=0 then
writeln("package ",allsrc(m).src(f).fname)
else
writeln(i,":",allsrc(m).src(f).fname,'-',l," ",allsrc(m).src(f).lines(l))
end-if
end-do
end-procedure
!***************************************
!* Convert a version number to a string
!***************************************
function vers2str(sv:string):string
returned:=vers2str(integer(sv))
end-function
function vers2str(v:integer):string
m0:=v mod 1000
v:=v div 1000
m1:=v mod 1000
v:=v div 1000
returned:=string(v)+"."+m1+"."+m0
end-function
!************************************
!* Convert a Unix time into a string
!************************************
function str2date(sd:string):string
dt:=datetime(integer(sd))
returned:=string(dt)
end-function
!***************************************
!* Return index value of an identifier
!***************************************
function getndx(v:integer):integer
declarations
SYMB_SHT_NDX=20
end-declarations
returned:=bitshift(v,-SYMB_SHT_NDX)
end-function
!*********************************
!* Display a subroutine argument
!*********************************
procedure showtyp(typs:array(range) of string, args:string, ta:textarea)
ta.start:=ta.succ
ta.succ:=ta.succ+1
case getchar(args,ta.start) of
105: write("integer") ! 'i'
114: write("real") ! 'r'
115: write("string") ! 's'
98: write("boolean") ! 'b'
118:write("mpvar") ! 'v'
99: write("linctr") ! 'c'
73: write("range") ! 'I'
97: write("array") ! 'a'
101:write("set") !' e'
108:write("list") ! 'l'
33: do ! '!'
i:=findtext(args,"!",ta.succ)
write(copytext(args,ta.succ,i-1))
ta.succ:=i+1
end-do
124: do ! '|'
i:=findtext(args,"|",ta.succ)
write(copytext(args,ta.succ,i-1))
ta.succ:=i+1
end-do
37: do ! '%'
i:=integer(substr(args,ta.succ,ta.succ+2))
write(typs(i))
ta.succ:=ta.succ+3
end-do
65: do ! 'A'
write("array (")
while(getchar(args,ta.succ)<>46) do
showtyp(typs,args,ta)
end-do
ta.succ:=ta.succ+1
write(") of ")
showtyp(typs,args,ta)
end-do
69: do ! 'E'
write("set of ")
showtyp(typs,args,ta)
end-do
76: do ! 'L'
write("list of ")
showtyp(typs,args,ta)
end-do
42: write("...") ! '*'
else
write("?")
end-case
end-procedure
!*************************
!* Display some help
!*************************
procedure showhelp
write(`
Available commands:
cont : continue execution
end : abort execution
next : continue to next statement
step : step into
fin : continue up to end of routine
to lndx: continue up to given line index
list : display all line indices of current model
fct fname: display line indices of given function
lslib : list available modules and packages
info [mod|*]: symbols of the model, a module (mod) or Mosel (*)
lsattr : list of attributes
lsloc : list of current local symbols
flushdso: unload unused modules
print expr: evaluate expression
break : list breakpoints
break lndx|*: remove breakpoints at line index lndx (*=> all breakpoints)
break lndx cond|*: set/change breakpoint at line index lndx
status : report status of all running models
stack [stlev [maxlev]]: set/check stack level
`)
end-procedure
end-model
|
