PROGRAM FILDEF
c**********************************************************************
c
c	FILEDEF.TSK
c
c	This program implements the FILEDEF command, for specifying file
c	specifications outside of FORTRAN programs at MCR level.
c	This program installs as ...FIL
c	Uses FORTRAN-77 OTS only, versions 4.0 or 4.1
c
c	Syntax:
c
c	(1) Add a new entry or replace an existing one:
c
c		FILEDEF  lun  filespec
c
c	(2) Delete an entry for a specific unit:
c
c		FILEDEF  lun
c
c	(3) Delete all entries for the issuing terminal:
c
c		FILEDEF 0
c
c	(4) List entries for current terminal session:
c
c		FILEDEF
c
c	Version 1.01	May 1982
c
c	Steve Thompson
c	School of Chemical Engineering
c	Olin Hall
c	Cornell University
c	Ithaca NY 14853
c	(607) 256 3895
c
c***********************************************************************
	include 'filparam.inc'
c
	byte cmdlin(80)
	integer*2 entry(8)
c
c-------Modify default OTS error handling
c
	call errset(28,.true.,.false.,.true.,.false.)	! Open errors
	call errset(29,.true.,.false.,.true.,.false.)	! ditto
	call errset(30,.true.,.false.,.true.,.false.)	! ditto
	call errset(35,.true.,.false.,.true.,.false.)	! Segment error on read
	call errset(43,.true.,.false.,,.false.)		! Filename error
	call errset(64,.true.,.false.,.true.,.false.)	! Formatting error
c
c-------Get MCR command line
c
	call getmcr(cmdlin,idsw)	! Get command line
	if(idsw.lt.1)then		! Error if none there
		type 901
		call exst(4)
		endif
	lencmd = idsw			! Save command length
c
c-------Skip over the command name and locate arguments
c
	do 100 i = 1,lencmd
	if(cmdlin(i).eq.' ')go to 120
100	continue
110	call list			! No params, must be List Function
	call exst(1)
120	i = i + 1			! Look at next character
	if(i.gt.lencmd)go to 110	! Might be line of spaces
	if(cmdlin(i).eq.' ')go to 120	! Look for first non-space
c
c-------Logical unit specification
c
	ilun1 = i			! Remember start of lun spec.
	ifile1 = 1			! Show us looking for filespec
130	i = i + 1
	if(i.gt.lencmd)then		! If at end, can't be any filespec
		ifile1 = 0		! Not looking for spec.
		go to 135
		endif
	if(cmdlin(i).ne.' ')go to 130	! Loop, looking for a space
135	ilun2 = i - 1			! Remember end of lun spec.
	if(ifile1.eq.0)go to 150	! Skip filespec.
c
c-------File specification
c
140	i = i + 1
	if(i.gt.lencmd)then
		type 902
		call exst(4)
		endif
	if(cmdlin(i).eq.' ')go to 140	! Loop, looking for non-blank
	ifile1 = i			! Filespec starts here
	ifile2 = lencmd			! Filespec ends here
