!***********************************************************************
!*
!*               Program to dump virtual memory in EBCDIC 
!*  
!*     Copyright (C)   R.D. Eager    University of Kent   MCMLXXXI 
!*
!***********************************************************************
!
!
!***********************************************************************
!*
!*          Constants
!*
!***********************************************************************
!
constantinteger  no = 0, yes = 1
constantinteger  outstream = 1;         ! Stream for dump output
constantstring (1) snl = "
"
constantbyteintegerarray  hex(0:15) = c 
'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
!
!
!***********************************************************************
!*
!*          Record and array formats
!*
!***********************************************************************
!
recordformat  fdf(integer  link,dsnum,byteinteger  status,accessroute,
                  valid action,cur state,byteinteger  mode of use,
                  mode,file org,dev code,byteinteger  rec type,flags,
                  lm,rm,integer  asvar,arec,recsize,minrec,maxrec,
                  maxsize,lastrec,conad,currec,cur,end,transfers,
                  darecnum,cursize,datastart,string (31) iden)
!
ownbyteintegerarrayformat  trtf(0:255)
!
!
!***********************************************************************
!*
!*          Subsystem references
!*
!***********************************************************************
!
systemintegermapspec  comreg(integer  i)
systemroutinespec  define(integer  chan,string (31) iden,
                          integername  afd,flag)
systemstringfunctionspec  failuremessage(integer  mess)
systemroutinespec  fill(integer  length,from,filler)
systemstringfunctionspec  itos(integer  n)
systemintegerfunctionspec  parmap
systemroutinespec  setfname(string (63) s)
systemroutinespec  setpar(string (255) s)
externalroutinespec  set return code(integer  i)
systemstringfunctionspec  spar(integer  n)
externalintegerfunctionspec  uinfi(integer  entry)
!
externalroutinespec  clear(string (255) s)
!
!
!***********************************************************************
!*
!*          Service routines
!*
!***********************************************************************
!
integerfunction  getval(string (255) s)
integer  sign,l,c,n,i,j
!
l = length(s)
result  = -1 if  l = 0
!
n = 0
sign = 1;                               ! Positive by default
c = charno(s,1)
!
if  c = 'X' then  start ;               ! Hexadecimal number
   result  = -1 if  l = 1
   for  i = 2,1,l cycle 
      c = charno(s,i)
      for  j = 0,1,15 cycle 
         -> found if  c = hex(j)
      repeat 
      result  = -1;                     ! Unrecognised digit
      !
   found:
      n = (n << 4)!j
   repeat 
else 
   for  i = 1,1,l cycle 
      c = charno(s,i)
      if  c = '-' and  i = 1 then  start 
         sign = -1
         continue 
      finish 
      result  = -1 unless  '0' <= c <= '9'
      n = n*10 + c - '0'
   repeat 
finish 
!
result  = n
end ;   ! of getval
!
!-----------------------------------------------------------------------
!
string (8)function  htos(integer  value,places)
integer  i
string (8) s
!
i = 64-4*places
*ld  _s
*lss _places
*st  _(dr )
*inca_1
*std _tos 
*std _tos 
*lss _value
*luh _0
*ush _i
*mpsr_x'24';                            ! Set CC=1
*supk_l =8
*ld  _tos 
*ands_l =8,0,15;                        ! Throw away zone codes
*lss _hex+4
*luh _x'18000010'
*ld  _tos 
*ttr _l =8
result  = s
end ;   ! of htos
!
!
!***********************************************************************
!*
!*          E D U M P
!*
!***********************************************************************
!
externalroutine  edump(string (255) parms)
integer  start,finish,i,j,above
integer  flag,afd
string (31) out
string (32) s
record (fdf)name  f
byteintegerarrayname  trtab
!
setpar(parms)
!
if  parmap = 1 and  spar(1) = "?" then  start 
   printstring("Parameters are:  start,finish,output".snl)
   set return code(0)
   return 
finish 
!
unless  3 <= parmap <= 7 then  start 
   flag = 263;                          ! Wrong number of parameters
   -> err
finish 
!
out = spar(3)
if  out = "" then  out = ".OUT"
define(outstream,out,afd,flag)
-> err if  flag # 0
f == record(afd)
f_maxsize = (uinfi(6) + 1)*1024
selectoutput(outstream)
!
trtab == array(comreg(11),trtf);        ! Address of master EBCDIC to ISO table
!
! Get start and length/finish values
!
start = getval(spar(1))
if  start = -1 then  start 
   setfname(spar(1))
   flag = 202;                          ! Invalid parameter
   -> err
finish 
finish = getval(spar(2))
if  finish = -1 then  start 
   setfname(spar(2))
   flag = 202;                          ! Invalid parameter
   -> err
finish 
!
if  finish < start or  start < 0 < finish then  start 
                                        ! Start, length intended
   finish = (finish+(start & x'7FFFFFFF') - 1)!(start & x'80000000')
finish 
!
length(s) = 32
newlines(2)
start = start & x'FFFFFFFC'
finish = ((finish+4)&x'FFFFFFFC') - 1
if  finish < start then  start 
   flag = 177;                          ! Addresses inside out
   -> err
finish 
!
above = no
-> printline;                           ! First line must be printed in full
!
nextline:
-> printline if  finish - start < 32;   ! Must print last line
!
!  Compare 32 bytes at 'start' with 32 bytes at 'start'-32:
!
*ldtb _x'18000020'
*lda  _start
*cyd  _0
*inca _-32
*cps  _l =dr 
*jcc  _7,<printline>
!
if  above = no then  start ;            ! First line as above in this group
   above = yes
   spaces(50)
   printstring("Lines(s) as above".snl)
finish 
!
start = start + 32
-> nextline
!
printline:
above = no
printsymbol('*')
fill(32,addr(s)+1,'_')
for  i = 32,-1,1 cycle 
   j = trtab(byteinteger(start+i-1))
   if  32 <= j < 127 then  charno(s,i) = j
repeat 
printstring(s."*   (".htos(start,8).")   ")
for  i = start,4,start + 28 cycle 
   printstring(htos(integer(i),8))
   spaces(2)
repeat 
start = start + 32
newline
-> nextline unless  start > finish
!
selectoutput(0)
closestream(outstream)
clear(itos(outstream))
!
set return code(0)
stop 
!
err:
selectoutput(0)
printstring(snl."EDUMP fails -".failuremessage(flag))
set return code(flag)
stop 
end ;   ! of edump
endoffile