From:	CSBVAX::CSBVAX::MRGATE::"SMTP::CRVAX.SRI.COM::RELAY-INFO-VAX" 11-DEC-1988 01:18
To:	MRGATE::"ARISIA::EVERHART"
Subj:	UNDEL.2_OF_2


Received: From KL.SRI.COM by CRVAX.SRI.COM with TCP; Tue, 29 NOV 88 00:37:45 PDT
Received: from Xerox.COM by KL.SRI.COM with TCP; Tue, 29 Nov 88 00:14:06 PST
Received: from Burger.ms by ArpaGateway.ms ; 29 NOV 88 00:04:58 PST
Sender: "James_A._Gray.OsbuSouth"@Xerox.COM
Date: 29 Nov 88 00:04:30 PST (Tuesday)
Subject: UNDEL.2_OF_2
From: "James_A._Gray.OsbuSouth"@Xerox.COM
To: info-vax@kl.sri.COM
Reply-to: "Gray:OSBUSouth@Xerox.COM:Xerox.ns"@Xerox.COM
Message-ID: <881129-000458-4499@Xerox>

+-+-+-+ Beginning of part 2 +-+-+-+
X      call UPD2(%VAL(irab),record,length)
X      return
X      end
X      subroutine UPD2(rab,record,length)
Xc
X      include '($rabdef)'
Xc
X      integer SYS$UPDATE,SYS$FLUSH
X      byte record(length)
X      record /rabdef/ rab
Xc
Xc  $UPDATE then $FLUSH to RAB
Xc
X      rab.rab$l_rbf=%LOC(record(1))
X      rab.rab$w_rsz=length
X      iret=SYS$UPDATE(rab)
X      if(.not.iret) then
X         write(6,1000) rab.rab$l_sts,rab.rab$l_stv
X         go to 80
X      endif
X      iret=SYS$FLUSH(rab)
X      if(.not.iret) then
X         write(6,1000) rab.rab$l_sts,rab.rab$l_stv
X         go to 80
X      endif
X      return
X   80 print*,'Trouble writing the file header into the index file.'
X      print*,'You may not have enough privileges. Error text follows:'
X      call LIB$STOP(%VAL(iret))
X      return
Xc
X 1000 format(' RMS Status on $UPDATE: ',z8.8,' STV value: ',z8.8)
X 1010 format(' RMS Status on $FLUSH: ',z8.8,' STV value: ',z8.8)
X      end
X      subroutine PARSE(string,did)
Xc
X      include '($fabdef)'
X      include '($namdef)'
Xc
X      integer SYS$PARSE
X      integer*2 did(3),savdid(3)
X      character*(*) string
Xc
X      record /fabdef/ fab
X      record /namdef/ nam
Xc
Xc  Parse device//dir//'*.*' to get the directory id and device into
Xc  the NAM block
Xc
X      call MOV3(did,savdid)
X      fab.fab$b_bid=fab$c_bid
X      fab.fab$b_bln=fab$c_bln
X      nam.nam$b_bid=nam$c_bid
X      nam.nam$b_bln=nam$c_bln
X      fab.fab$l_nam=%LOC(nam)
X      fab.fab$l_fna=%LOC(string)
X      fab.fab$b_fns=LEN(string)
Xc
X      iret=SYS$PARSE(fab)
X      if(.not.iret) then
X         write(6,1010) fab.fab$l_sts,fab.fab$l_stv
X         print*,'Cannot find the directory you want.'
X         print*,'File will be put back into its original directory'
X         call MOV3(savdid,did)
X         return
X      endif
X      call MOV3(nam.nam$w_did,did)
X      return
Xc
X 1010 format(' RMS Status on $PARSE: ',z8.8,' STV value: ',z8.8)
X      end
X      subroutine ENTER(file,fid,did,device,result,rslen)
Xc
X      include '($iodef)'
X      include '($fibdef)'
Xc
X      integer SYS$ASSIGN,SYS$QIOW,fibdesc(2),iosb(2),rslen
X      integer*2 channel,fid(3),did(3)
X      character*(*) file,device,result
Xc
X      record /fibdef/ fib
Xc
Xc  Invoke ACP function to create a directory entry
Xc  This will complain if the directory isn't there (but file will be found
Xc  later by ANAL/DISK/REPAIR and put into [SYSLOST])
Xc
Xc  Get a channel to the device
Xc
X      iret=SYS$ASSIGN(device,channel,,)
X      if(.not.iret) then
X         write(6,1000) iret
X         go to 80
X      endif
Xc
Xc  Create the directory entry
Xc
X      fibdesc(1)=22
X      fibdesc(2)=%LOC(fib)
X      call MOV3(did,fib.fib$w_did)
X      call MOV3(fid,fib.fib$w_fid)
X      fib.fib$w_nmctl=fib$m_newver
X      iret=SYS$QIOW(,%VAL(channel),%VAL(io$_create),iosb,,,
X     &              fibdesc,file,rslen,result,,)
X      if(iret) iret=iosb(1)
X      if(iret) return
Xc
Xc  Error entering the file in the directory
Xc
X      write(6,1000) iret
X   80 print*,'The file has not been entered in a directory.'
X      print*,'ANALYZE/DISK/REPAIR is required to put it in [SYSLOST]'
X      rslen=0
X      return
X 1000 format(' $ASSIGN status: ',z8.8)
X 1010 format(' $QIOW status on CREATE: ',z8.8)
X      end
X      subroutine MOV3(fid,blkfid)
Xc
X      integer*2 fid(3),blkfid(3)
Xc
Xc  Move a 3-word fid
Xc
X      blkfid(1)=fid(1)
X      blkfid(2)=fid(2)
X      blkfid(3)=fid(3)
X      return
X      end
X      subroutine RPOINTER(map,lbncount,lbnstart,m)
Xc
X      integer*2 map(*)
Xc
Xc  Break the count and start fields out of a retrieval pointer
Xc  Handle the 3 formats of 'em that exist
Xc  Bump m by the # of bytes in the pointer found
Xc
X      itype=LIB$EXTZV(14,2,map(1))
X      if(itype.eq.0) then`009`009! Placement word or junk
X         lbncount=0
X         lbnstart=0
X      else if(itype.eq.1) then`009`009! 4-byte short form
X         lbncount=LIB$EXTZV(0,8,map(1))+1
X         lbnstart=map(2)+65536*LIB$EXTZV(8,6,map(1))
X      else if(itype.eq.2) then`009`009! 6-byte medium form
X         lbncount=LIB$EXTZV(0,14,map(1))+1
X         lbnstart=map(2)+65536*map(3)
X      else if(itype.eq.3) then`009`009! 8-byte long form
X         lbncount=map(2)+65536*LIB$EXTZV(0,14,map(1))+1
X         lbnstart=map(3)+65536*map(4)
X      endif
X      j=(itype+1)*2
X      m=m+j
X      if(itype.eq.0) return
X      write(6,'(2i6,4(1x,z4.4))') lbncount,lbnstart,(map(i),i=1,itype+1)
X      return
X      end
X      integer function LENBL(string)
Xc
X      character*(*) string
Xc
Xc  Returns the length of a character string, ignoring trailing blanks
Xc
X      do 20 l=LEN(string),1,-1
X   20   if(string(l:l).ne.' ') go to 40
X      l=0
X   40 LENBL=l
X      return
X      end
X
$ GOSUB UNPACK_FILE
$ FILE_IS = "CHECKSUM.MAR"
$ CHECKSUM_IS = 2115527063
$ COPY SYS$INPUT VMS_SHARE_DUMMY.DUMMY
X`009.title`009CHECKSUM - Compute checksum: Call CHECKSUM(record)
X;
X`009.psect`009CHECKSUM$CODE,nowrt,exe,quad
X;
X`009.ENTRY`009CHECKSUM, `094M<R2>
X`009CLRL`009R1`009`009`009; Accumulate checksum in R1.
X`009MOVL`0094(AP), R2`009`009; Header address into R2.
X`009MOVZBL`009#255, R0`009`009; Loop counter into R0.
X;
X10$:`009ADDW2`009(R2)+, R1`009`009; Compute checksum.
X`009SOBGTR`009R0, 10$
X;
X`009MOVW`009R1, (R2)`009`009; Store computed checksum.
X`009RET
X`009.END
X
$ GOSUB UNPACK_FILE
$ EXIT
-+-+-+-+-+ End of part 2 +-+-+-+-+-