c
c-------Validate logical unit specification. (Lun 0 is permitted for
c	the "delete all assignments" operation.
c
150	decode(ilun2-ilun1+1,801,cmdlin(ilun1),err=501) lun
	if((lun.lt.0).or.(lun.gt.maxlun))go to 501
c
c-------If no filespec, just clear assignment
c
	if(ifile1.eq.0)then
		call clear(lun)
		call exst(1)
		endif
	if(lun.eq.0)go to 501
c
c-------Validate filespec
c
	cmdlin(ifile2+1) = 0			! make filespec ASCIZ
	call chkspc(lun,cmdlin(ifile1),entry)	! and validate it
c
c-------Make new entry. If same as old entry, do nothing.
c
	call getrec			! Get lun information
	call openf			! Open data base file
	read(unit=1,rec=recnum) record	! Read current record
	isave = record(1,lun)		! Save first word of entry
	do 87 i = 1,8
	if(record(i,lun).ne.entry(i))go to 871
87	continue
	isave = 0			! Show that entry did not change
	go to 881			! Close file and exit
871	continue
c
	do 88 i = 1,8
	record(i,lun) = entry(i)	! Add new entry
88	continue
	write(unit=1,rec=recnum) record	! Re-write record
881	close(unit=1)			! Close data base
	if(isave.ne.0)type 904		! If we replaced an entry
c
c-------That's it
c
	call exst(1)
c
c-------Error returns
c
501	type 903,(cmdlin(j),j=ilun1,ilun2)
	call exst(4)
c
c-------Format statements
c
801	format(I<ilun2-ilun1+1>)
c
901	format(' FIL -- Command input error')
902	format(' FIL -- Syntax error')
903	format(' FIL -- Invalid logical unit specification - ',
	1      <ilun2-ilun1+1>A1)
904	format(' FIL -- Previous assignment replaced')
	end
	subroutine chkspc(lun,fspec,entry)
	byte fspec(*)
	integer*2 entry(8)
c**********************************************************************
c
c	This routine validates the file specification given in the
c	FIL command line, and fills in the relevant information in
c	the "entry" buffer.
c
c**********************************************************************
	integer*2 tskbuf(16),lunbuf(6)
	byte devnam(2),defn2(3)
	byte name(9),typ(3)
	logical period,semic
c
	data name / 9*' ' /
	data typ  / 3*' ' /
c
c-------Set defaults
c
	entry(1) = 'SY'			! Default device name
	entry(2) = 0			! Default unit number
	call gettsk(tskbuf,idsw)	! Get task information
	if(idsw.ne.1)then
		type 901
		call exst(4)
		endif
	entry(3) = tskbuf(8)		! Default UIC
	encode(3,801,defn2(1)) lun	! Convert part #2 of default name
	call irad50(3,'FOR',entry(4))	! Default filename
	call irad50(3,defn2,entry(5))	!
	call irad50(3,'   ',entry(6))	!
	call irad50(3,'DAT',entry(7))	! Default filetype
	entry(8) = 0			! Default version number
c
c-------Check device specification
c
	call index(fspec,':',icolon)	! Look for colon (:)
	if(icolon.eq.0)go to 100	! No device spec.
	fspec(icolon) = 0		! Make device ASCIZ
	if(icolon.lt.3)go to 501	! Nad news
	if(icolon.eq.3)then		! No unit number
		numdev = 0
		go to 90
		endif
	decode(icolon-3,802,fspec(3),err=501) numdev
90	devnam(1) = fspec(1)		! Copy device name
	devnam(2) = fspec(2)		!
	call asnlun(2,devnam,numdev,idsw) ! Assign lun #2 to device
	if(idsw.ne.1)go to 502		! If illegal device
	call getlun(2,lunbuf,idsw)	! Get device's real name
	if(idsw.ne.1)go to 503		! Whoops
	entry(1) = lunbuf(1)		! Save name of device
	entry(2) = ishft(ishft(lunbuf(2),8),-8) ! and number
	call copy(fspec(icolon+1),fspec(1)) ! Reform list
100	continue
c
c-------Check UFD specification
c
	if(fspec(1).ne.'[')go to 200	! If no UFD following
	call index(fspec,',',icomma)	! Look for comma
	if(icomma.eq.0)go to 504	! Error if none
	call index(fspec,']',iclose)	! Look for ]
	if(iclose.eq.0)go to 504	! Error if none
	if(iclose.lt.icomma)go to 504	! Error if ] before ,
	fspec(icomma) = 0		! Make group code ASCIZ
	fspec(iclose) = 0		! Make member code ASCIZ
	call ufd(fspec(2),igrp)		! Get group code
	call ufd(fspec(icomma+1),imem)	! Get member code
	entry(3) = ishft(igrp,8) + imem	! Save complete UIC
	call copy(fspec(iclose+1),fspec(1))
200	continue
c
c-------Check filename (NB Command will always be upper case)
c
	call index(fspec,'.',istop)	! Look for end of filename
	if(istop.eq.0)then
		period = .false.	! No .
		iname = lenstr(fspec)	! If no ., use whole string
	else
		period = .true.		! . found, explicit type
		iname = istop - 1	! Else use up to .
	endif
	if(iname.eq.0)go to 300		! Name is null
	if(iname.gt.9)go to 504		! Name too long
	do 210 i = 1,iname		! Check characters in name
	if((fspec(i).ge.'0').and.(fspec(i).le.'9'))go to 210
	if((fspec(i).ge.'A').and.(fspec(i).le.'Z'))go to 210
	go to 504			! Illegal characters
210	name(i) = fspec(i)		! Copy name
	call irad50(9,name,entry(4))	! Enter filename
300	continue
	if(istop.eq.0)return		! No string left
	call copy(fspec(istop+1),fspec(1)) ! Compress string
