Trailing-Edge
-
PDP-10 Archives
-
tops10and20_integ_tools_v9_3-aug-86
-
tools/crc/browse/browse.for
There are no other files named browse.for in the archive.
program browse
include 'brzblk.for'
c
c The layout of the link list of the nodes and their offspring
c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
c
c map(place) map(place)+
c list v count
c -------------------------------------------------------------------------
c |count|map |name|file|number |number |f 1|f 2|s 1|s 2|next | empty=
c | |self| |name|of dads|of sons| | | | |count| total
c -------------------------------------------------------------------------
c ^ v v v v ^
c map ^ v v v v<<<<<<<<<<<< ^
c ----------------------------------------------- ^
c |location| v v |loc | ffslot-first free slot
c | | v v | |
c -----------------------------------------------
c v<<<<<<<<<<<<</ v v :
c text v v >>>>>...^
c ------------------------------------------------------------
c |node |0| |file |0| txtspa= total empty
c |name | | |name | |
c ------------------------------------------------------------
c ^
c fftext
c.......
c get the existing info into memory
c
character*80 nodnam,filenm,binfil
logical done
binfil='ps:<packages>browse.bin'
c ** binfil='ps:<g-gibbs>browse.bin'
call begin (binfil)
edting=.true.
call wizkid
c
c what ought we do here? let's see what the user has typed in.
c
do while (.true.)
call crsil(1)
letter=ichain()
if (letter.eq.uparow) then
call up
else if (letter.eq.dwnarw) then
call down
else if (letter.eq.ritarw) then
call son
else if (letter.eq.lftarw) then
call father
else if (letter.eq.e) then
call exit (binfil)
c else if (letter.eq.f) then
c call father
c else if (letter.eq.g) then
c call genera
else if (letter.eq.h) then
call help
else if (letter.eq.i) then
call info (.true.)
else if (letter.eq.l) then
call locate
else if (letter.eq.n) then
call next (done)
else if (letter.eq.p) then
call info (.false.) !.not. terminal
else if (letter.eq.r) then
call run
c else if (letter.eq.s) then
c call son
else if (letter.eq.t) then
call top
else if (letter.eq.w) then
call wizkid
c
c are we enabled for editing ?
c
else if (edting) then
if (letter.eq.a) then
call add
else if (letter.eq.c) then
call create
else if (letter.eq.d) then
call delete
else if (letter.eq.k) then
call kill
else if (letter.eq.m) then
call mod
else if (letter.eq.q) then
call quit
else if (letter.eq.u) then
call update (binfil)
else if (letter.eq.x) then
call gc
else if (letter.eq.query) then
call files
else
call crbell (1)
end if
else if (letter.eq.query) then
call info (.true.)
else
call crbell(1)
end if
end do
end
c
c subroutine to add in a link from the --> node to the input (new) node
c
subroutine add
include 'brzblk.for'
character*80 gtnode,gtfils
dimension dadptr(maxrel),sonptr(maxrel)
call gtdads (place,dadcnt,dadptr)
call gtsons (place,soncnt,sonptr)
if (soncnt.lt.maxrel) then
soncnt=soncnt+1
sonptr(soncnt)=input
call enter (place,gtnode(place),gtfils(place),
+ dadcnt,soncnt,dadptr,sonptr)
else
call cleol
call disply ('Too many offspring from this node.',1,1)
call curhom
end if
call gtdads (input,dadcnt,dadptr)
call gtsons (input,soncnt,sonptr)
if (dadcnt.lt.maxrel) then
dadcnt=dadcnt+1
dadptr(dadcnt)=place
call enter (input,gtnode(input),gtfils(input),
+ dadcnt,soncnt,dadptr,sonptr)
call son !and redisplay with sons
else
call cleol
call disply ('Too many parents of this node.',1,1)
call curhom
end if
return
end
c
c subroutine to create a new (the input) node as the son of --> node
c
subroutine create
include 'brzblk.for'
character*80 nfname,nnname,indfil
dimension dadptr(1),sonptr(1)
call scrrst !screen normal
c
c obtain the information required from the user
c
write (unit=tty,fmt='1x,a')
+ 'Enter the name of the new node or "@" followed '//
+ 'by the name of the file',
+ 'containing the names and files to be added '//
+ 'below this node.'
read (unit=tty,fmt='q,a')nnnlen,nnname
nnnlen=nnnlen+1
nnname(nnnlen:nnnlen)=char(0)
if (nnname(1:1).ne.'@' .or. nnnlen.eq.2) then
write (unit=tty,fmt='1x,a')
+ 'Enter the file names of the new node, in the form',
+ 'textfile%*exefile',
+ 'or',
+ 'lbrfile%modulename*exefile',
+ 'where, sys: is assumed if no directory is given, and',
+ 'lbrfile defaults to .lbr, and exefile (if present) '
+ //'to .exe'
read (unit=tty,fmt='q,a')nfnlen,nfname
nfnlen=nfnlen+1
nfname(nfnlen:nfnlen)=char(0)
c
c now add it in
c
input=gtmap()
dadptr(1)=0 !father is put in by ADD
sonptr(1)=0
call enter (input,nnname,nfname,0,0,dadptr,sonptr)
call scrset !screen set up
call add !new node as son of current node
else
c
c obtain the information required from the user's indirect file
c
indfil=nnname(2:nnnlen-1)
open (unit=3,file=indfil,status='old')
call scrset !screen set up
do while (.true.)
read (unit=3,fmt='q,a',iostat=flag)nnnlen,nnname
if (nnname.eq.' ' .or. flag.ne.0) go to 500
nnnlen=nnnlen+1
nnname(nnnlen:nnnlen)=char(0)
read (unit=3,fmt='q,a',iostat=flag)nfnlen,nfname
if (nnname.eq.' ' .or. flag.ne.0) go to 500
nfnlen=nfnlen+1
nfname(nfnlen:nfnlen)=char(0)
c
c now add it in
c
input=gtmap()
dadptr(1)=0 !father is put in by ADD
sonptr(1)=0
call enter (input,nnname,nfname,0,0,dadptr,sonptr)
call add !new node as son of current node
end do
500 continue
close (unit=3)
end if
return
end
c
c subroutine to delete the current node
c
subroutine delete
include 'brzblk.for'
call deletn (place)
call top
return
end
c
c subroutine to save the info before exiting
c
subroutine exit (opfile)
include 'brzblk.for'
character*(*) opfile
if (edting) then
call update (opfile)
end if
call quit
stop
end
c
c subroutine to display the fathers of the current node
c we also show the sons if there is only one father
c if there is no father we jump to the top
c
subroutine father
include 'brzblk.for'
call crclr (screen,maxrel*4,0)
call crclr (scrlev,maxrel*4,0)
call crclr (stalev,4,0)
call crclr (endlev,4,0)
call gtdads (place,levcnt,screen)
if (levcnt.le.0) then
call top
else
do dd=1,levcnt
scrlev(dd)=1
end do
place=screen(1)
pageno=1
scrloc=1
curlev=1
genmax=4
stalev(1)=1
endlev(1)=levcnt
c
c if there is only one father, we may as well show the sons
c
if (levcnt.eq.1) then
call son
else
call dsplev
end if
end if
return
end
c
c subroutine to change the maximum depth of display level
c
subroutine genera
include 'brzblk.for'
call scrrst !screen normal
c
c obtain the information required from the user
c
write (unit=tty,fmt=*)
+ 'What is the maximum number of generations'//
+ ' you wish to be displayed ? (2-4)'
read (unit=tty,fmt=*)number
genmax=min(4,max(2,number))
call scrset !set up the screen
call dsplev !redisplay
return
end
c
c subroutine to give the user the help message
c
subroutine help
include 'brzblk.for'
call cleol
call disply ('Help...',1,1)
call curhom
if (edting) then
call dspmod ('sys:brzhlp','wiz')
else
call dspmod ('sys:brzhlp','bas1')
call dspmod ('sys:brzhlp','bas2')
end if
return
end
c
c subroutine to type out the info associated with a node
c the info is store in a file, or possibly a module in a lbr file
c
subroutine info (term)
include 'brzblk.for'
character*80 file,buffer*132,gtfils,nammod*39,gtdev
logical term,sure
if (term) then
call cleol
call disply ('Information...',1,1)
call curhom
else
call scrrst !screen normal
call yesno ('Are you sure you want this information printed'
+ //' on the lineprinter ? ',sure,ifail,0,0,'no')
call scrset !set up the screen
call dsplev !redisplay
if (.not.sure) then
call cleol
call disply ('No action taken.',1,1)
call curhom
return
end if
call cleol
call disply ('Print...',1,1)
call curhom
end if
file=gtfils(place)
module=index(file,'%')
exefil=index(file,'*')
if (exefil.le.0) then !we have no files
call cleol
call disply ('There is no information available'//
+ ' to you on this topic.',1,1)
call curhom
else if (module.eq.0.or.module.eq.exefil-1) then !not a library file
file=gtdev(file(1:module-1)//char(0))
if (term) then
call dspfil (file) !display the file
else
call prtfil (file) !print the file
end if
else !module in a library
nammod=file(module+1:exefil-1)//char(0)
file=gtdev(file(1:module-1)//char(0))
if (term) then
call dspmod (file,nammod) !display the module
else
call prtmod (file,nammod) !print the module
end if
end if
return
end
c
c subroutine to kill the link between the --> node and the input(new) node
c
subroutine kill
include 'brzblk.for'
character*80 gtnode,gtfils
dimension dadptr(maxrel),sonptr(maxrel),dptr(maxrel),sptr(maxrel)
c
c remove any links from place to input (as sons)
c
call gtdads (place,dadcnt,dadptr)
call gtsons (place,soncnt,sonptr)
number=0
do ns=1,soncnt
if (sonptr(ns).ne.input) then
number=number+1
sptr(number)=sonptr(ns)
end if
end do
if (number.lt.soncnt) then
soncnt=number
call enter (place,gtnode(place),gtfils(place),
+ dadcnt,soncnt,dadptr,sptr)
end if
c
c remove any links from input to place (as fathers)
c
call gtdads (input,dadcnt,dadptr)
call gtsons (input,soncnt,sonptr)
number=0
do nd=1,dadcnt
if (dadptr(nd).ne.place) then
number=number+1
dptr(number)=dadptr(nd)
end if
end do
if (number.lt.dadcnt) then
dadcnt=number
call enter (input,gtnode(input),gtfils(input),
+ dadcnt,soncnt,dptr,sonptr)
end if
call son !and redisplay with sons
return
end
c
c subroutine to locate a node with a given name
c
subroutine locate
include 'brzblk.for'
character*80 gtnode,buffer,craise
logical done
call scrrst !screen normal
c
c What are we looking for ?
c
write (unit=tty,fmt='1x,a')'Enter the name of the topic'//
+ ' you are looking for.',
+ 'You may enter part of the name, and step through'//
+ 'all occurences with NEXT.'
read (unit=tty,fmt='q,a')luklen,buffer
wanted=craise(buffer)
call scrset !set screen up again
lukher=1
call next (done)
return
end
c
c subroutine to modify a node and make it the input node
c
subroutine mod
include 'brzblk.for'
character*80 nfname,nnname,ofname,onname,gtnode,gtfils
dimension dadptr(maxrel),sonptr(maxrel)
call scrrst !screen normal
onname=gtnode(place)
onname=onname(1:length(onname))
write (unit=tty,fmt=*)'Enter the new name of the node'//
+ ', or return'
write (unit=tty,fmt=*) onname
read (unit=tty,fmt='q,a')nnnlen,nnname
if (nnnlen.gt.0) then
nnnlen=nnnlen+1
nnname(nnnlen:nnnlen)=char(0)
else
write (unit=tty,fmt=*)'Unaltered'
nnname=onname
end if
ofname=gtfils(place)
ofname=ofname(1:length(ofname))
write (unit=tty,fmt=*)'Enter the new file names of the node'//
+ ', or return'
write (unit=tty,fmt=*) ofname
read (unit=tty,fmt='q,a')nfnlen,nfname
if (nfnlen.gt.0) then
nfnlen=nfnlen+1
nfname(nfnlen:nfnlen)=char(0)
else
write (unit=tty,fmt=*)'Unaltered'
nfname=ofname
end if
input=place
c
c if either of the names have changed then modify the node
c
if (nnnlen.gt.0 .or. nfnlen.gt.0) then
call gtdads(input,dadcnt,dadptr)
call gtsons(input,soncnt,sonptr)
call enter (input,nnname,nfname,dadcnt,soncnt,dadptr,sonptr)
end if
call scrset !screen set up
call dsplev
return
end
c
c subroutine to find the next occurence of wanted node name
c
subroutine next (done)
include 'brzblk.for'
character*80 gtnode,craise
logical done
c
c now go and find it, the GO TO terminates the DO loop
c
if (luklen.gt.0) then
call disply ('Searching for',1,1)
call disply (wanted(:luklen),1,15)
do ptr=lukher,mapsiz
if (map(ptr).ne.0) then
if (index(craise(gtnode(ptr)),wanted(1:luklen)).ne.0)
+ then
done=.true.
place=ptr
lukher=ptr+1
call crclr (screen,4*maxrel,0)
call crclr (scrlev,4*maxrel,0)
call crclr (stalev,4,0)
call crclr (endlev,4,0)
screen(1)=place
scrlev(1)=1
stalev(1)=1
endlev(1)=1
pageno=1
scrloc=1
curlev=1
call son
go to 100
end if
end if
end do
end if
call crbell (1) !didn't find it
call dsplev
call curhom
call cleol
call disply ('No (further) match found',1,1)
call curhom
done=.false.
100 continue
return
end
c
c subroutine to leave program without updating any files
c
subroutine quit
include 'brzblk.for'
c call scrrg (1,24)
call putcrs (23,80)
call cleos
call vtend
call crhalt
stop
end
c
c subroutine to the program associated with a node
c
subroutine run
include 'brzblk.for'
character*80 gtfils,file,gtdev
call cleol
call disply ('Run...',1,1)
call curhom
file=gtfils(place)
exefil=index(file,'*')
endexe=index(file,char(0))
if (exefil.lt.endexe-2) then !we have a file to run
file=gtdev(file(exefil+1:endexe-1)//'.exe'//char(0))
call scrrst !reset screen
call crrun (file,0,error) !run the program
call scrset !set up screen
call dsplev !redisplay
else
call cleol
call disply ('Unable to run the program.',1,1)
call curhom
end if
return
end
c
c subroutine to include the sons of the --> node, on the screen
c
c if we are already displaying the maximum number of generations
c then we must delete the highest level, and then shove everything
c up one level...
c otherwise...
c we must first delete any nodes at a lower level than current...
c then slide up the existing displayed data to make room for the
c sons, and then slip them in and redisplay
c
subroutine son
include 'brzblk.for'
dimension temp(maxrel)
c
c have we run out of generations to display ? ** must check if any sons
c
call gtsons(place,num,temp)
if (num.gt.0) then !we have some sons
if (curlev.ge.genmax) then
diff=curlev-genmax
startl=stalev(2+diff) !start & end of wanted generations
end=endlev(2+diff)
do nlev=startl,end !raise their level by the required no.
scrlev(nlev)=scrlev(nlev)-(1+diff)
end do
do nlev=end+1,endlev(1) !delete the tail
screen(nlev)=0
scrlev(nlev)=0
end do
call slide(1,1-startl,end-startl+1) !delete the head
do nlev=2+diff,genmax !what are the limits of levels
stalev(nlev-1)=stalev(nlev)-startl+1
endlev(nlev-1)=endlev(nlev)-startl+1
end do
do nlev=genmax,4
stalev(nlev)=0
endlev(nlev)=0
end do
scrloc=scrloc-startl+1 !keep track of where we are
curlev=scrlev(scrloc)
place=screen(scrloc)
end if
c
c do we have to delete generations at a lower level ?
c
startl=stalev(curlev+1) !start & end of UNwanted generations
end=endlev(curlev+1)
if (startl.gt.0) then !we have some to delete
del=startl-end-1 !del will be negative
resid=endlev(1)-end
call slide(startl,del,resid) !slide screen info down to delete
do nlev=curlev+1,4
stalev(nlev)=0
endlev(nlev)=0
end do
do nlev=1,curlev
endlev(nlev)=endlev(nlev)+del
end do
if (scrloc.gt.end) then
scrloc=scrloc+del
end if
end if
c
c now put in the new sons
c
resid=endlev(1)-scrloc
call slide(scrloc+1,num,resid) !slide screen info up for insert
do nlev=1,curlev
endlev(nlev)=endlev(nlev)+num
end do
stalev(curlev+1)=scrloc+1
endlev(curlev+1)=scrloc+num
do nt=1,num
screen(scrloc+nt)=temp(nt)
scrlev(scrloc+nt)=curlev+1
end do
end if
call dsplev
return
end
c
c subroutine to set up to the top of the list, one generation only
c
subroutine top
include 'brzblk.for'
parent=start
call crclr (screen,maxrel*4,0)
call crclr (scrlev,maxrel*4,0)
call crclr (stalev,4,0)
call crclr (endlev,4,0)
call gtsons (parent,levcnt,screen)
do sn=1,levcnt
scrlev(sn)=1
end do
place=screen(1)
pageno=1
scrloc=1
curlev=1
stalev(1)=1
endlev(1)=levcnt
call dsplev
return
end
c
c subroutine to save the data file
c
subroutine update (opfile)
include 'brzblk.for'
character*(*) opfile
character*80 gtnode,nodtxt,gtfils,filtxt
character*6 tabs
data tabs/' '/
call cleol
call disply ('Saving...',1,1)
call curhom
open (unit=2,name=opfile//'.-1',access='sequential',
+ form='unformatted',status='new')
write (unit=2)
+ start,ffslot,empty,txtspa,fftext,lstsiz,mapsiz,txtsiz
write (unit=2) list
write (unit=2) map
write (unit=2) text
close (unit=2)
open (unit=2,name='ps:<packages>browse.list.-1',
+ access='sequential',form='formatted',status='new')
open (unit=3,name='ps:<packages>browse.files.-1',
+ access='sequential',form='formatted',status='new')
mapcnt=0
do ptr=1,mapsiz
if (map(ptr).ne.0) then
mapcnt=mapcnt+1
nodtxt=gtnode(ptr)
filtxt=gtfils(ptr)
nodlen=length(nodtxt)
write(unit=2,fmt='a') nodtxt(:nodlen)
numtab=max(((40-nodlen)/8)+1,1)
write(unit=3,fmt='3a')
+ nodtxt(:nodlen),tabs(:numtab),filtxt(:length(filtxt))
end if
end do
close (unit=2)
close (unit=3)
call cleol
call disply ('Saved',1,1)
call curhom
return
end
c
c subroutine to set and reset wizard mode (allow editing)
c
subroutine wizkid
include 'brzblk.for'
character*90 bschlp,wizhlp
data bschlp /
+' Exit Help Information Locate Next Print Run Top [7m^ v <- ->[0
+m'/
c data wizhlp /
c +'Add Bck Crt Del Exi Gen Hlp Kil Inf Loc Mod Nxt Pag Quit Run Top
c + Updt ? ^ v < >'/ !** old version with Bck Gen Pag
data wizhlp /
+' Add Crt Del Exi Hlp Kil Inf Loc Mod Nxt Prt Quit Run Top Updt Xp
+ng? [7m^ v < >[0m'/
bschlp(80:80)=char(0)
wizhlp(86:86)=char(0)
if (edting.or..not.wizard) then
edting=.false.
call disply (bschlp,24,1)
else
edting=.true.
call disply (wizhlp,24,1)
end if
call cleol
call curhom
return
end
c
c subroutine to
c
c subroutine escseq
c include 'brzblk.for'
c letter=raise(ichin())
c if (letter.eq.opsqbr) then
c letter=raise(ichin())
c if (letter.eq.a) then
c call up
c else if (letter.eq.b) then
c call down
c else if (letter.eq.c) then
c call son
c else if (letter.eq.d) then
c call father
c end if
c end if
c return
c end
c
c subroutine to move the pointer up one entry
c
subroutine up
include 'brzblk.for'
if (scrloc.gt.1) then
call cleol
call disply(' ',pointa,1)
pointa=pointa-1
scrloc=scrloc-1
place=screen(scrloc)
curlev=scrlev(scrloc)
if (pointa.ge.2) then
call disply('-->',pointa,1)
call curhom
else
call dsplev
end if
else
call crbell (1)
end if
return
end
c
c subroutine to move the pointer down one entry
c
subroutine down
include 'brzblk.for'
if (screen(scrloc+1).gt.0) then
call cleol
call disply(' ',pointa,1)
pointa=pointa+1
scrloc=scrloc+1
place=screen(scrloc)
curlev=scrlev(scrloc)
if (pointa.le.23) then
call disply('-->',pointa,1)
call curhom
else
call dsplev
end if
else
call crbell (1)
end if
return
end
c
c subroutine to display the current node and file names
c
subroutine files
include 'brzblk.for'
c character*(40) node,filnms,gtnode,gtfils,buffer*80
character*(40) node,filnms,gtnode,gtfils
node=gtnode(place)
filnms=gtfils(place)
call cleol
call disply ('node:-'//node,1,1)
call disply ('files:-'//filnms,1,20)
c write (unit=buffer,fmt=100) stalev,endlev
c write (unit=buffer,fmt=100) place,(screen(ij),ij=1,10)
c write (unit=buffer,fmt=100) place,scrloc,row,depth
c buffer(40:40)=char(0)
c call disply ('debug:-'//buffer,1,40)
call curhom
return
c 100 format (20i3)
end
c
c subroutine to indicate a function is not implemented
c
subroutine unimp
include 'brzblk.for'
call cleol
call disply ('This function is not yet implemented',1,1)
call curhom
return
end
c
c routine to read in the info from a binary file and set up at start
c
subroutine begin (ipfile)
include 'brzblk.for'
integer iuser(8)
character*(*) ipfile,user*39
logical done
call cruser(iuser)
call crsint (iuser,user)
if (user.eq.'G-GIBBS'.or.user.eq.'P-GARDNER') then
wizard=.true.
else
wizard=.false.
end if
open (unit=1,name=ipfile,access='sequential',
+ form='unformatted',status='old',iostat=error)
c
c if it has not been set up before then do so now
c
if (error.ne.0) then
start=1
parent=1
pageno=1
ffslot=1
fftext=1
scrloc=1
levcnt=3
screen(1)=2
screen(2)=3
screen(3)=4
screen(4)=1
call enter (1,'top'//char(0),char(0),
+ 1,levcnt,screen(4),screen)
screen(1)=1
screen(2)=5
screen(3)=6
call enter (2,'commands'//char(0),'%*'//char(0),
+ 1,0,screen,screen(2))
call enter (3,'programs'//char(0),'%*'//char(0),
+ 1,0,screen,screen(2))
call enter (4,'writing programs'
+ //char(0),'%*'//char(0),
+ 1,0,screen,screen(2))
screen(1)=2
screen(2)=3
screen(3)=4
else
read (unit=1)
+ start,ffslot,empty,txtspa,fftext,lstlen,maplen,txtlen
read (unit=1) (list(ii),ii=1,lstlen)
read (unit=1) (map(ii),ii=1,maplen)
read (unit=1) text(:txtlen)
close (unit=1)
end if
c
c set up the screen and do a dummy fortran write, to keep it happy
c
call scrset
call curhom
call cleos
genmax=4
call rescan (done)
if (.not.done) then
call top
call disply ('Help and information are available '//
+ 'in the following areas :-',1,1)
+
call disply (
+ 'Type the initial letter of any command below '//
+ 'to use it, e.g. H for help.'
+ //char(13)//char(10)//
+ 'Use the arrow keys to move the pointer around.'
+ //char(13)//char(10)//
+ 'Type I or ? to see the information at any time.',20,1)
call curhom
end if
return
end
c
c routine to recan the input line for search string
c
subroutine rescan (done)
include 'brzblk.for'
character*80 buffer,craise
logical done
call crrscn (buffer,bufcnt)
first=index(buffer,'browse ')+8
if (first.ge.bufcnt) then
done=.false.
else
luklen=(bufcnt-first)
wanted=craise(buffer(first:bufcnt))
call scrset !set screen up again
lukher=1
call next (done)
c done=.true.
end if
return
end
c
c routine to delete a nodes data
c
subroutine deletn (pointr)
include 'brzblk.for'
character*80 gtnode,gtfils
dimension dptr(maxrel),sptr(maxrel)
c
c tot up the space regained
c
empty=empty+list(map(pointr))
txtspa=txtspa+length(gtnode(pointr))
+ +length(gtfils(pointr))
c
c delete links to it, first the sons of the fathers then vice versa
c
call gtdads(pointr,numd,dptr)
do id=1,numd
call gtsons(dptr(id),nums,sptr)
do js=1,nums
if (sptr(js).eq.pointr) then
list(map(dptr(id))+numson+
+ list(map(dptr(id))+numdad)+js)=0
end if
end do
end do
c
call gtsons(pointr,nums,sptr)
do is=1,nums
call gtdads(sptr(is),numd,dptr)
do jd=1,numd
if (dptr(jd).eq.pointr) then
list(map(sptr(is))+numson+jd)=0
end if
end do
end do
c
c delete itself
c
list(map(pointr)+mapslf)=0
map(pointr)=0
return
end
c
c routine to enter a new nodes data
c
subroutine enter (mapslt,nodnam,filenm,dadcnt,soncnt,
+ dadptr,sonptr)
include 'brzblk.for'
character nodnam*(*),filenm*(*)
integer dadptr(*),sonptr(*)
if (dadcnt.ge.0) then
c
c get a free slot, have we enough space, if not return
c
count=1+numson+dadcnt+soncnt
slot=gtslot(count)
namlen=length(nodnam)
fillen=length(filenm)
namslt=getext(namlen)
filslt=getext(fillen)
if(slot.eq.0.or.mapslt.eq.0.or.namslt.eq.0.or.filslt.eq.0)then
return
end if
c
c now get map to point to us
c
map(mapslt)=slot
list(slot)=count
list(slot+mapslf)=mapslt
c
c put the node and file names into the text array and then point to them
c
if (namlen.gt.0) then
text(namslt:namslt+namlen)=nodnam(1:namlen)
list(slot+name)=namslt
else
list(slot+name)=0
end if
if (fillen.gt.0) then
text(filslt:filslt+fillen)=filenm(1:fillen)
list(slot+filnam)=filslt
else
list(slot+filnam)=0
end if
c
c put in the pointers to the fathers and sons
c
list(slot+numdad)=dadcnt
list(slot+numson)=soncnt
do id=1,dadcnt
list(slot+numson+id)=dadptr(id)
end do
do is=1,soncnt
list(slot+numson+dadcnt+is)=sonptr(is)
end do
else !no illegitimate nodes wanted
map(mapslt)=0
end if
return
end
c
c routine to add on a device (sys:) if none specified in a file name
c
character*(*) function gtdev(file)
include 'brzblk.for'
character*(*) file
dev=index(file,':')
dir=max(index(file,'<'),index(file,'['))
if (dev.gt.0 .or. dir.gt.0) then
gtdev=file
else
gtdev='sys:'//file
end if
return
end
c
c routine to return the text node name
c
character*(*) function gtnode(locatn)
include 'brzblk.for'
slot=list(map(locatn)+name)
gtnode=text(slot:slot+length(text(slot:)))
return
end
c
c routine to return the text of the file names
c
character*(*) function gtfils(locatn)
include 'brzblk.for'
slot=list(map(locatn)+filnam)
gtfils=text(slot:slot+length(text(slot:)))
return
end
c
c routine to get the number of sons and the pointers to them
c
subroutine gtsons (me,number,points)
include 'brzblk.for'
dimension points(*)
slot=map(me)
num=list(slot+numson)
number=0
do in=1,num
loc=list(slot+numson+list(slot+numdad)+in)
if (loc.gt.0) then
number=number+1
points(number)=loc
end if
end do
return
end
c
c routine to get the number of fathers and the pointers to them
c
subroutine gtdads (me,number,points)
include 'brzblk.for'
dimension points(*)
slot=map(me)
num=list(slot+numdad)
number=0
do in=1,num
loc=list(slot+numson+in)
if (loc.gt.0) then
number=number+1
points(number)=loc
end if
end do
return
end
c
c routine to return the text node name
c
character*(*) function gtxnod(locatn)
include 'brzblk.for'
slot=xlist(map(locatn)+name)
gtxnod=xtext(slot:slot+length(xtext(slot:)))
return
end
c
c routine to return the text of the file names
c
character*(*) function gtxfil(locatn)
include 'brzblk.for'
slot=xlist(map(locatn)+filnam)
gtxfil=xtext(slot:slot+length(xtext(slot:)))
return
end
c
c routine to get the number of sons and the pointers to them
c
subroutine gtxson (me,number,points)
include 'brzblk.for'
dimension points(*)
slot=map(me)
num=xlist(slot+numson)
number=0
do in=1,num
loc=xlist(slot+numson+xlist(slot+numdad)+in)
if (loc.gt.0) then
number=number+1
points(number)=loc
end if
end do
return
end
c
c routine to get the number of fathers and the pointers to them
c
subroutine gtxdad (me,number,points)
include 'brzblk.for'
dimension points(*)
slot=map(me)
num=xlist(slot+numdad)
number=0
do in=1,num
loc=xlist(slot+numson+in)
if (loc.gt.0) then
number=number+1
points(number)=loc
end if
end do
return
end
c
c get the first free slot in list, have we enough space
c
integer function gtslot (size)
include 'brzblk.for'
if (ffslot+size.gt.lstsiz) then
write (unit=tty,fmt=*)' list has run out of space, squeeze'
gtslot=0
return
end if
gtslot=ffslot
ffslot=ffslot+size
return
end
c
c get the first free slot in map, have we enough space
c
integer function gtmap()
include 'brzblk.for'
gtmap=1
do while (map(gtmap).ne.0)
gtmap=gtmap+1
if (gtmap.gt.mapsiz) then
write (unit=tty,fmt=*)'map has run out of space, rebuild'
gtmap=0
return
end if
end do
return
end
c
c get the first free slot, have we enough space
c
integer function getext (size)
include 'brzblk.for'
if (fftext+size.gt.txtsiz) then
write (unit=tty,fmt=*)
+ 'text list has run out of space, squeeze'
getext=0
else
getext=fftext
fftext=fftext+size
end if
return
end
c
c routine to put the screen into normal mode
c
subroutine scrrst
include 'brzblk.for'
call curhom
call cleos
c call scrrg(1,24)
call crsil(0)
c call curhom
call vtend
return
end
c
c routine to set up the screen
c
subroutine scrset
include 'brzblk.for'
call vtinit
call crsil(1)
c call scrrg(2,23)
write (unit=tty,fmt=*)
return
end
c
c raise the 'case' of the character input (as a number in the ascii
c sequence) and check for an escape sequence.
c
integer function ichain (dummy)
include 'brzblk.for'
common /vterr/err1,err2,termnl !from vtsubs
letter=ichin()
if (letter.ge.97.and.letter.le.122) then !lower case letter
ichain=letter-32 !raise
else if (letter.eq.escape) then !an escape sequence, we hope !
if (termnl.eq.vt100) then
letter=ichin() !get the [ or ( or ?
if (letter.eq.opsqbr) then
letter=ichin()
if (letter.eq.a) then
ichain=uparow !up arrow
else if (letter.eq.b) then
ichain=dwnarw !down arrow
else if (letter.eq.c) then
ichain=ritarw !right arrow
else if (letter.eq.d) then
ichain=lftarw !left arrow
else
ichain=letter
end if
end if
else !vt52
letter=ichin() !get the control letter
if (letter.eq.a) then
ichain=uparow !up arrow
else if (letter.eq.b) then
ichain=dwnarw !down arrow
else if (letter.eq.c) then
ichain=ritarw !right arrow
else if (letter.eq.d) then
ichain=lftarw !left arrow
else
ichain=letter
end if
end if
else
ichain=letter
end if
return
end
c
c function to return the length of a string, terminated with a nul
c
integer function length(string)
include 'brzblk.for'
character*(*) string
length=index(string,char(0))
return
end
c
c routine to slide the (for) contents of an array by a given amount
c
subroutine slide(from,by,for)
include 'brzblk.for'
if (by.gt.0) then !slide up
do loc=from+for,from,-1
screen(loc+by)=screen(loc)
scrlev(loc+by)=scrlev(loc)
end do
else if (by.lt.0) then !slide down
do loc=from,from+for
screen(loc)=screen(loc-by) !by is negative
scrlev(loc)=scrlev(loc-by)
end do
do loc=from+for+1,from+for-by !clear the tail
screen(loc)=0
scrlev(loc)=0
end do
end if
return
end
c
c subroutine to garbage collect
c
subroutine gc
include 'brzblk.for'
dimension dadptr(maxrel),sonptr(maxrel)
character*80 gtxnod,gtxfil,buffer
write (unit=buffer,fmt=100) (ffslot*100)/lstsiz,
+ (fftext*100)/txtsiz,(mapcnt*100)/mapsiz
call cleol
call disply (buffer,1,1)
call curhom
c
c first check for any parentless nodes and delete them
c
do ptr=1,mapsiz
if (map(ptr).gt.0) then
call gtdads (ptr,dadcnt,dadptr)
if (dadcnt.le.0) then
call deletn (ptr)
end if
end if
end do
c
c copy the arrays to the temporary locations and clear the real ones
c
xtext=text
text=' '
call crmove(list,xlist,lstsiz)
call crclr (list,lstsiz,0)
ffslot=1
fftext=1
c
c now copy back, stepping our way through MAP.
c
mapcnt=0
do ptr=1,mapsiz
if (map(ptr).ne.0) then
mapcnt=mapcnt+1
call gtxdad(ptr,dadcnt,dadptr)
call gtxson(ptr,soncnt,sonptr)
call enter (ptr,gtxnod(ptr),gtxfil(ptr),
+ dadcnt,soncnt,dadptr,sonptr)
end if
end do
write (unit=buffer,fmt=101) (ffslot*100)/lstsiz,
+ (fftext*100)/txtsiz,(mapcnt*100)/mapsiz
call cleol
call disply (buffer,1,1)
call curhom
return
100 format
+ ('(GC)...List',i3,'% full, text',i3,'% full, map',i3,'% full')
101 format ('List',i3,'% full, text',i3,'% full, map',i3,'% full')
end
c
c routine to display the contents of a file on the screen
c
subroutine dspfil (file)
include 'brzblk.for'
character*(*) file,buffer*132,gtfils*80
open (unit=4,name=file,status='old',iostat=error)
if (error.eq.0) then
call scrrst !screen normal
eof=0
do while (eof.eq.0.and.ittinr().ne.space)
read (unit=4,fmt='q,a',iostat=eof)length,buffer
if (eof.eq.0.and.length.gt.0) then
write (unit=tty,fmt='1x,a') buffer(1:length)
else if (eof.eq.0.and.length.eq.0) then
write (unit=tty,fmt='1x')
end if
end do
close (unit=4)
if (eof.ne.0) then
write (unit=tty,fmt='t20,a')
+ '*** Press the space bar to continue.***'
do while (ichin().ne.space)
end do
end if
call scrset
call son
else
call cleol
call disply ('There is no information available'//
+ ' to you on this topic.',1,1)
call curhom
end if
return
end
c
c routine to display a module from a library on the screen
c
subroutine dspmod (file,module)
include 'brzblk.for'
character*(*) file,buffer*132,module
dimension ibuff (16)
call crlbop (file,module,jfn,from,error) !open module
if (error.eq.0) then
call scrrst !screen normal
do while (error.eq.0.and.ittinr().ne.space)!loop reading & writing
c call crlbrd (buffer,length,jfn,from,error)
c quick F 66 kludge
call crlbrd (ibuff,length,jfn,from,error)
call crsint (ibuff,buffer)
if (error.eq.0.and.length.gt.0) then
write (unit=tty,fmt='1x,a') buffer(1:length)
else if (error.eq.0.and.length.eq.0) then
write (unit=tty,fmt='1x')
end if
end do
if (error.ne.0) then !did user terminate ?
write (unit=tty,fmt='t20,a')
+ '*** Press the space bar to continue.***'
do while (ichin().ne.space)
end do
end if
call scrset !set up screen
call son
else
call cleol
call disply ('There is no information available'//
+ ' to you on this topic.',1,1)
if (edting) then
write (unit=buffer,fmt=100) error
call disply (buffer,1,58)
end if
call curhom
end if
return
100 format (' crlbop- error ',i2)
end
c
c routine to print a file
c
subroutine prtfil (file)
include 'brzblk.for'
character*(*) file,buffer*132,gtfils*80
open (unit=4,name=file,status='old',iostat=error)
if (error.eq.0) then
close (unit=4,dispose='print',status='keep')
call dsplev
call cleol
call disply ('Done.',1,1)
call curhom
else
call cleol
call disply ('There is no information available'//
+ ' to you on this topic.',1,1)
call curhom
end if
return
end
c
c Routine to print a module, from a library, on the line printer.
c
subroutine prtmod (file,module)
include 'brzblk.for'
character*(*) file,buffer*132,module
dimension ibuff (16)
call crlbop (file,module,jfn,from,error) !open module
if (error.eq.0) then
open (unit=4,device='lpt')
do while (error.eq.0) !loop reading & writing
c call crlbrd (buffer,length,jfn,from,error)
c quick F 66 kludge
call crlbrd (ibuff,length,jfn,from,error)
call crsint (ibuff,buffer)
if (error.eq.0.and.length.gt.0) then
write (unit=4,fmt='1x,a') buffer(1:length)
else if (error.eq.0.and.length.eq.0) then
write (unit=4,fmt='1x')
end if
end do
close (unit=4)
call cleol
call disply ('Done.',1,1)
call curhom
else
call cleol
call disply ('There is no information available'//
+ ' to you on this topic.',1,1)
if (edting) then
write (unit=buffer,fmt=100) error
call disply (buffer,1,58)
end if
call curhom
end if
return
100 format (' crlbop- error ',i2)
end
c
c routine to display text at a specified point
c
subroutine disply (words,row,col)
include 'brzblk.for'
character*(*) words
call putcrs (row,col)
call crsout (words//char(0))
return
end
c
c routine to display a given level of nodes on the screen
c
subroutine dsplev
include 'brzblk.for'
character*80 node,gtnode
dimension temp(maxrel)
c
c clear the screen and display the help line at the bottom by calling
c wizkid, which flips edting and redisplays the help message
c
call curhom
call cleos
edting=.not.edting
call wizkid
c
c now display the nodes
c
col=5
pageno=((scrloc-1)/22)+1
do row=2,23
depth=((pageno-1)*22)+row-1
locatn=screen(depth)
if (locatn.gt.0) then
node=gtnode(locatn)
if (scrloc.eq.depth) then
call disply('-->',row,1)
pointa=row
end if
call disply(node,row,col*scrlev(depth))
call gtsons (locatn,number,temp)
if (number.gt.0) then
call crsout (' ...'//char(0))
end if
end if
end do
call curhom
return
end
c The layout of the arrays of the nodes on display on the screen
c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
c screen scrlev (row) stalev(4) endlev(4) curlev=2
c |a | 1 1 1 row =4 (row on screen)
c |b | 1 2 pointa=4 (row with pointer)
c |c | 1 3 pageno=1 no. of screen on disp
c -->| d | 2 4 4 depth =((pageno-1)*22)+row-1
c place | e | 2 5 ie element in screen
c | f | 2 6 scrloc=depth of place
c | g | 3 7 7 place =screen(scrloc)
c | h | 3 8 ie where it is at -->
c | i| 4 9 9
c | j| 4 10 10(4)
c | k | 3 11 11(3)
c | l | 2 12 12(2)
c |m | 1 13
c |n | 1 14
c : : : : (1)