(!*******************************************************
* 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<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.succ0 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<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
|