c
c-------Check filetype
c
	call index(fspec,';',ivers)	! Look for ;
	if(ivers.eq.0)then
		semic = .false.		! No ;
		itype = lenstr(fspec)	! No ;, use whole of string
	else
		semic = .true.		!
		itype = ivers - 1	! Else use up to ;
	endif
	if(itype.eq.0)then
		if(period)entry(7) = 0	! Explicit null filetype
		go to 400
		endif
	if(itype.gt.3)go to 504
	do 310 i = 1,itype
	if((fspec(i).ge.'0').and.(fspec(i).le.'9'))go to 310
	if((fspec(i).ge.'A').and.(fspec(i).le.'Z'))go to 310
	go to 504
310	typ(i) = fspec(i)
	call irad50(3,typ,entry(7))	! Enter filename
400	continue
	if(ivers.eq.0)return		! No string left
	call copy(fspec(ivers+1),fspec(1)) ! Compress string
c
c-------Check version number (NB -1 ==> oldest version)
c
	if(.not.semic)return		! No version specified
	if(fspec(1).eq.0)return		! Not specified
	len1 = lenstr(fspec)		! Get string length
	if(len1.eq.2)then		! Check for -1
		if((fspec(1).ne.'-').or.(fspec(2).ne.'1'))go to 405
		num = -1
		go to 410
		endif
405	decode(len1,803,fspec(1),err=504) num
	if(num.eq.0)return
	if(num.lt.0)go to 504
410	entry(8) = num
	return
c
c-------Error returns
c
501	type 902,(fspec(j),j=1,icolon)
	call exst(4)
502	type 903
	call exst(4)
503	type 904
	call exst(4)
504	type 905
	call exst(4)
c
c-------Format statements
c
801	format(I3.3)
802	format(O<icolon-3>)
803	format(O<len1>)
901	format(' FIL -- *FATAL* Get task parameters directive failed')
902	format(' FIL -- Illegal format for device specification - ',
	1 <icolon>A1)
903	format(' FIL -- Illegal device or unit')
904	format(' FIL -- *FATAL* Get unit information failure')
905	format(' FIL -- Illegal file specification')
	end
	subroutine ufd(str,num)
	byte str(*)
c*********************************************************************
c
c	This routine converts the ASCIZ string "str" into a group
c	or member code during parsing of the filespec. The task
c	will exit here if there is anything illegal.
c
c********************************************************************
	len1 = lenstr(str)
	if(len1.eq.0)go to 501
	decode(len1,801,str(1),err=501) num
	if((num.le.0).or.(num.gt.255))go to 501
	return
c
c--------Error exits
c
501	type 901
	call exst(4)
c
c-------Format statements
c
801	format(O<len1>)
901	format(' FIL -- Illegal directory specification')
	end
	subroutine clear(lun)
c**********************************************************************
c
c	This routine deletes the entry for logical unit "lun" for
c	the current terminal. If "lun" is zero, all assignments
c	are cleared.
c
c**********************************************************************
	include 'filparam.inc/nolist'
c
	call getrec		! Get information on TI:, unit #lun
	call openf		! Open data base file
	if(lun.eq.0)then
		do 10 i = 1,8
		do 10 j = 1,maxlun
		record(i,j) = 0
10		continue
		write(unit=1,rec=recnum) record
	else
		read(unit=1,rec=recnum) record
		do 20 i = 1,8
		record(i,lun) = 0
20		continue
		write(unit=1,rec=recnum) record
	endif
	close(unit=1)
	return
	end
	subroutine list
c**********************************************************************
c
c	This routine services the List function of FILEDEF.
c
c**********************************************************************
	include 'filparam.inc/nolist'
c
	byte name(9),type(3),buffer(80)
	data ittl /0/
c
c-------Open data base file and read record
c
	call getrec
	call openf
	read(unit=1,rec=recnum) record
	close(unit=1)
c
c-------Scan record and list entries
c
	ic = 0				! Listing counter
	call wtqio('1400'O,5,1)		! Attach to TI:
	do 100 i = 1,maxlun		! Loop over logical units
	if(record(1,i).eq.0)go to 100		! Entry not in use
	if(ittl.eq.0)type 503			! Print column heading
	ittl = 1				! Flag no further headings
	ic = ic + 1				! Count this entry
	igrp = ishft(record(3,i),-8)		! Get group code
	imem = ishft(ishft(record(3,i),8),-8)	! Get member code
	call r50asc(9,record(4,i),name(1))	! Filename --> ASCII
	call r50asc(3,record(7,i),type(1))	! Filetype --> ASCII
	if((record(8,i).eq.0).or.(record(8,i).eq.-1))then
		encode(80,500,buffer) record(1,i),record(2,i),igrp,imem,
	1			      name,type,0
	else
		encode(80,501,buffer) record(1,i),record(2,i),igrp,imem,
	1			      name,type,record(8,i),0
	endif
	lenout = lenstr(buffer)		! Length of filespec
	if(record(8,i).eq.-1)then
		buffer(lenout+1) = ';'	! Add ;-1 for oldest version
		buffer(lenout+2) = '-'
		buffer(lenout+3) = '1'
		lenout = lenout + 3
		endif
	ipos = 1
	do 110 j = 1,lenout		! Remove all spaces
	if(buffer(j).eq.' ')go to 110
	buffer(ipos) = buffer(j)
	ipos = ipos + 1
