zar@HAMLET.CALTECH.EDU (Dan Zirin) (06/30/87)
$!------------------------------Cut Here-------------------------
$ chk = "236487385"
$ create nf5.for
$ deck/dollars="ThEgReAtZaR"
5 if (inline(1:7).eq.'ADDACC') then
i='fffffffe'x.or.disable
if (i.ne.'ffffffff'x) call account(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:4).eq.'DIE') then
if (uict(2).gt.sysgrp) goto 4
i='fffffffd'x.or.disable
if (i.ne.'ffffffff'x) call nan$die
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
dumy = nan$_normal
else if (inline(1:6).eq.'ENTER') then
if (uict(2).gt.sysgrp) goto 4
i='fffffffb'x.or.disable
if (i.ne.'ffffffff'x) call forget(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:7).eq.'FORGET') then
if (uict(2).gt.sysgrp) goto 4
i='fffffff7'x.or.disable
if (i.ne.'ffffffff'x) call forget(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:5).eq.'FREE') then
if (uict(2).gt.sysgrp) goto 4
i='ffffffef'x.or.disable
if (i.ne.'ffffffff'x) call alloc(inline,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:5).eq.'GRAB') then
if (uict(2).gt.sysgrp) goto 4
i='ffffffdf'x.or.disable
if (i.ne.'ffffffff'x) call alloc(inline,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:7).eq.'IGNORE') then
if (uict(2).gt.sysgrp) goto 4
i='ffffffbf'x.or.disable
if (i.ne.'ffffffff'x) call listener(0)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
dumy = nan$_normal
else if (inline(1:5).eq.'KILL') then
i='ffffff7f'x.or.disable
if (i.ne.'ffffffff'x) call kill(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:7).eq.'LISTEN') then
if (uict(2).gt.sysgrp) goto 4
i='fffffeff'x.or.disable
if (i.ne.'ffffffff'x) call listener(1)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
dumy = nan$_normal
else if (inline(1:4).eq.'NEW') then
if (uict(2).gt.sysgrp) goto 4
i='fffffdff'x.or.disable
if (i.ne.'ffffffff'x) call new_log(dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:4).eq.'ODIS') then
i='fffffbff'x.or.disable
if (i.ne.'ffffffff'x) call oprman(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:3).eq.'OEN') then
i='fffff7ff'x.or.disable
if (i.ne.'ffffffff'x) call oprman(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:7).eq.'QSTART') then
i='ffffefff'x.or.disable
if (i.ne.'ffffffff'x) call queman(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:6).eq.'QSTOP') then
i='ffffdfff'x.or.disable
if (i.ne.'ffffffff'x) call queman(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:8).eq.'REQUEUE') then
i='ffffbfff'x.or.disable
if (i.ne.'ffffffff'x) call queman(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:7).eq.'RESUME') then
if (uict(2).gt.sysgrp) goto 4
i='ffff7fff'x.or.disable
if (i.ne.'ffffffff'x) call kill(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:5).eq.'STOP') then
i='fffeffff'x.or.disable
if (i.ne.'ffffffff'x) call kill(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:8).eq.'SUSPEND') then
if (uict(2).gt.sysgrp) goto 4
i='fffdffff'x.or.disable
if (i.ne.'ffffffff'x) call kill(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:5).eq.'WAKE') then
i='fffbffff'x.or.disable
if (i.ne.'ffffffff'x) call waker(inline,1,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:5).eq.'WCLR') then
i='fff7ffff'x.or.disable
if (i.ne.'ffffffff'x) call wakeclr(inline,uict,dumy)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
else if (inline(1:6).eq.'WSHOW') then
i='ffefffff'x.or.disable
if (i.ne.'ffffffff'x) call showake(retmbx)
if (i.eq.'ffffffff'x) dumy = nan$_comdis
if (i.eq.'ffffffff'x) goto 1
dumy = nan$_normal
else
call output(1,'Received unknown message: '//
1 inline(:len1(inline)))
dumy = nan$_nosuchcom
end if
if (.not.startup_flg) goto 3
999 do i=1,128
inbuff(i)=0
end do
call loop
return
1 call output(1,inline(1:funct_l)//' command aborted. '//
1 'Function disabled.')
3 code=sys$qio(,%val(retmbx),%val('70'x),,,,dumy,%val(1),,,,)
call bug(code,'QIO')
code=sys$dassgn(%val(retmbx))
call bug(code,'DASSGN')
goto 999
2 call output(1,inline(1:funct_l)//' command aborted. '//
1 'No return mailbox.')
goto 999
4 call output(1,inline(1:funct_l)//' command aborted. Non-'//
1 'system user.')
dumy = nan$_nonsys
goto 3
end
integer*4 function nanjpi()
c
c Do random getjpi on system(needs WORLD privilege)
c
c (c) Zar Ltd. 1985
c
parameter maxwait = '0 0:0:2.0'
implicit integer*4 (a-z)
include 'nanny.inc'
include '($dvidef)'
include '($jpidef)'
include '($ssdef)'
integer*4 dvilist(4),jpilist(55),qwait(2)
integer*4 gpgcnt,ppgcnt
c
c Initialize
c
c_account = ' '
c_authpriv(1) = 0
c_authpriv(2) = 0
c_bufio = 0
c_cpulim = 0
c_cputim = 0
c_dirio = 0
gpgcnt = 0
c_owner = 0
c_pageflts = 0
c_phy_term = ' '
c_pid = 0
ppgcnt = 0
c_prccnt = 0
c_prib = 0
c_ipid = 0
c_sts = 0
c_terminal = ' '
c_uic(1) = 0
c_uic(2) = 0
c_username = ' '
jpilist(1) = jpi$_account *2**16 + 8
jpilist(2) = %loc(c_account)
jpilist(3) = 0
jpilist(4) = jpi$_authpriv *2**16 + 8
jpilist(5) = %loc(c_authpriv)
jpilist(6) = 0
jpilist(7) = jpi$_bufio *2**16 + 4
jpilist(8) = %loc(c_bufio)
jpilist(9) = 0
jpilist(10) = jpi$_cpulim *2**16 + 4
jpilist(11) = %loc(c_cpulim)
jpilist(12) = 0
jpilist(13) = jpi$_cputim *2**16 + 4
jpilist(14) = %loc(c_cputim)
jpilist(15) = 0
jpilist(16) = jpi$_dirio *2**16 + 4
jpilist(17) = %loc(c_dirio)
jpilist(18) = 0
jpilist(19) = jpi$_gpgcnt *2**16 + 4
jpilist(20) = %loc(gpgcnt)
jpilist(21) = 0
jpilist(22) = jpi$_owner *2**16 + 4
jpilist(23) = %loc(c_owner)
jpilist(24) = 0
jpilist(25) = jpi$_pageflts *2**16 + 4
jpilist(26) = %loc(c_pageflts)
jpilist(27) = 0
jpilist(28) = jpi$_pid *2**16 + 4
jpilist(29) = %loc(c_pid)
jpilist(30) = 0
jpilist(31) = jpi$_ppgcnt *2**16 + 4
jpilist(32) = %loc(ppgcnt)
jpilist(33) = 0
jpilist(34) = jpi$_prccnt *2**16 + 2
jpilist(35) = %loc(c_prccnt)
jpilist(36) = 0
jpilist(37) = jpi$_prib *2**16 + 2
jpilist(38) = %loc(c_prib)
jpilist(39) = 0
jpilist(40) = jpi$_proc_index *2**16 + 4
jpilist(41) = %loc(c_ipid)
jpilist(42) = 0
jpilist(43) = jpi$_sts *2**16 + 4
jpilist(44) = %loc(c_sts)
jpilist(45) = 0
jpilist(46) = jpi$_terminal *2**16 + 10
jpilist(47) = %loc(c_terminal)
jpilist(48) = 0
jpilist(49) = jpi$_uic *2**16 + 4
jpilist(50) = %loc(c_uic)
jpilist(51) = 0
jpilist(52) = jpi$_username *2**16 + 12
jpilist(53) = %loc(c_username)
jpilist(54) = 0
jpilist(55) = 0
dvilist(1) = dvi$_tt_phydevnam *2**16 + 10
dvilist(2) = %loc(c_phy_term)
dvilist(3) = 0
dvilist(4) = 0
nanjpi = ss$_normal
c
c Convert MAXWAIT to system time
c
code = sys$bintim(maxwait,qwait)
if (code.ne.ss$_normal) then
nanjpi = ss$_abort
return
end if
c
c Set a timer
c
code = sys$setimr(%val(1),qwait,,%val(3))
if (code.eq.ss$_normal) then
c
c Do the $GETJPI service
c
jpicode = sys$getjpi(%val(2),ranjpipid,,jpilist,,,)
if (jpicode.eq.ss$_normal) code = sys$wflor(%val(1),
1 %val(2**1.or.2**2))
end if
c_wssize = gpgcnt + ppgcnt
if (lench(c_terminal).gt.0) then
if (index(c_terminal,':').eq.0) c_terminal =
1 c_terminal(:len1(c_terminal))//':'
c
c Get the physical terminal name if a terminal field exists
c First cancel the previous timer if its still alive and set a
c new timer
c
code = sys$cantim(%val(3),)
code = sys$setimr(%val(1),qwait,,%val(3))
if (code.eq.ss$_normal) then
c
c Do the $GETDVI service
c
dvicode = sys$getdvi(%val(17),,c_terminal,dvilist,,,,)
if (dvicode.eq.ss$_normal) code = sys$wflor(%val(1),
1 %val(2**1.or.2**17))
end if
end if
c
c Clear R0 and return
c
code = sys$cantim(%val(3),)
nanjpi = jpicode
return
end
ThEgReAtZaR
$ checksum nf5.for
$ if chk.nes.checksum$checksum then write sys$output -
"NF5.FOR didn't pass checksum. File may be corrupted."
$ if chk.nes.checksum$checksum then exit %x2c
$ exit