110	continue
	ipos = ipos - 1
	type 502,i,(buffer(j),j=1,ipos)
100	continue
	call wtqio('2000'O,5,1)		! Detach TI:
c
c-------Warning if no entries to list
c
	if(ic.eq.0)type 510
c
c-------That's it
c
	return
c
c-------Format statements
c
500	format(A2,O2,':[',O3,',',O3,']',9A1,'.',4A1)
501	format(A2,O2,':[',O3,',',O3,']',9A1,'.',3A1,';',O6,A1)
502	format(I5,5X,<ipos>A1)
503	format(2x,'LUN',5X,'File specification',/,
	1      2x,'---',5X,'------------------')
510	format(' FIL -- No assignments currently in use')
	end
	subroutine getrec
c*********************************************************************
c
c	This routine gets information about TI:, and sets up the
c	pointer recnum for proper access to the data base file.
c
c**********************************************************************
	include 'filparam.inc/nolist'
c
	dimension lunbuf(6)
c
c-------Get logical unit information on TI: (lun=5)
c
	call getlun(5,lunbuf,idsw)
	if(idsw.ne.1)then
		type 901
		call exst(4)
		endif
	if((lunbuf(1).eq.'TT').or.(lunbuf(1).eq.'VT'))go to 100
	type 902,lunbuf(1)
	call exst(4)
100	recnum = ishft(ishft(lunbuf(2),8),-8) + 1
	if(lunbuf(1).eq.'VT')recnum = recnum + maxtty + 1
	return
c
c-------Format statements
c
901	format(' FIL -- *FATAL* Get unit information failed')
902	format(' FIL -- *FATAL* TI: device is unknown - ',A2)
	end
	subroutine openf
c**********************************************************************
c
c	This routine is called to open the data base file. If there are
c	any errors, a severe error exit is taken on the fifth retry (there
c	is a 1-second pause between tries).
c
c**********************************************************************
c
	itry = 0			! Initialise attempt counter
10	itry = itry + 1			! Try once more
	open(unit=1,file='LB:[1,7]FILESPEC.SYS',status='old',
	1    access='direct',err=100)
	return
100	if(itry.eq.5)go to 501		! Hard error
	if(itry.eq.1)type 902		! Say that we're busy
	call mark(3,1,2,idsw)		! Mark time, flag #3
	if(idsw.ne.1)return		! If MRKT$ fails, just return
	call stopfr(3)			! Wait for event flag #3
	go to 10			! Try again
c
c-------Error returns
c
501	type 901
	call exst(4)
c
c-------Format statements
c
901	format(' FIL -- *FATAL* Unable to access data base file')
902	format(' FIL -- File Manager is busy. Please wait...')
	end
	function lenstr(str)
	byte str(*)
c*******************************************************************
c
c	This function returns the length of the ASCIZ string supplied
c	as the argument.
c
c*******************************************************************
c
	n = 1
10	if(str(n).eq.0)go to 20
	n = n + 1
	go to 10
20	lenstr = n - 1
	return
	end
	subroutine copy(str1,str2)
	byte str1(*),str2(*)
c*********************************************************************
c
c	This routine transfers characters from "str1" to "str2".
c	The output string is forced to be ASCIZ.
c
c*********************************************************************
c
	len1 = lenstr(str1)
	if(len1.eq.0)then
		str2(1) = 0
		return
		endif
	do 100 i = 1,len1
	str2(i) = str1(i)
100	continue
	str2(len1+1) = 0
	return
	end
	subroutine index(str,object,icol)
	byte str(*),object(*)
c**********************************************************************
c
c	This routine searches for the occurrence of string "object"
c	within string "str" and returns the position of the first
c	character position that starts the match in "icol". Only
c	one character in "object" is matched.
c
c***********************************************************************
c
	icol = 0			! Assume substring not found
	len1 = lenstr(str)		! Length of string to search
	if(len1.eq.0)return		! Can't find substring if too long
	do 100 i = 1,len1
	if(str(i).eq.object(1))go to 200
100	continue
	return
200	icol = i			! Found correct column
	return
	end