;.MCALL SCAT11,EXIT$S,OPEN$,CLOSE$,FINIT$,GET$,READ$,PUT$,WRITE$,WAIT$,GCML$
.MCALL SMACIT,EXIT$S,OPEN$,CLOSE$,FINIT$,GET$,READ$,PUT$,WRITE$,WAIT$,GCML$
.MCALL CSI$1,CSI$2,DIR$,ALUN$S,GLUN$S,FDAT$R,FDRC$R,FDBF$R
;SCAT11
SMACIT
.ENABL LC
;
;*+*
BEGINMODULE TAR,01.00,10-NOV-83
;
;COPYRIGHT (c) 1983
;SSG
;BOX #1595
;NORTH WALES, PA  19454
;USA
;
;THIS SOFTWARE IS THE EXCLUSIVE PROPERTY OF SSG
;AND IS FURNISHED ONLY UNDER THE TERMS OF A LICENSE FOR A SINGLE CPU. ANY
;OTHER USE OF THIS SOFTWARE EXCEPT UNDER THE TERMS OF THE ABOVE NOTED
;SINGLE-USE LICENSE IS A VIOLATION BOTH OF THE OWNERSHIP RIGHTS OF SSG
;AND THE SOFTWARE LICENSE AGREEMENT UNDER WHICH
;THIS SOFTWARE WAS OBTAINED, AND IS STRICTLY PROHIBITED.
;
;THIS ROUTINE WILL:
;
;			1) LIST A UNIX TAR FLOPPY VOLUME.
;			2) INITIALIZE A UNIX TAR FLOPPY VOLUME.
;			3) COPY FILES-11 FD.CR AND FD.FTN ASCII FILES
;			   TO A TAR FLOPPY VOLUME IN UNIX <NEWLIN> FOR-
;			   MAT.
;			4) COPY FILES-11 UNFORMATTED(IMAGE) FILES TO
;			   A TAR FLOPPY VOLUME IN UNIX IMAGE FORMAT.
;			5) COPY UNIX IMAGE FILES FROM A TAR FLOPPY
;			   VOLUME TO FILES-11 UNFORMATTED(IMAGE) FILES.
;			6) COPY UNIX <NEWLIN> FORMATED FILES FROM A
;			   TAR FLOPPY VOLUME TO FILES-11 FD.CR ASCII
;			   FILES.
;
;COMMAND LINE VARIANTS ARE:
;
;			>TAR DDNN:[/LIST][/INIT][/TK]
;			>TAR DDNN:[/INIT][/TK]=FILSPEC1,FILSPEC2,...
;			>TAR =DDNN:/FILE:N1[/IMAGE][/NEWLIN][/TK],/FILE:N2,...
;			>TAR =DDNN:/ALL[/IMAGE][/NEWLIN][/TK]
;
;WHERE:
;
;		DDNN: REPRESENTS THE FLOPPY DEVICE MNEMONIC, DY OR DX,
;		AND NN REPRESENTS THE UNIT NUMBER
;
;		/LI OR /LIST IS THE LIST SWITCH
;		/INIT IS THE INITIALIZATION SWITCH
;		/TK IS THE TEKTRONIX FORMAT SWITCH - UNIX VOLUME WILL
;		BE IN TEKTRONIX FORMAT(NO INTERLEAVE, NO SKEW); BE
;		PATIENT, /TK IS SLOOOOOOOWWWWWWWW
;		/FILE:N IS THE UNIX FILE NUMBER SWITCH AND N IS THE FILE
;		NUMBER AS OBTAINED FROM THE TAR VOLUME LISTING(/LI)
;		/ALL IS THE ALL FILES SWITCH
;		/IM OR /IMAGE IS THE IMAGE SWITCH WHICH FORCES AN
;		IMAGE COPY.
;		/NE OR /NEWLIN IS THE NEWLIN SWITCH WHICH FORCES
;		<NEWLIN> -> FD.CR CONVERSION.
;
;		MULTI-LEVEL INVOCATION IS SUPPORTED AS IS A SINGLE
;		LEVEL OF FILE INDIRECTION
;
;NOTES:
;
;	1) NOTE THAT IN COPYING FROM RSX -> UNIX, THE OUTPUT FORMAT IS
;	   DETERMINED FROM THE (INPUT) FILES-11 FILE ATTRIBUTES.
;	2) NOTE THAT IN COPYING FROM UNIX -> RSX, THE OUTPUT FORMAT IS
;	   DETERMINED FROM THE /IMAGE OR /NEWLIN SWITCH: THIS PRESUPPOSES
;	   THAT YOU KNOW THE FORMATS OF THE FILES ON THE TAR VOLUME.
;	   IF YOU DON'T, TRY /NEWLIN FORMAT FIRST, IF IT'S NOT <NEWLIN>
;	   FORMAT, THE COPY WILL FAIL ON BUFFER OVERFLOW. A <NEWLIN>(TEXT)
;	   FILE COPIED IN /IMAGE FORMAT WILL HAVE <LF> AS THE LINE
;	   TERMINATOR.
;	3) NOTE THAT IN COPYING FROM UNIX -> RSX, AN OUTPUT FILENAME
;	   IS NOT ALLOWED: THE RSX FILENAME IS OBTAINED BY MAPPING THE
;	   UNIX FILENAME AS DESCRIBED BELOW. OUTPUT DEVICE(DDNN:) AND
;	   UIC([GGG,MMM]) ARE ALLOWED. TI: IS A VALID OUTPUT DEVICE.
;	4) FILES-11 FILE NAMES ARE NOT MAPPED TO UNIX FILENAMES(UC->LC)
;	5) FILES-11 VERSION NUMBERS ARE NOT RETAINED
;	6) UNIX FILE NAMES ARE MAPPED AS FOLLOWS:
;		LOWER CASE LETTERS -> UPPER CASE LETTERS.
;		ILLEGAL CHARACTERS -> UPPER CASE 'Q'.
;		'.' DELIMITS FILENAME AND FILETYPE.
;		NULL UNIX FILENAMES -> UPPER CASE 'Q'.
;		THE FIRST NINE MAPPED CHARACTERS EXCEPT '.' DEFINE
;		THE FILES-11 FILENAME.
;		THE NEXT THREE MAPPED CHARACTERS EXCEPT '.' DEFINE
;		THE FILES-11 FILETYPE.
;	7) /LIST AND /INIT ARE MUTUALLY EXCLUSIVE
;	8) /IMAGE AND /NEWLIN ARE MUTUALLY EXCLUSIVE FOR A GIVEN FILE
;	9) IF /IMAGE OR /NEWLIN IS NOT SPECIFIED, /IMAGE IS THE DEFAULT
;	10) ONCE ASSERTED, /IMAGE OR /NEWLIN HOLD FOR THE BALANCE OF
;	   THE INPUT STRING UNLESS SUPERCEDED.
;	11) THE UNIX FILE CREATION DATE AND TIME IS NOT SUPPORTED
;	12) THE FILES-11 DEFAULT UIC [GROUP,MEMBER] IS MAPPED TO
;	   THE UNIX GROUPID AND USERID, RESPECTIVELY.
;	13) ALL UNIX FILES CREATED WITH THIS PROGRAM WILL HAVE {rwx}
;	    ACCESS PRIVILEGE FOR USER, GROUP, AND WORLD.
;	14) UNUSED PORTIONS OF THE LAST BLOCK OF A UNIX FILE ARE PADDED
;	    WITH NULLS.
;	15) EMBEDDED UNIX PATH NAMES ARE IGNORED.
;	16) RX03(DOUBLE SIDED-DOUBLE DENSITY) SUPPORT IS PRESENT
;	17) UNLIKE UNIX tar, RSX TAR CAN APPEND A FILE TO A TAR VOLUME
;*-*
;
.MACRO $CALLR TGT
JMP TGT
.ENDM
.MACRO TRHDF
.ASECT
.=0
HEADER:
FILNAM:
	.BLKB 100.
ACCESS:
	.BLKB 8.
USERID:
	.BLKB 8.
GRUPID:
	.BLKB 8.
BYTCNT:
	.BLKB 12.
FILTIM:
	.BLKB 12.
CHKSUM:
	.BLKB 6.
ENDCHK:
	.BLKB 2.
ENDHDR:
.=0
.PSECT
.MACRO TRHDF
.ENDM
.ENDM
;
TRHDF
;
LCR = 'r
LCW = 'w
LCX = 'x
SEMI=73
SLASH=57
;
.PAGE
.SBTTL COMMAND LINE PROCESSING AND DISPATCH
;
;
;
ENTRYPOINT TAR,LOCAL
;
FINIT$					;INIT FILE SYSTEM
ALUN$S #CMDLUN,#"TI,#0			;ASSIGN COMMAND I/O LUN
ALUN$S #MSGLUN,#"TI,#0			;ASSIGN MESSAGE LUN
REPEAT					;
  GCML$ #GETCMD				;RETRIEVE COMMAND LINE
  ON.ERROR				;OOPS
    IFB G.ERR(R0) NE #GE.EOF		;EOF(CTRL/Z)?
      $CALL ERROR <#0>			;NOPE, SIGNAL
    END					;
    EXIT$S				;LEAVE
  END					;
  IF G.CMLD(R0) EQ #0 THEN RESTART LOOP	;IGNORE NULL LINES AND RETRY
  CSI$1 #CSIBLK,<GETCMD+G.CMLD+2>,<GETCMD+G.CMLD> ;PRE-PROCESS COMMAND LINE
  ON.ERROR				;OOPS, SYNTAX ERROR
    $CALL ERROR <#1>			;SIGNAL
  ELSE					;OK
    IFB #CS.EQU CLEARED.IN C.STAT(R0)	;UNIX VOLUME MANIPULATION?
      $CALL VOLUME <R0>			;YUP, PROCESS VOLUME REQUEST
    ELSE				;NOPE
      $CALL COPY <R0>			;PROCESS COPY REQUEST
    END					;
  END					;
END
.PAGE
.SBTTL VOLUME MANIPULATION FUNCTIONS
;
;
;
PROCEDURE VOLUME,GLOBAL
;
CSI$2 R0,OUTPUT,#VOLSWT			;PARSE FOR VOLUME MANIPULATION SPEC
ON.ERROR				;OOPS
  $CALL ERROR <#2>			;SIGNAL
ELSE					;OK
  LET OUTMKW := C.MKW1(R0)		;COPY SWITCH MASK WORD
  LETB OUTMKW+1 := #UNIX		;ASSERT UNIX OPERATION
  LET INMKW := OUTMKW			;INPUT IS SAME AS OUTPUT FOR VOL OPS
  IFB #CS.NMF!CS.DIF!CS.WLD!CS.MOR SET.IN C.STAT(R0) ;YUP, ANY SPEC ERRORS?
    $CALL ERROR <#2>			;YUP, SIGNAL
  ELSE					;NOPE, NO SPEC ERRORS
    IFB #CS.DVF CLEARED.IN C.STAT(R0)	;DEVICE NAME PRESENT?
      $CALL ERROR <#2>			;NOPE, SIGNAL
    ELSE				;YUP, DEVICE NAME PRESENT
      LET R1 := C.DEVD+2(R0)		;YUP, GET POINTER TO DEVICE STRING
      PUSHB (R1)+			;GET FIRST CHARACTER
      LETB 1(SP) := (R1)		;GET SECOND CHARACTER
      POP R1				;SET DEVICE NAME
      IF R1 NE #"DY AND R1 NE #"DX	;FLOPPY DEVICE?
	$CALL ERROR <#3>		;NOPE, SIGNAL ERROR
      ELSE				;YUP, FLOPPY DEVICE
	IF #INIMSK SET.IN OUTMKW	;INIT VOLUME?
	  IF #LSTMSK SET.IN OUTMKW	;YUP, AND LIST TOO?
	     $CALL ERROR <#4>		;YUP, CAN'T DO BOTH, SIGNAL
	  ELSE				;NOPE, NOT BOTH
	    $CALL INITVOL <C.DEVD+2(R0)>;INITIALIZE VOLUME
	  END				;
	ELSE				;NOPE, PERHAPS LIST VOLUME
	  IF #LSTMSK SET.IN OUTMKW	;LIST VOLUME?
	    $CALL LISTVOL <C.DEVD+2(R0)>;YUP, DO IT
	  ELSE				;NOPE, NOTHING TO DO
	    $CALL ERROR <#5>		;SIGNAL
	  END				;
	END				;
      END				;
    END					;
  END					;
END					;
$RETURN					;
.PAGE
.SBTTL COPY FUNCTIONS
;
;
;
PROCEDURE COPY,GLOBAL
;
CSI$2 R0,OUTPUT,#OUTSWT			;PARSE FOR OUTPUT SPECIFICATION
ON.ERROR				;OOPS
  $CALL ERROR <#2>			;SIGNAL
  $RETURN				;
END					;
LET OUTMKW := C.MKW1(R0)		;COPY SWITCH MASK WORD
IFB #CS.NMF!CS.WLD!CS.MOR SET.IN C.STAT(R0) ;ANY SPEC ERRORS?
  $CALL ERROR <#2>			;YUP, SIGNAL
  $RETURN				;
END					;
IFB #CS.DIF SET.IN C.STAT(R0)		;DIRECTORY STRING PRESENT?
  IF OUTMKW NE #0			;YUP, AND UNIX SWITCHES TOO?
    $CALL ERROR <#2>			;YUP, ERROR, SIGNAL
    $RETURN				;
  END					;
  LETB OUTMKW+1 := #RSX			;ASSERT OUTPUT
ELSE					;NOPE
  IFB #CS.DVF CLEARED.IN C.STAT(R0)	;DEVICE NAME PRESENT?
    IF OUTMKW NE #0			;NOPE, BUT UNIX SWITCHES PRESENT?
      $CALL ERROR <#2>			;YUP, ERROR, SIGNAL
      $RETURN				;
    END					;
    LETB OUTMKW+1 := #RSX		;ASSERT OUTPUT
  ELSE					;YUP
    LET R1 := C.DEVD+2(R0)		;POINT TO DEVICE STRING
    PUSHB (R1)+				;GET FIRST CHAR
    LETB 1(SP) := (R1)			;AND THE SECOND
    POP R1				;RETRIEVE DEVICE
    IF R1 EQ #"DY OR R1 EQ #"DX		;FLOPPY DEVICE?
      IF OUTMKW NE #0			;YUP, UNIX ASSERTED?
        LETB OUTMKW+1 := #UNIX		;YUP, ASSERT OUTPUT
      END				;N.B.! AMBIGUITY POSSIBLE HERE
    ELSE				;NOPE
      IF OUTMKW NE #0			;UNIX ASSERTED?
        $CALL ERROR <#3>		;YUP, ERROR, SIGNAL
	$RETURN				;
      END				;
      LETB OUTMKW+1 := #RSX    		;ASSERT OUTPUT
    END					;
  END					;
END					;
IFB #CS.DIF SET.IN C.STAT(R0)		;DIRECTORY STRING PRESENT?
  LET R1 := C.DIRD+2(R0)		;YUP, GET ADDRESS OF STRING
  LET R2 := C.DIRD(R0)			;AND ITS SIZE
  LET UIC := R2				;STUFF THE SIZE
  LET R3 := UIC+2			;GET STORAGE POINTER
  THRU R2				;LOOP TO COPY DIRECTORY STRING
    LETB (R3)+ := (R1)+			;
  END					;
ELSE					;NOPE
  LET UIC := #0				;SAY SO
END					;
IFB #CS.DVF SET.IN C.STAT(R0)		;DEVICE STRING PRESENT?
  LET R1 := C.DEVD+2(R0)		;YUP, GET ADDRESS OF STRING
  LET R2 := C.DEVD(R0)			;AND ITS SIZE
  LET DEVICE := R2			;STUFF THE SIZE
  LET R3 := DEVICE+2			;GET STORAGE POINTER
  THRU R2				;LOOP TO COPY DEVICE STRING
    LETB (R3)+ := (R1)+			;
  END					;
  LETB (R3) := #':			;APPEND DELIMITER FOR UNIX OUTPUT
ELSE					;NOPE
  LET DEVICE := #0			;SAY SO
END					;
IFB OUTMKW+1 EQ #UNIX			;UNIX OUTPUT?
  LET C.SWAD(R0) := #0			;YUP, RSX INPUT REQ'D, CLEAR SWITCH TBL
ELSE					;NOPE, RSX OR AMBIGUOUS
  LET C.SWAD(R0) := #INSWT		;SET FOR POSSIBLE UNIX INPUT
END					;
CSI$2 R0,INPUT				;PARSE FOR INPUT SPECIFICATION
ON.ERROR				;OOPS
  $CALL ERROR <#2>			;SIGNAL
  $RETURN				;ESCAPE
END					;
LET INMKW := C.MKW1(R0)			;COPY SWITCH MASK WORD
IFB #CS.WLD SET.IN C.STAT(R0)		;ANY SPEC ERRORS?
  $CALL ERROR <#2>			;YUP, SIGNAL
  $RETURN				;ESCAPE
END					;
IFB #CS.NMF SET.IN C.STAT(R0)		;FILENAME STRING PRESENT?
  IF INMKW NE #0			;YUP, UNIX SWITCHES TOO?
    $CALL ERROR <#2>			;YUP, ERROR, SIGNAL
    $RETURN				;
  ELSE					;NOPE
    LETB INMKW+1 := #RSX		;ASSERT INPUT
  END					;
ELSE					;NOPE, NO FILENAME PRESENT
  IFB #CS.DIF SET.IN C.STAT(R0)		;DIRECTORY STRING PRESENT?
    $CALL ERROR <#2>			;YUP, ERROR, SIGNAL
    $RETURN				;
  ELSE					;NOPE, NO DIRECTORY STRING PRESENT
    IFB #CS.DVF SET.IN C.STAT(R0) AND INMKW NE #0 ;DVC STRING + UNIX SWITCHES?
      LET R1 := C.DEVD+2(R0)		;YUP, POINT TO DEVICE STRING
      PUSHB (R1)+			;GET FIRST CHAR
      LETB 1(SP) := (R1)		;GET SECOND CHARACTER
      POP R1				;RETRIEVE DEVICE
      IF R1 EQ #"DY OR R1 EQ #"DX	;FLOPPY DEVICE?
	IF #FILMSK SET.IN INMKW		;YUP, FILE SWITCH PRESENT?
	  IF #ALLMSK CLEARED.IN INMKW	;YUP, ALL SWITCH ABSENT?
	    LETB INMKW+1 := #UNIX	;NOPE, ASSERT INPUT
	  ELSE				;YUP, ALL SWITCH PRESENT
	    $CALL ERROR <#4>		;DECLARE ERROR
	    $RETURN			;
	  END				;
	ELSE				;NOPE, FILE SWITCH ABSENT
	  IF #ALLMSK SET.IN INMKW	;ALL SWITCH PRESENT?
	    IFB #CS.MOR SET.IN C.STAT(R0) ;YUP, MORE THAN 1 FILESPEC?
	      $CALL ERROR <#1>		;YUP, SIGNAL ERROR
	      $RETURN			;
	    ELSE			;NOPE
	      LETB INMKW+1 := #UNIX	;ASSERT INPUT
	    END				;
	  ELSE				;NOPE, ALL SWITCH ABSENT
	    $CALL ERROR <#5>		;SIGNAL ERROR
	    $RETURN			;
	  END				;
	END				;
      ELSE				;NOPE, NOT FLOPPY DEVICE
	$CALL ERROR <#2>		;DECLARE ERROR
	$RETURN				;
      END				;
    ELSE				;NOPE
      $CALL ERROR <#2>			;DECLARE ERROR
      $RETURN				;
    END					;
  END					;
END					;
IFB OUTMKW+1 EQ #0			;AMBIGUITY?
  IFB INMKW+1 EQ #RSX			;RSX INPUT?
    LETB OUTMKW+1 := #UNIX		;YUP, ASSERT UNIX OUTPUT
  ELSE					;NOPE
    LETB OUTMKW+1 := #RSX		;ASSERT RSX OUTPUT
  END					;
END					;
IFB OUTMKW+1 EQ INMKW+1			;WELL, WELL, WELL, WHAT HAVE WE HERE?
  $CALL ERROR <#11.>			;CONFLICT, SIGNAL ERROR
  $RETURN				;
END					;
IF #TKMSK SET.IN OUTMKW AND #TKMSK SET.IN INMKW ;SWITCH CONFLICT?
  $CALL ERROR <#4>			;YUP, SAY SO
  $RETURN				;
END					;
IFB INMKW+1 EQ #RSX			;RSX INPUT?
  IF #TKMSK SET.IN INMKW		;YUP, TEKTRONIX FORMAT ON RSX INPUT?
    $CALL ERROR <#4>			;YUP, DECLARE ERROR
    $RETURN				;
  ELSE					;NOPE
    IF #TKMSK SET.IN OUTMKW		;TEKTRONIX OUTPUT?
      LET INMKW := INMKW SET.BY #TKMSK	;YUP, ASSERT FOR READING PURPOSES
    END					;
  END					;
  LET C.SWAD(R0) := #0			;NO SWITCHES ON ADDITIONAL INPUT
  $CALL RSX2UNIX <R0>			;PROCESS
ELSE					;NOPE, UNIX
  IF #TKMSK SET.IN OUTMKW		;TEKTRONIX ON RSX OUTPUT?
    $CALL ERROR <#4>			;YUP, DECLARE ERROR
    $RETURN				;
  END					;
  $CALL UNIX2RSX <R0>			;PROCESS
END					;
$RETURN					;BACK TO CALLER
.PAGE
.SBTTL COPY RSX TO UNIX
;
;
;
PROCEDURE RSX2UNIX,GLOBAL
;
IF #INIMSK SET.IN OUTMKW		;DEVICE INITIALIZATION REQUESTED?
  LET OUTMKW := OUTMKW CLEARED.BY #INIMSK ;YUP, ACKNOWLEDGE REQUEST
  $CALL INITVOL <DEVICE+2>		;AND DO IT
  ON.ERROR THEN $RETURN			;OOPS, FAILED
END					;
LET R3 := #INLUN			;INPUT LUN FOR FLOPPY READS
LET R2 := #ATTACH+Q.IOLU		;POINT TO ATTACH DPB
LET (R2)+ := R3				;INSERT LUN
LETB (R2) := R3				;AND EVENT FLAG
LET R2 := #DETACH+Q.IOLU		;POINT TO DETACH DPB
LET (R2)+ := R3				;INSERT LUN
LETB (R2) := R3				;AND EVENT FLAG
LET R2 := #UNXRD+Q.IOLU			;POINT TO BLOCK READ DPB
LET (R2)+ := R3				;INSERT LUN
LETB (R2) := R3				;AND EVENT FLAG
$CALL ASSIGN <DEVICE+2,R3>		;ASSIGN THE LUN
ON.ERROR				;OOPS ASSIGN FAILED
  $CALL ERROR <#6>			;SIGNAL
  $RETURN				;
END					;
DIR$ #ATTACH				;ATTACH DEVICE
ON.ERROR ORB STATUS NE #IS.SUC		;OOPS, ATTACH FAILED
  $CALL ERROR <#7>			;SIGNAL
  $RETURN				;
END					;
LET NXTBLK := #0			;SET TO READ BLOCK #0
$CALL READ				;READ IT
ON.ERROR				;OOPS, READ FAILED
  $CALL ERROR <#16.>			;SIGNAL
  DIR$ #DETACH				;CLEAN UP
  $RETURN				;
END					;
LET R0 := SP				;COPY STACK
LET SP := SP - #12.			;ALLOCATE GET LUN INFO BUFFER
LET R1 := SP				;COPY POINTER
GLUN$S R3,R1				;GET LUN INFO
LET R1 := G.LUCW+4(R1)			;GET # BLOCKS ON DEVICE
LET SP := R0				;CLEAN STACK
ON.ERROR				;OOPS
  $CALL ERROR <#10.>			;SIGNAL
  DIR$ #DETACH				;DETACH DEVICE
  $RETURN				;
END					;
LET R1 := R1 - #1			;CONVERT # BLOCKS TO MAX BLOCK #
LET MAXBLK := R1			;TUCK IT AWAY
REPEAT					;
  $CALL CHKHDR <,,,,,#UNXBUF>		;SEE IF UNIX HEADER
  IF RESULT IS CS			;NOPE, NOT A UNIX HEADER
    LET HDRBLK := NXTBLK - #1		;SAVE HEADER BLOCK NUMBER
    IF HDRBLK EQ MAXBLK			;ANY ROOM FOR FILE?
      $CALL ERROR <#14.>		;NOPE, SIGNAL
      DIR$ #DETACH			;CLEAN UP
      $RETURN				;
    END					;
    LEAVE LOOP				;
  ELSE					;GOT A UNIX HEADER
    LET R5 := R5 + #BYTCNT		;POINT TO BYTE COUNT
    LET R4 := #11.			;STRING COUNT
    WHILEB (R5) EQ #SPACE		;POINTING AT SPACE?
      LET R5 := R5 + #1			;YUP, SPACE FORWARD
      LET R4 := R4 - #1			;KEEP COUNT
      IF RESULT IS EQ			;NULL FIELD = CORRUPTED VOLUME
	$CALL ERROR <#12.>		;SIGNAL
	DIR$ #DETACH			;DETACH DEVICE
	$RETURN				;
      END				;
    END					;
    PUSH #0,#0				;CREATE 32-BIT 0
    $CALL .OD2CT <,,,SP,R4,R5>		;CONVERT TO BINARY
    POP R1,R2				;RETRIEVE RESULT
    IF RESULT IS NE OR R1 NE #0		;NON-ZERO RESULT?
      $CALL $DDIV <#512.,R1,R2>		;YUP, CONVERT TO BLKS + REMAINDER
    ELSE				;ZERO RESULT
      $CALL ERROR <#12.>		;NULL FILE
      DIR$ #DETACH			;CLEAN UP
      $RETURN				;
    END					;
    IF R0 NE #0				;ANY REMAINDER
      LET R2 := R2 + #1			;YUP, INCREMENT BLOCK COUNT
    END					;
    LET NXTBLK := NXTBLK + R2		;CALCULATE NEXT BLOCK TO READ
    IF NXTBLK HI MAXBLK			;OOPS, VOLUME CORRUPTED
      $CALL ERROR <#12.>		;SIGNAL
      DIR$ #DETACH			;DETACH DEVICE
      $RETURN				;
    END					;
    $CALL READ				;READ NEXT BLOCK
    ON.ERROR				;OOPS
      $CALL ERROR <#16.>		;SIGNAL
      DIR$ #DETACH			;CLEAN UP
      $RETURN				;
    END					;
  END					;
END					;
LET R1 := #OUTLUN			;OUTPUT LUN FOR FLOPPY WRITES
LET R2 := #ATTACH+Q.IOLU		;POINT TO ATTACH DPB
LET (R2)+ := R1				;INSERT LUN
LETB (R2) := R1				;AND EVENT FLAG
DIR$ #DETACH				;DETACH THE DEVICE
LET R2 := #DETACH+Q.IOLU		;POINT TO DETACH DPB
LET (R2)+ := R1				;INSERT LUN
LETB (R2) := R1				;AND EVENT FLAG
LET R2 := #UNXWRT+Q.IOLU		;POINT TO BLOCK WRITE DPB
LET (R2)+ := R1				;INSERT LUN
LETB (R2) := R1				;AND EVENT FLAG
$CALL ASSIGN <DEVICE+2,R1>		;ASSIGN THE LUN
ON.ERROR				;OOPS
  $CALL ERROR <#6>			;SIGNAL
  $RETURN				;
END					;
DIR$ #ATTACH				;ATTACH OUTPUT
ON.ERROR ORB STATUS NE #IS.SUC		;OOPS, ATTACH FAILED
  $CALL ERROR <#7>			;SIGNAL
  $RETURN				;
END					;
ALUN$S #INLUN,#"SY,#0			;DEFAULT ASSIGNMENT
;
ENTRYPOINT PROR2U,LOCAL
;
OPEN$ #FDB,#FO.RD,#INLUN,#CSIBLK+C.DSDS,#DEFALT,#FD.RWM ;OPEN INPUT FOR BLK I/O
ON.ERROR				;OOPS, CAN'T OPEN
  DIR$ #DETACH				;DETACH DEVICE
  $CALL ERROR <#13.>			;SIGNAL
  $RETURN				;
END					;
IFB #FD.CR!FD.FTN SET.IN F.RATT(R0)	;RECORD ORIENTED FILE?
  LET R1 := R0 + #F.FNB			;YUP, POINT TO FILE NAME BLOCK
  LET R2 := #S.FNBW			;SET WORD COUNT
  LET R5 := R2				;COPY FOR LATER
  LET R3 := SP				;MARK STACK
  LET SP := SP - #S.FNB			;ALLOCATE A FILE NAME BLOCK
  LET R4 := SP				;POINT TO IT
  THRU R2				;LOOP TO COPY FNB
    LET (R4)+ := (R1)+			;COPY A WORD
  END					;
  CLOSE$ R0				;CLOSE THE FILE
  ON.ERROR				;OOPS
    LET SP := R3			;CLEAN STACK
    DIR$ #DETACH			;CLEAN UP
    $CALL ERROR <#13.>			;CAN'T CLOSE, SAY CAN'T OPEN(AGAIN)
    $RETURN				;
  END					;
  THRU R5				;LOOP TO RESTORE FNB
    LET -(R1) := -(R4)			;RESTORE A WORD
  END					;
  LET SP := R3				;CLEAN STACK
  FDBF$R R0,#INFLAG			;SET EVENT FLAG FOR RECORD I/O
  OPEN$ R0,#FO.RD,#INLUN,,,#0,#RECBUF,#512. ;OPEN BY FILENAME BLOCK
  ON.ERROR				;OOPS
    DIR$ #DETACH			;DETACH DEVICE
    $CALL ERROR <#13.>			;SIGNAL
    $RETURN				;
  END					;
ELSE					;NOPE, BLOCK ORIENTED
  LET R1 := MAXBLK - HDRBLK		;# BLOCKS AVAILABLE ON DEVICE FOR FILE
  LET LSTBLK := F.EFBK+2(R0)		;COPY END OF FILE BLOCK NUMBER
  LET LBLKCT := F.FFBY(R0)		;COPY BYTE COUNT FOR LAST BLOCK
  IF RESULT IS EQ			;NO BYTES IN LAST BLOCK?
    LET LSTBLK := LSTBLK - #1		;YUP, BACK UP ONE BLOCK
    LET LBLKCT := #512.			;AND RESET THE LAST BLOCK BYTE COUNT
  END					;
  IF F.EFBK(R0) NE #0 OR LSTBLK HI R1	;SPACE AVAILABLE FOR FILE?
    CLOSE$ R0				;NOPE, CLOSE 'ER UP
    DIR$ #DETACH			;DETACH DEVICE
    $CALL ERROR <#15.>			;SIGNAL
    $RETURN				;
  END					;
END					;
LET BYTECT := #0			;ZERO OUT THE
LET BYTECT+2 := #0			;BYTE COUNT
LET BUFPOS := #UNXBUF			;SET UP BUFFER CONTROL
LET BUFCNT := #512.			;FOR RECORD I/O
REPEAT					;LOOP TO READ FROM INPUT FILE
  IFB #FD.RWM SET.IN F.RACC(R0)		;BLOCK I/O?
    LET R1 := F.BKVB+2(R0)		;YUP, GET BLOCK # TO BE READ
    READ$ R0,#UNXBUF,#512.,,#INFLAG,#STATUS ;READ THE BLOCK
    ON.ERROR				;OOPS
      CLOSE$ R0				;CLOSE 'ER UP
      DIR$ #DETACH			;DETACH DEVICE
      $CALL ERROR <#16.>		;SIGNAL
      $RETURN				;
    END					;
    WAIT$ R0				;SYNCHRONIZE
    ON.ERROR ORB STATUS NE #IS.SUC	;OOPS
      CLOSE$ R0				;CLOSE 'ER UP
      DIR$ #DETACH			;DETACH DEVICE
      $CALL ERROR <#16.>		;SIGNAL
      $RETURN				;
    END					;
    IF R1 EQ LSTBLK			;IS THIS THE END OF FILE BLOCK?
      LET R2 := #UNXBUF + LBLKCT	;YUP, POINT TO FREE SPACE
      LET R3 := #512. - LBLKCT		;GET COUNT OF FREE BYTES
      IF RESULT IS NE			;NE, GOT SOME
	THRU R3				;LOOP TO
	  LETB (R2)+ := #0		;CLEAR
	END				;THEM
      END				;
    END					;
    $CALL WRITE				;WRITE TO FLOPPY
    ON.ERROR				;OOPS
      CLOSE$ R0				;CLOSE 'ER UP
      DIR$ #DETACH			;DETACH DEVICE
      $CALL ERROR <#17.>		;SIGNAL
      $RETURN				;
    END					;
    IF R1 EQ LSTBLK			;LAST BLOCK?
      LET BYTECT+2 := BYTECT+2 + LBLKCT	;YUP, ADD IN LAST BYTES
      LET BYTECT := BYTECT + CARRY	;
      LEAVE LOOP			;DONE
    ELSE				;NOPE
      LET BYTECT+2 := BYTECT+2 + #512.	;ADD IN BLOCK VALUE
      LET BYTECT := BYTECT + CARRY	;
    END					;
  ELSE					;NOPE, RECORD I/O
    GET$ R0				;GET A RECORD
    ON.ERROR				;OOPSEE
      IFB F.ERR(R0) NE #IE.EOF		;BADDEE
	CLOSE$ R0			;CLOSE 'ER UP
	DIR$ #DETACH			;DETACH DEVICE
	$CALL ERROR <#16.>		;SIGNAL
	$RETURN				;
      ELSE				;
	$CALL FLUSH			;FLUSH DA BUFFER
	ON.ERROR			;OOPS
	  CLOSE$ R0			;CLOSE 'ER UP
	  DIR$ #DETACH			;DETACH DEVICE
	  $CALL ERROR <#17.>		;SIGNAL
	  $RETURN			;
	ELSE				;OK
	  LEAVE LOOP			;DONE
	END				;
      END				;
    END					;
    LET R1 := #RECBUF			;POINT TO RECORD
    LET R2 := F.NRBD(R0)		;GET BYTE COUNT
    LET R3 := R1 + R2			;POINT TO NEXT FREE BYTE
    LETB (R3) := #NEWLIN		;CONVERT TO UNIX FORMAT
    LET R2 := R2 + #1			;COUNT THE BYTE
    LET R3 := R2			;SAVE IT
    $CALL PUTREC <,R1,R2>		;PUT DA RECORD
    ON.ERROR				;OOPPSEE
      CLOSE$ R0				;CLOSE 'ER UP
      DIR$ #DETACH			;DETACH DEVICE
      $CALL ERROR <#17.>		;SIGNAL
      $RETURN				;
    END					;
    LET BYTECT+2 := BYTECT+2 + R3	;COUNT THE BYTES
    LET BYTECT := BYTECT + CARRY	;
  END					;
END					;
LET R1 := #UNXBUF			;POINT TO OUTPUT BUFFER
LET R2 := #512./2			;SET SIZE
THRU R2					;LOOP TO ZERO BUFFER
  LET (R1)+ := #0			;
END					;
LET R1 := F.DSPT(R0) + #8.		;POINT TO FILENAME DESCRIPTOR
LET R2 := (R1)+				;PICK UP SIZE
LET R1 := (R1)				;AND ADDRESS OF FILENAME STRING
LET R3 := #UNXBUF+FILNAM		;POINT TO FILENAME STRING IN BUFFER
THRU R2					;LOOP TO COPY FILENAME
  LETB (R3)+ := (R1)+			;
  IFB (R1) EQ #SEMI THEN LEAVE LOOP	;EXIT AT FILE VERSION DELIMITER
END					;
CLOSE$ R0				;CLOSE INPUT FILE
LET R1 := #ACSSTR			;POINT TO STANDARD ACCESS STRING
LETB R2 := (R1)+			;PICK UP BYTE COUNT
LET R3 := #UNXBUF+ACCESS		;POINT TO OUTPUT STRING
THRU R2					;LOOP TO COPY ACCESS STRING
  LETB (R3)+ := (R1)+			;
END					;
$CALL .RDFUI <,R1>			;READ DEFAULT UIC
SWAB R1					;INTERCHANGE GROUP AND USER
PUSHB R1				;PUSH GROUP
LETB 1(SP) := #0			;KEEP CLEAN
SWAB R1					;INTERCHANGE GROUP AND USER
PUSHB R1				;PUSH USER
LETB 1(SP) := #0			;KEEP CLEAN
LET R1 := #UNXBUF+USERID		;POINT TO OUTPUT STRING
LET R0 := R1 + #3			;SKIP UNUSED STUFF
LET R2 := #7				;SIZE OF OUTPUT STRING
THRU R2					;LOOP TO INITIALIZE OUTPUT STRING
  LETB (R1)+ := #SPACE			;
END					;
IF (SP) LOS #77				;TWO DIGITS OR LESS?
  LET R0 := R0 + #1			;YUP, SPACE PAST
END
IF (SP) LOS #7				;ONE DIGIT?
  LET R0 := R0 + #1			;YUP, SPACE PAST
END					;
$CALL $CBOMG <R0,(SP)+,#0>		;CONVERT USER
LET R1 := #UNXBUF+GRUPID		;POINT TO OUTPUT STRING
LET R0 := R1 + #3			;SKIP UNUSED STUFF
LET R2 := #7				;SIZE OF OUTPUT STRING
THRU R2					;LOOP TO INITIALIZE OUTPUT STRING
  LETB (R1)+ := #SPACE			;
END					;
IF (SP) LOS #77				;TWO DIGITS OR LESS?
  LET R0 := R0 + #1			;YUP, SPACE PAST
END
IF (SP) LOS #7				;ONE DIGIT?
  LET R0 := R0 + #1			;YUP, SPACE PAST
END					;
$CALL $CBOMG <R0,(SP)+,#0>		;CONVERT GROUP
$CALL SPINIT <#BYTECT,#UNXBUF+BYTCNT,#0,#1,#2> ;GEN FIRST BYTE COUNT DIGIT
$CALL SPINIT <R0,R1,R2,#10.,#3>		;THEN THE NEXT TEN
LETB (R1) := #SPACE			;AND A SPACE
LET R0 := #TIMSTR			;POINT TO STANDARD TIME STRING
LETB R1 := (R0)+			;PICK UP BYTE COUNT
LET R2 := #UNXBUF+FILTIM		;POINT TO OUTPUT AREA
THRU R1					;
  LETB (R2)+ := (R0)+			;TRANSFER TO OUTPUT AREA
END					;
$CALL GETCHK <R0,,,,,#UNXBUF>		;GET THE CHECKSUM
LET R1 := R0				;COPY CHECKSUM
LET R0 := #UNXBUF+CHKSUM		;POINT TO OUTPUT AREA
LET R2 := #77777			;DIGITS DETECTOR
REPEAT					;LOOP TO PAD
  IF R1 LOS R2				;THIS MANY DIGITS?
    LETB (R0)+ := #SPACE		;NOPE, PAD
  END					;
  LET R2 := R2 R.SHIFT 3		;DIVIDE BY 8.
UNTIL RESULT IS EQ			;
IF R1 EQ #0				;NULL SUM?
  LETB (R0)+ := #'0			;YUP, AT LEAST ONE 0 REQ'D
ELSE					;NOPE
  $CALL $CBOMG <R0,R1,R2>		;CONVERT THE CHECKSUM
END					;
LETB (R0)+ := #0			;GOD
LETB (R0) := #SPACE			;ONLY KNOWS
LET R0 := NXTBLK			;SAVE NEXT BLOCK
LET NXTBLK := HDRBLK			;SET UP HEADER BLOCK FOR WRITE
$CALL WRITE				;WRITE THE HEADER
ON.ERROR				;OOPS
  DIR$ #DETACH				;CLEAN UP
  $CALL ERROR <#17.>			;SIGNAL
  $RETURN				;
END					;
LET HDRBLK := R0			;SET NEW HEADER BLOCK
LET NXTBLK := R0			;AND NEXT BLOCK
$CALL NULBLK				;ZERO THE HEADER BLOCK
IFB #CS.MOR SET.IN CSIBLK+C.STAT	;MORE FILESPECS?
  CSI$2 #CSIBLK				;YUP, PARSE 'EM
  ON.ERROR				;OOPS
    DIR$ #DETACH			;CLEAN UP
    $CALL ERROR <#2>			;SIGNAL
    $RETURN				;
  END					;
  IFB #CS.WLD SET.IN C.STAT(R0) ORB #CS.NMF CLEARED.IN C.STAT(R0) ;ANY ERRS?
    DIR$ #DETACH			;YUP, CLEAN UP
    $CALL ERROR <#2>			;SIGNAL
    $RETURN				;
  END					;
  $CALLR PROR2U				;PROCESS NEXT SPEC
ELSE					;NOPE, NO MORE
  DIR$ #DETACH				;DONE WITH DEVICE
  $RETURN				;BACK TO CALLER
END					;
.PAGE
.SBTTL CONVERSION SERVICE
;
;
;
PROCEDURE SPINIT,GLOBAL
;
PUSH R4					;SAVE INNER LOOP COUNT
THRU R3					;NO OF OCTAL DIGITS
  LET R4 := (SP)			;SET LOOP COUNT
  LET R5 := #0				;CLEAR WORKING REGISTER
  THRU R4				;NO OF BINARY DIGITS/OCTAL DIGIT
    LET CARRY := CLEARED		;START FRESH
    LET (R0)+ := (R0)+ L.ROTATE 1	;NEXT BIT TO CARRY, 0 TO LSB
    LET R5 := R5 L.ROTATE 1		;AND THEN TO WORKING REGISTER
    LET (R0) := (R0) L.ROTATE 1		;GET THE NEXT BIT FROM LOW ORDER
    LET -(R0) := -(R0) + CARRY		;AND INSERT IN HIGH ORDER
  END					;
  IF R5 EQ #0				;GOT A ZERO?
    IF R2 EQ #0				;SUPPRESS?
      LETB R5 := R5 SET.BY #40		;YUP
    ELSE				;NOPE
      LETB R5 := R5 SET.BY #60		;
    END					;
  ELSE					;NOPE
    LETB R5 := R5 SET.BY #60		;
    IF R2 EQ #0				;SUPPRESSION?
      LET R2 := R2 - #1			;YUP, CLEAR SUPPRESSION
    END					;
  END					;
  LETB (R1)+ := R5			;INSERT IN BUFFER
END					;
POP R4					;RESTORE INNER LOOP COUNT
$RETURN					;
.PAGE
.SBTTL RECORD MANAGEMENT ROUTINES
;
;
;
PROCEDURE PUTREC,GLOBAL
;
THRU R2					;LOOP TO COPY
  LETB @BUFPOS := (R1)+			;COPY A BYTE
  LET BUFPOS := BUFPOS + #1		;POINT TO NEXT
  LET BUFCNT := BUFCNT - #1		;COUNT IT
  IF RESULT IS EQ			;IF EQ, BUFFER FULL
    $CALL WRITE				;WRITE IT OUT
    ON.ERROR THEN $RETURN		;OOPS!
  END					;
END					;
$RETURN NOERROR				;
;
;
;
PROCEDURE FLUSH,GLOBAL
;
IF BUFCNT NE #0				;ANYTHING TO PAD OUT?
  REPEAT				;YUP, GO TO IT
    LETB @BUFPOS := #0			;SET NULL BYTE
    LET BUFPOS := BUFPOS + #1		;POINT TO NEXT
    LET BUFCNT := BUFCNT - #1		;COUNT IT
  UNTIL RESULT IS EQ			;'TILL DONE
END
;
;
;
PROCEDURE WRITE,GLOBAL
;
IF NXTBLK HI MAXBLK THEN $RETURN ERROR	;OUT OF RANGE CHECK
LET UNXWRT+Q.IOPL+8. := NXTBLK		;SET NEXT BLOCK
IF #TKMSK SET.IN OUTMKW			;TEKTRONIX FORMAT?
  IF DEVTYP NE #RX01			;YUP, SINGLE DENSITY, SINGLE SIDED?
    $RETURN ERROR			;NOPE, NOT SUPPORTED, FLEE
  END					;
  LET UNXWRT+Q.IOFN := #IO.WPB		;SET TO WRITE PHYSICAL
  LET UNXWRT+Q.IOPL+8. := UNXWRT+Q.IOPL+8. L.SHIFT 2 ;CONVERT TO PBN FROM LBN
ELSE					;
  LET UNXWRT+Q.IOFN := #IO.WLB		;SET TO WRITE LOGICAL
END					;
DIR$ #UNXWRT				;WRITE THE BLOCK
ON.ERROR ORB STATUS NE #IS.SUC		;OOPS
  $RETURN ERROR				;SIGNAL
END					;
LET BUFPOS := #UNXBUF			;RESET BUFFER
LET BUFCNT := #512.			;CONTROL
LET NXTBLK := NXTBLK + #1		;AND NEXT BLOCK
$RETURN NOERROR				;
;
;
;
PROCEDURE GETREC,GLOBAL
;
LET R2 := #0				;INITIALIZE BYTE COUNT
IF BUFCNT EQ #0				;EMPTY BUFFER?
  IF BYTECT+2 NE #0 OR BYTECT NE #0	;YUP, END OF FILE?
    $CALL READ				;NOPE, READ NEXT BLOCK
    ON.ERROR THEN $RETURN		;OOPS, READ ERROR
  ELSE					;YUP
    LET R2 := #-1			;EOF
    $RETURN ERROR			;SIGNAL
  END					;
END					;
REPEAT					;
  IF BYTECT+2 EQ #0 AND BYTECT EQ #0	;END OF FILE?
    LET R2 := #-1			;YUP,
    $RETURN ERROR			;SIGNAL
  END					;
  LETB R3 := @BUFPOS			;PICK UP NEXT BYTE
  LET BUFPOS := BUFPOS + #1		;AND POINT PAST
  LET BYTECT+2 := BYTECT+2 - #01	;COUNT THE BYTE
  LET BYTECT := BYTECT - CARRY		;IN DOUBLE PRECISION
  LET BUFCNT := BUFCNT - #1		;UPDATE BUFFER COUNT
  IF RESULT IS EQ			;IF EQ, END OF BUFFER
    IF BYTECT+2 NE #0 OR BYTECT NE #0	;END OF FILE?
      $CALL READ			;NOPE, READ NEXT BLOCK
      ON.ERROR THEN $RETURN		;OOPS, READ ERROR
    END					;
  END					;
  IFB R3 EQ #NEWLIN			;END OF RECORD?
    LEAVE LOOP				;YUP
  ELSE					;NOPE
    LET R2 := R2 + #1			;UPDATE RECORD COUNT
    IF R2 HI #512.			;BUFFER OVERFLOW
      LET R2 := #-2			;YUP,
      $RETURN ERROR			;SIGNAL
    END					;
    LETB (R1)+ := R3			;INSERT IN BUFFER
  END					;
END					;
$RETURN NOERROR				;
;
;
;
PROCEDURE READ,GLOBAL
;
IF NXTBLK HI MAXBLK THEN $RETURN ERROR	;OUT OF RANGE CHECK
IF NXTBLK EQ #0				;READ BLOCK 0?
  LET SENSE+Q.IOLU := UNXRD+Q.IOLU	;YUP, COPY LUN
  LETB SENSE+Q.IOEF := UNXRD+Q.IOEF	;AND EVENT FLAG
  DIR$ #SENSE				;SENSE CHARACTERISTICS
  ON.ERROR ORB STATUS NE #IS.SUC	;OOPS...
    $RETURN ERROR			;FLEE
  END					;
  LET DEVTYP := STATUS+2		;COPY DEVICE TYPE MASK
END					;
LET UNXRD+Q.IOPL+8. := NXTBLK		;SET NEXT BLOCK
IF #TKMSK SET.IN INMKW			;TEKTRONIX FORMAT?
  IF DEVTYP NE #RX01			;YUP, SINGLE DENSITY, SINGLE SIDED?
    $RETURN ERROR			;NOPE, NOT SUPPORTED, FLEE
  END					;
  LET UNXRD+Q.IOFN := #IO.RPB		;SET TO READ PHYSICAL
  LET UNXRD+Q.IOPL+8. := UNXRD+Q.IOPL+8. L.SHIFT 2 ;CONVERT TO PBN FROM LBN
ELSE					;
  LET UNXRD+Q.IOFN := #IO.RLB		;SET TO READ LOGICAL
END					;
DIR$ #UNXRD				;READ THE BLOCK
ON.ERROR ORB STATUS NE #IS.SUC		;OOPS
  $RETURN ERROR				;SIGNAL
END					;
LET BUFPOS := #UNXBUF			;RESET BUFFER
LET BUFCNT := #512.			;CONTROL
LET NXTBLK := NXTBLK + #1		;AND NEXT BLOCK
$RETURN NOERROR				;
;
;
;
PROCEDURE SEEK,GLOBAL
;
IF NXTFIL LO FILENO			;BELOW CURRENT POSITION?
  LET NXTBLK := #0			;YUP, START
  LET FILENO := #0			;ALL OVER
ELSE					;NOPE
  LET NXTBLK := HDRBLK			;SET TO REREAD CURRENT HEADER
  LET FILENO := FILENO - #1		;BACK UP FILE NUMBER
END					;
LET R2 := #0				;INITIALIZE BLOCK COUNT
REPEAT					;
  LET NXTBLK := NXTBLK + R2		;CALCULATE BLOCK # OF NXT HEADER
  $CALL READ				;READ IT
  ON.ERROR THEN $RETURN			;ESCAPE ON READ ERROR
  $CALL CHKHDR <,,,,,#UNXBUF>		;SEE IF UNIX HEADER
  ON.ERROR THEN $RETURN			;ESCAPE IF NOT
  LET R5 := R5 + #BYTCNT		;POINT TO BYTE COUNT FIELD IN HEADER
  LET R4 := #11.			;SET FIELD SIZE
  WHILEB (R5) EQ #SPACE			;SKIP
    LET R5 := R5 + #1			;PAST
    LET R4 := R4 - #1			;SPACES
    IF RESULT IS EQ THEN $RETURN ERROR	;ESCAPE IF NULL BYTE COUNT FIELD
  END					;
  LET FILENO := FILENO + #1		;INCREMENT FILE NUMBER
  $CALL .OD2CT <,,,#BYTECT,R4,R5>	;CONVERT BYTE COUNT TO BINARY
  $CALL $DDIV <#512.,BYTECT,BYTECT+2>	;CONVERT TO BLOCKS
  IF R0 NE #0				;ANY REMAINDER?
    LET R2 := R2 + #1			;YUP, INCREMENT BLOCK COUNT
  ELSE					;NOPE
    LET R0 := #512.			;SET LAST BLOCK BYTE COUNT
  END					;
UNTIL FILENO EQ NXTFIL			;
$RETURN NOERROR				;RETURN WITH BYTECT FOR RECORD I/O;
					;R0 = LAST BLOCK BYTE COUNT AND
					;R2 = BLOCK COUNT FOR BLOCK I/O;
					;AND NXTBLK FOR I/O CONTROL
;
;
;
PROCEDURE NULBLK,GLOBAL
;
LET R0 := #UNXBUF			;POINT TO OUTPUT BUFFER
LET R1 := #512./2			;SET WORD COUNT
THRU R1					;LOOP TO ZERO BUFFER
  LET (R0)+ := #0			;
END					;
$CALL WRITE				;WRITE OUT THE BUFFER
ON.ERROR				;OOPS
  LET CARRY := SET			;
ELSE					;
  LET CARRY := CLEARED			;
END					;
$RETURN					;
.PAGE
.SBTTL COPY UNIX TO RSX
;
;
;
PROCEDURE UNIX2RSX,GLOBAL
;
LET R3 := #INLUN			;INPUT LUN FOR FLOPPY READS
LET R2 := #ATTACH+Q.IOLU		;POINT TO ATTACH DPB
LET (R2)+ := R3				;INSERT LUN
LETB (R2) := R3				;AND EVENT FLAG
LET R2 := #DETACH+Q.IOLU		;POINT TO DETACH DPB
LET (R2)+ := R3				;INSERT LUN
LETB (R2) := R3				;AND EVENT FLAG
LET R2 := #UNXRD+Q.IOLU			;POINT TO BLOCK READ DPB
LET (R2)+ := R3				;INSERT LUN
LETB (R2) := R3				;AND EVENT FLAG
$CALL ASSIGN <C.DEVD+2(R0),R3>		;ASSIGN THE LUN
ON.ERROR				;OOPS ASSIGN FAILED
  $CALL ERROR <#6>			;SIGNAL
  $RETURN				;
END					;
DIR$ #ATTACH				;ATTACH DEVICE
ON.ERROR ORB STATUS NE #IS.SUC		;OOPS, ATTACH FAILED
  $CALL ERROR <#7>			;SIGNAL
  $RETURN				;
END					;
LET NXTBLK := #0			;SET TO READ BLOCK #0
$CALL READ				;READ IT
ON.ERROR				;OOPS, READ FAILED
  $CALL ERROR <#16.>			;SIGNAL
  DIR$ #DETACH				;CLEAN UP
  $RETURN				;
END					;
LET R0 := SP				;COPY STACK
LET SP := SP - #12.			;ALLOCATE GET LUN INFO BUFFER
LET R1 := SP				;COPY POINTER
GLUN$S R3,R1				;GET LUN INFO
LET R1 := G.LUCW+4(R1)			;GET # BLOCKS ON DEVICE
LET SP := R0				;CLEAN STACK
ON.ERROR				;OOPS
  $CALL ERROR <#10.>			;SIGNAL
  DIR$ #DETACH				;DETACH DEVICE
  $RETURN				;
END					;
LET R1 := R1 - #1			;CONVERT # BLOCKS TO MAX BLOCK #
LET MAXBLK := R1			;TUCK IT AWAY
$CALL CHKHDR <,,,,,#UNXBUF>		;SEE IF UNIX VOLUME
ON.ERROR				;NOT A UNIX VOLUME
  DIR$ #DETACH				;DETACH DEVICE
  $CALL ERROR <#9.>			;SIGNAL
  $RETURN				;
END					;
LET HDRBLK := #0			;SET UP THE
LET FILENO := #1			;INITIAL
LET NXTFIL := #0			;CONDITIONS
IF #NEWMSK SET.IN INMKW AND #IMGMSK SET.IN INMKW ;SWITCH CONFLICT?
  DIR$ #DETACH				;YUP, DETACH DEVICE
  $CALL ERROR <#4>			;SIGNAL
  $RETURN				;
END					;
IF #NEWMSK CLEARED.IN INMKW AND #IMGMSK CLEARED.IN INMKW ;DEFAULT CONDITIONS?
  LET INMKW := INMKW SET.BY #IMGMSK	;YUP, ESTABLISH STANDARD DEFAULT
END					;
ALUN$S #OUTLUN,#"SY,#0			;DEFAULT ASSIGNMENT
;
ENTRYPOINT PROU2R,LOCAL
;
IF #ALLMSK SET.IN INMKW			;ALL?
  LET NXTFIL := NXTFIL + #1		;YUP, SET NEXT
ELSE					;NOPE, MUST BE /FILE:N
  IF TGTFIL EQ #0			;NULL FILE NUMBER?
    DIR$ #DETACH			;YUP, DETACH DEVICE
    $CALL ERROR <#18.>			;SIGNAL
    $RETURN				;
  ELSE					;NOPE
    LET NXTFIL := TGTFIL		;SET NEXT
  END					;
END					;
$CALL SEEK <R0,,R2>			;FIND THE FILE
ON.ERROR				;OOPS, CAN'T FIND
  IF #ALLMSK CLEARED.IN INMKW		;FILE:N MODE?
    $CALL ERROR <#18.>			;YUP, NO SUCH FILE
  END					;
  DIR$ #DETACH				;DETACH DEVICE
  $RETURN				;DONE
END					;
LET BLKCNT := R2			;SAVE BLOCK COUNT
LET LBLKCT := R0			;AND BYTE COUNT OF LAST BLOCK
LET HDRBLK := NXTBLK - #1		;SAVE THE HEADER BLOCK NUMBER
LET R0 := FILENM+2			;ADDRESS OF OUTPUT STRING
LET R1 := #0				;INIT SIZE OF OUTPUT STRING
LET R2 := #UNXBUF+FILNAM		;ADDRESS IF FILENAME IN HEADER
PUSH R2					;SAVE FOR LATER
LET R3 := #0				;SAY DOT NOT SEEN
WHILEB (R2) NE #0			;SCAN FOR PATHNAME DELIMITERS
  IFB (R2)+ EQ #SLASH			;DELIMITER?
    LET R3 := R3 + #1			;YUP, COUNT IT
  END					;
END					;
POP R2					;RESTORE POINTER
IF R3 NE #0				;PATHNAME PRESENT?
  REPEAT				;YUP, SCAN PAST
    IFB (R2)+ EQ #SLASH			;DELIMITER?
      LET R3 := R3 - #1			;YUP, COUNT IT
    END					;
  UNTIL R3 EQ #0			;
END					;
REPEAT					;
  LETB R4 := (R2)+			;GET NEXT CHAR
  IF RESULT IS EQ			;NULL BYTE?
    IF R1 EQ #0				;NO BYTES YET?
      LETB (R0)+ := #'Q			;YUP, STUFF A Q
      LETB (R0) := #'.			;AND A DOT
      LET R1 := R1 + #2			;AND THE COUNT
    ELSE				;NOPE, SOME
      IF R3 EQ #0			;DOT NOT SEEN?
	LETB (R0) := #'.		;YUP, STUFF A DOT
	LET R1 := R1 + #1		;AND THE COUNT
      END				;
    END					;
    LEAVE LOOP				;DONE
  END					;
  IF R1 EQ #9.				;IS THIS THE TENTH CHAR?
    IF R3 EQ #0				;YUP, DOT SEEN?
      LETB (R0)+ := #'.			;NOPE, STUFF A DOT
      LET R1 := R1 + #1			;AND THE COUNT
      LET R3 := R3 + #1			;SAY DOT SEEN
      IFB R4 EQ #'. THEN RESTART LOOP	;IF THIS IS A DOT, GET NEXT CHARACTER
    END					;
  END					;
  IFB R4 EQ #'.				;IS THIS A DOT?
    IF R1 EQ #0				;YUP, ANY CHARS YET?
      LETB R4 := #'Q			;NOPE, MAKE IT A Q
    ELSE				;YUP
      IF R3 NE #0			;DOT SEEN YET?
	LETB R4 := #'Q			;YUP, MAKE IT A Q
      ELSE				;NOPE
	LETB (R0)+ := R4		;COPY AS IS
	LET R1 := R1 + #1		;COUNT IT
	LET R3 := R3 + #1		;SAY DOT SEEN
	RESTART LOOP			;AND GO AGAIN
      END				;
    END					;
  END					;
  IFB R4 LO #'0				;LOW STUFF?
    LETB R4 := #'Q			;YUP, MAKE IT A Q
  ELSE					;NOPE
    IFB R4 HI #'9 ANDB R4 LO #'A	;'TWEEN NUMBERS & UC LETTERS?
      LETB R4 := #'Q			;YUP, MAKE IT A Q
    ELSE				;NOPE
      IFB R4 HI #'Z ANDB R4 LO #141	;'TWEEN UC LETTERS AND LC LETTERS?
	LETB R4 := #'Q			;YUP, MAKE IT A Q
      ELSE				;NOPE
	IFB R4 HIS #141 ANDB R4 LOS #172;LC LETTER?
	  LETB R4 := R4 CLEARED.BY #40	;YUP, MAKE IT AN UC LETTER
	ELSE				;NOPE
	  IFB R4 HI #172		;UPPER END STUFF?
	    LETB R4 := #'Q		;YUP, MAKE IT A Q
	  END				;
	END				;
      END				;
    END					;
  END					;
  LETB (R0)+ := R4			;STUFF IN OUTPUT BUFFER
  LET R1 := R1 + #1			;
  IF R1 EQ #13. THEN LEAVE LOOP		;ESCAPE WHEN DONE
  IF R3 NE #0				;DOT SEEN?
    LET R3 := R3 + #1			;YUP, COUNT EXTENSION CHARACTER
  END					;
  IF R3 EQ #4 THEN LEAVE LOOP		;IF THREE EXTENSION CHARACTERS, DONE
END					;
LET FILENM := R1			;INSERT STRING SIZE
LET R0 := #FDB				;POINT TO FDB
IF #NEWMSK SET.IN INMKW			;<NEWLIN> FORMAT?
  FDAT$R R0,#R.VAR,#FD.CR		;YUP, CUSTOMIZE FDB
  FDRC$R R0,#0				;FOR PUT$ OPERATIONS
  FDBF$R R0,#OUTFLG			;WITH FD.CR RECORDS
ELSE					;NOPE, IMAGE
  FDAT$R R0,#0,#0			;CUSTOMIZE FDB
  FDRC$R R0,#FD.RWM			;FOR BLOCK I/O
END					;
OPEN$ R0,#FO.WRT,#OUTLUN,#FLSPEC,#DEFALT;OPEN OUTPUT FILE
ON.ERROR				;OOPS
  DIR$ #DETACH				;DETACH DEVICE
  $CALL ERROR <#19.>			;SIGNAL
  $RETURN				;
END					;
IF #NEWMSK SET.IN INMKW			;<NEWLIN> FORMAT?
  LET BUFCNT := #0			;YUP, INITIALIZE BUFFER CONTROL
  REPEAT				;PROCESS FILE
    $CALL GETREC <,#RECBUF,R2>		;GET A RECORD
    ON.ERROR				;OOPS, SUMPIN WRONG
      $CALL .TRNCL <R0>			;CLOSE 'ER UP
      IF R2 EQ #-1 THEN LEAVE LOOP	;END OF FILE
      DIR$ #DETACH			;DETACH DEVICE
      IF R2 EQ #-2			;-2 -> BIGGGGG RECORDS
	LET R0 := #8.			;SET ERROR CODE
      ELSE				;I/O ERROR
	LET R0 := #16.			;SET ERROR CODE
      END				;
      $CALL ERROR <R0>			;SIGNAL
      $RETURN				;
    END					;
    PUT$ R0,#RECBUF,R2			;OUTPUT THE RECORD
    ON.ERROR				;OOPS
      $CALL .TRNCL <R0>			;CLOSE 'ER UP
      DIR$ #DETACH			;DETACH DEVICE
      $CALL ERROR <#17.>		;SIGNAL
    END					;
  END					;GO AGAIN
ELSE					;NOPE, IMAGE MODE
  REPEAT				;LOOP TO TRANSFER 'EM
    $CALL READ				;READ A BLOCK
    ON.ERROR				;OOPS
      $CALL .TRNCL <R0>			;
      DIR$ #DETACH			;DETACH DEVICE
      $CALL ERROR <#16.>		;SIGNAL
      $RETURN				;
    END					;
    IF BLKCNT EQ #1			;LAST BLOCK?
      LET R2 := #UNXBUF + LBLKCT	;YUP, POINT TO FREE SPACE
      LET R3 := #512. - LBLKCT		;GET COUNT OF FREE BYTES
      IF RESULT IS NE			;NE, GOT SOME
	THRU R3				;LOOP TO CLEAR 'EM
	  LETB (R2)+ := #0		;
	END				;
      END				;
    END					;
    WRITE$ R0,#UNXBUF,#512.,,#OUTFLG,#STATUS ;WRITE OUT THE BLOCK
    ON.ERROR				;OOPS
      $CALL .TRNCL <R0>			;CLOSE 'ER UP
      DIR$ #DETACH			;DETACH DEVICE
      $CALL ERROR <#17.>		;SIGNAL
      $RETURN				;
    END					;
    WAIT$ R0				;SYNCHRONIZE
    ON.ERROR ORB STATUS NE #IS.SUC	;OOPS
      $CALL .TRNCL <R0>			;CLOSE 'ER UP
      DIR$ #DETACH			;DETACH DEVICE
      $CALL ERROR <#17.>		;SIGNAL
      $RETURN				;
    END					;
    LET BLKCNT := BLKCNT - #1		;KEEP COUNT
  UNTIL RESULT IS EQ			;
END					;
$CALL .TRNCL <R0>			;CLOSE OUTPUT FILE
IFB #CS.MOR SET.IN CSIBLK+C.STAT	;MORE TO GO?
  CSI$2 #CSIBLK				;PARSE NEXT FILESPEC
  ON.ERROR				;OOPS
    DIR$ #DETACH			;DETACH DEVICE
    $CALL ERROR <#2>			;SIGNAL
    $RETURN				;
  END					;
  IFB #CS.WLD!CS.NMF!CS.DIF!CS.DVF SET.IN C.STAT(R0) ;ANY SPEC ERRORS?
    DIR$ #DETACH			;YUP, DETACH DEVICE
    $CALL ERROR <#2>			;SIGNAL
    $RETURN				;
  END					;
  IF #FILMSK CLEARED.IN C.MKW1(R0) OR #ALLMSK SET.IN C.MKW1(R0) ;ANY SWTCH ERRS?
    DIR$ #DETACH			;YUP, DETACH DEVICE
    $CALL ERROR <#4>			;SIGNAL
    $RETURN				;
  END					;
  IF #NEWMSK SET.IN C.MKW1(R0) AND #IMGMSK SET.IN C.MKW1(R0) ;MORE SWITCH ERRS?
    DIR$ #DETACH			;YUP, DETACH DEVICE
    $CALL ERROR <#4>			;SIGNAL
    $RETURN				;
  END					;
  IF #TKMSK SET.IN C.MKW1(R0) AND #TKMSK CLEARED.IN INMKW ;MORE SWITCH ERRS?
    DIR$ #DETACH			;YUP, DETACH DEVICE
    $CALL ERROR <#4>			;SIGNAL
    $RETURN				;
  END					;
  IF #NEWMSK SET.IN C.MKW1(R0)		;<NEWLIN> SWITCH?
    LET INMKW := INMKW SET.BY #NEWMSK	;YUP, ASSERT IT
    LET INMKW := INMKW CLEARED.BY #IMGMSK ;AND DE-ASSERT IMAGE SWITCH
  END					;
  IF #IMGMSK SET.IN C.MKW1(R0)		;IMAGE SWITCH?
    LET INMKW := INMKW SET.BY #IMGMSK	;YUP, ASSERT IT
    LET INMKW := INMKW CLEARED.BY #NEWMSK ;AND DE-ASSERT NEWLIN SWITCH
  END					;
ELSE					;
  IF #ALLMSK CLEARED.IN INMKW		;/ALL SWITCH PRESENT?
    DIR$ #DETACH			;NOPE, DETACH DEVICE
    $RETURN				;
  END					;
END					;
$CALLR PROU2R				;GO AGAIN
.PAGE
.SBTTL ERROR HANDLER
;
;
;
PROCEDURE ERROR,GLOBAL
;
LET R0 := R0 L.SHIFT 1			;CONVERT TO WORD INDEX
LET R0 := ERRTBL(R0)			;PICK UP MESSAGE POINTER
LETB ERRWRT+Q.IOPL+2 := (R0)+		;INSERT BYTE COUNT
LET ERRWRT+Q.IOPL := R0			;INSERT MSG POINTER
DIR$ #ERRWRT				;OUTPUT MESSAGE
$RETURN					;BACK TO CALLER
.PAGE
.SBTTL ASSIGN LUN FROM DEVICE STRING
;
;
;
PROCEDURE ASSIGN,GLOBAL
;
LET R2 := #ASGLUN+A.LULU		;POINT INTO ALUN$ DPB
LET (R2)+ := R1				;INSERT LUN
LETB (R2)+ := (R0)+			;COPY DEVICE NAME
LETB (R2)+ := (R0)+			;FROM DEVICE STRING
IFB (R0) EQ #':				;NON-NULL UNIT NUMBER?
  LET R1 := #0				;NOPE, NULL UNIT NUMBER
ELSE					;YUP
  $CALL $COTB <R0,R1,R2>		;CONVERT TO BINARY
  IFB R2 NE #':				;OK?
    $RETURN ERROR			;NOPE, FLEE
  END					;
END					;
LET ASGLUN+A.LUNU := R1			;INSERT UNIT #
DIR$ #ASGLUN				;ASSIGN THE LUN
$RETURN					;BACK TO CALLER WITH STATUS
.PAGE
.SBTTL LIST UNIX DIRECTORY
;
;
;
PROCEDURE LISTVOL,GLOBAL
;
LET R1 := #INLUN			;INPUT LUN FOR FLOPPY READS
LET R2 := #ATTACH+Q.IOLU		;POINT INTO ATTACH DPB
LET (R2)+ := R1				;INSERT LUN
LETB (R2) := R1				;AND FLAG
LET R2 := #DETACH+Q.IOLU		;POINT INTO DETACH DPB
LET (R2)+ := R1				;INSERT LUN
LETB (R2) := R1				;AND FLAG
LET R2 := #UNXRD+Q.IOLU			;POINT TO BLOCK READ DPB
LET (R2)+ := R1				;INSERT LUN
LETB (R2) := R1				;AND FLAG
LET R3 := R0				;COPY POINTER TO DEVICE STRING
LET R4 := R1				;COPY LUN
$CALL ASSIGN <R0,R1>			;ASSIGN THE LUN
ON.ERROR				;OOPS, ASSIGN FAILED
  $CALL ERROR <#6>			;SIGNAL
  $RETURN				;AND EXIT
END					;
DIR$ #ATTACH				;ATTACH DEVICE
ON.ERROR ORB STATUS NE #IS.SUC		;ARE WE OK?
  $CALL ERROR <#7>			;NOPE, SIGNAL
ELSE					;YUP, OK
  LET NXTBLK := #0			;SET TO READ BLOCK '0'
  $CALL READ				;READ THE BLOCK
  ON.ERROR				;ARE WE OK?
    $CALL ERROR <#16.>			;NOPE, SIGNAL
  ELSE					;YUP
    $CALL CHKHDR <,,,,,#UNXBUF>		;CHECK HEADER
    ON.ERROR				;OOPS, NOT A UNIX VOLUME
      $CALL ERROR <#9.>			;SIGNAL
    ELSE				;GOT A UNIX VOLUME!
      LET R0 := SP			;COPY STACK
      LET SP := SP - #12.		;ALLOCATE GET LUN INFO BUFFER
      LET R1 := SP			;COPY POINTER
      GLUN$S R4,R1			;GET LUN INFO
      LET R1 := G.LUCW+4(R1)		;GET # OF BLOCKS ON DEVICE
      LET SP := R0			;CLEAN STACK
      ON.ERROR				;OOPS
	$CALL ERROR <#10.>		;SIGNAL
      ELSE				;OK
	LET R1 := R1 - #1		;CONVERT # BLOCKS TO MAX BLOCK #
	LET MAXBLK := R1		;TUCK IT AWAY
	LET FILENO := #1		;INITIALIZE THE FILE NUMBER
	LET R0 := #COLHDR		;POINT TO COLUMN HEADER STRING
	LET R1 := #5			;SET COUNT
	REPEAT				;LOOP
	  LETB (R0)+ := (R3)		;TO
	  LET R1 := R1 - #1		;TRANSFER
	UNTILB (R3)+ EQ #': OR R1 EQ #0	;DEVICE STRING
	IF R1 NE #0			;PAD
	  THRU R1			;OUT
	    LETB (R0)+ := #SPACE	;DEVICE
	  END				;FIELD
	END				;
	LET R0 := #LSTHDR		;POINT TO MESSAGE
	LETB LIST+Q.IOPL+2 := (R0)+	;RETRIEVE BYTE COUNT & INSERT
	LET LIST+Q.IOPL := R0		;INSERT STRING POINTER IN DPB
	DIR$ #LIST			;PUT TO TERMINAL
	REPEAT				;LOOP TO OUTPUT DIRECTORY
	  $CALL BLDBUF <#LINBUF,R5,R2>	;BUILD THE OUTPUT LINE
	  LETB LIST+Q.IOPL+2 := R1	;INSERT BYTE COUNT FOR OUTPUT LINE
	  LET LIST+Q.IOPL := R0		;AND OUTPUT LINE ADDRESS
	  DIR$ #LIST			;PUT TO TERMINAL
	  IF R2 EQ #0			;PROTECT
	    LET R2 := R2 + #1		;AGAINST
	  END				;NULL FILES
	  LET NXTBLK := NXTBLK + R2	;NEXT BLOCK TO READ
	  IF NXTBLK HIS MAXBLK THEN LEAVE LOOP ;ESCAPE IF END OF VOLUME
	  $CALL READ			;READ THE BLOCK
	  ON.ERROR			;OOPS
	    $CALL ERROR <#16.>		;SIGNAL
	    LEAVE LOOP			;ESCAPE
	  END				;
	  $CALL CHKHDR <,,,,,R5>	;VALIDATE HEADER
	  ON.ERROR THEN LEAVE LOOP	;ESCAPE IF NO MORE FILES
	  LET FILENO := FILENO + #1	;UPDATE FILE NUMBER
	END				;
      END				;
    END					;
  END					;
  DIR$ #DETACH				;DETACH DEVICE
END					;
$RETURN					;
.PAGE
.SBTTL BUILD LISTING OUTPUT LINE
;
;
;
PROCEDURE BLDBUF,GLOBAL
;
LET R4 := R0				;COPY OUTPUT BUFFER POINTER
LET R3 := R1				;COPY INPUT BUFFER POINTER
LET R1 := FILENO			;GET FILE NUMBER
LETB (R0)+ := #SPACE			;
IF R1 LOS #99.				;THREE DIGITS?
  LETB (R0)+ := #SPACE			;NOPE, SPACE PAST
END					;
IF R1 LOS #9.				;TWO DIGITS?
  LETB (R0)+ := #SPACE			;NOPE, SPACE PAST
END					;
$CALL $CBDMG <R0,R1,#0>			;CONVERT TO DECIMAL
LETB (R0)+ := #'.			;DECIMAL POINT
LET R1 := #5				;SPACE COUNT
THRU R1					;
  LETB (R0)+ := #SPACE			;PADDING
END					;
LET R1 := R3 + #FILNAM			;POINT TO FILENAME IN HEADER BUFFER
PUSH R1					;SAVE FOR LATER
LET R2 := #0				;INITIALIZE DELIMITER COUNT
WHILEB (R1) NE #0			;
  IFB (R1)+ EQ #SLASH			;PATHNAME DELIMITER?
    LET R2 := R2 + #1			;YUP, COUNT IT
  END					;
END					;
POP R1					;RESTORE POINTER
IF R2 NE #0				;PATHNAME PRESENT?
  REPEAT				;YUP, SCAN PAST
    IFB (R1)+ EQ #SLASH			;DELIMITER?
      LET R2 := R2 - #1			;YUP, COUNT IT
    END					;
  UNTIL R2 EQ #0			;
END					;
LET R2 := #14.				;MAXIMUM CHARACTER COUNT FOR FILENAME
WHILEB (R1) NE #0			;SCAN FOR NULL
  LETB (R0)+ := (R1)+			;COPY
  LET R2 := R2 - #1			;KEEP COUNT
  IF RESULT IS EQ THEN LEAVE LOOP	;ESCAPE AT LIMIT
END					;
LET R2 := R2 + #4			;ADD PADDING TO NEXT FIELD
THRU R2					;
  LETB (R0)+ := #SPACE			;PADDING
END					;
PUSH R0					;SAVE BUFFER POINTER
LET R0 := R3 + #ACCESS+3		;POINT TO PROTECTION FIELD IN BUFFER
$CALL $COTB <R0,R1,R2>			;CONVERT TO BINARY
POP R0					;RESTORE BUFFER POINTER
LET R1 := R1 L.SHIFT 7			;MOVE PROTECTION BITS INTO PLACE
LET R2 := #3				;THREE FIELDS, OWNER, GROUP, WORLD
THRU R2					;
  LET R1 := R1 L.ROTATE 1		;GET READ BIT
  IF RESULT IS CS			;ASSERTED?
    LETB (R0)+ := #LCR			;YUP, ASSERT READ PRIVILEGE
  ELSE					;NOPE
    LETB (R0)+ := #'-			;
  END					;
  LET R1 := R1 L.ROTATE 1		;GET WRITE BIT
  IF RESULT IS CS			;ASSERTED?
    LETB (R0)+ := #LCW			;YUP, ASSERT WRITE PRIVILEGE
  ELSE					;NOPE
    LETB (R0)+ := #'-			;
  END					;
  LET R1 := R1 L.ROTATE 1		;GET EXECUTE BIT
  IF RESULT IS CS			;ASSERTED?
    LETB (R0)+ := #LCX			;YUP, ASSERT EXECUTE PRIVILEGE
  ELSE					;NOPE
    LETB (R0)+ := #'-			;
  END					;
END					;
LET R2 := #4				;SET PAD COUNT
THRU R2					;PAD TO NEXT FIELD
  LETB (R0)+ := #SPACE			;PADDING
END					;
LET R1 := R3 + #USERID			;POINT TO USER ID IN HEADER BUFFER
LET R2 := #6				;FIELD SIZE
WHILEB (R1) EQ #SPACE			;POINTING AT SPACE?
  LET R1 := R1 + #1			;YUP, SPACE FORWARD
  LET R2 := R2 - #1			;KEEP COUNT
  IF RESULT IS EQ THEN LEAVE LOOP	;ESCAPE AT FIELD LIMIT
END					;
IF R2 NE #0				;POPULATED FIELD?
  PUSH R0				;YUP, SAVE POINTER
  LET R0 := R1				;COPY CURRENT POINTER
  $CALL $COTB <R0,R1,R2>		;CONVERT TO BINARY
  POP R0				;RESTORE POINTER
ELSE					;NOPE
  LET R1 := #0				;SET = 0
END					;
IF R1 LOS #9999.			;FIVE DIGIT FIELD?
  LETB (R0)+ := #SPACE			;NOPE, SPACE PAST
END					;
IF R1 LOS #999.				;FOUR DIGIT FIELD?
  LETB (R0)+ := #SPACE			;NOPE, SPACE PAST
END					;
IF R1 LOS #99.				;THREE DIGIT FIELD?
  LETB (R0)+ := #SPACE			;NOPE, SPACE PAST
END					;
IF R1 LOS #9.				;TWO DIGIT FIELD?
  LETB (R0)+ := #SPACE			;NOPE, SPACE PAST
END					;
IF R1 NE #0				;NULL FIELD?
  $CALL $CBDMG <R0,R1,#0>		;NOPE, CONVERT TO DECIMAL
ELSE					;YUP
  LETB (R0)+ := #SPACE			;SPACE PAST
END					;
LETB (R0)+ := #'/			;SET DELIMITER
LET R1 := R3 + #GRUPID			;POINT TO GROUP ID IN HEADER BUFFER
LET R2 := #6				;FIELD SIZE
WHILEB (R1) EQ #SPACE			;POINTING AT SPACE?
  LET R1 := R1 + #1			;YUP, SPACE FORWARD
  LET R2 := R2 - #1			;KEEP COUNT
  IF RESULT IS EQ THEN LEAVE LOOP	;ESCAPE AT FIELD LIMIT
END					;
IF R2 NE #0				;POPULATED FIELD?
  PUSH R0				;YUP, SAVE POINTER
  LET R0 := R1				;COPY CURRENT POINTER
  $CALL $COTB <R0,R1,R2>		;CONVERT TO BINARY
  POP R0				;RESTORE POINTER
ELSE					;NOPE
  LET R1 := #0				;SET = 0
END					;
IF R1 NE #0				;NULL FIELD?
  PUSH R1				;NOPE, PRESERVE GROUP NUMBER
  $CALL $CBDMG <R0,R1,#0>		;CONVERT TO DECIMAL
  POP R1				;RESTORE GROUP NUMBER
END					;
LET R2 := #4				;INITIALIZE PADDING COUNT
IF R1 LOS #9999.			;FIVE DIGIT FIELD?
  LET R2 := R2 + #1			;NOPE, PAD ONE LOCATION
END					;
IF R1 LOS #999.				;FOUR DIGIT FIELD?
  LET R2 := R2 + #1			;NOPE, PAD ONE LOCATION
END					;
IF R1 LOS #99.				;THREE DIGIT FIELD?
  LET R2 := R2 + #1			;NOPE, PAD ONE LOCATION
END					;
IF R1 LOS #9.				;TWO DIGIT FIELD?
  LET R2 := R2 + #1			;NOPE, PAD ONE LOCATION
END					;
IF R1 EQ #0				;NULL FIELD?
  LET R2 := R2 + #1			;YUP, PAD ONE LOCATION
END					;
THRU R2					;
  LETB (R0)+ := #SPACE			;PAD TO NEXT FIELD
END					;
LET R1 := R3 + #BYTCNT			;POINT TO BYTE COUNT IN HEADER BUFFER
LET R2 := #11.				;FIELD SIZE
WHILEB (R1) EQ #SPACE			;POINTING AT SPACE?
  LET R1 := R1 + #1			;YUP, SPACE FORWARD
  LET R2 := R2 - #1			;KEEP COUNT
  IF RESULT IS EQ THEN LEAVE LOOP	;ESCAPE AT FIELD LIMIT
END					;
PUSH R4,R5,#0,#0			;SAVE REGS AND CREATE 32-BIT 0
IF R2 NE #0				;POPULATED FIELD?
  $CALL .OD2CT <,,,SP,R2,R1>		;YUP, CONVERT BYTE COUNT TO BINARY
END					;
LET R2 := #0				;SET TO SUPPRESS LEADING ZEROS
IF (SP) EQ #0				;HIGH ORDER 16 BITS = 0 ?
  LET R1 := 2(SP)			;YUP, MAXIMUM 5 DIGIT NUMBER
  LETB (R0)+ := #SPACE			;SPACE
  LETB (R0)+ := #SPACE			;PAST
  IF R1 LOS #9999.			;5 DIGITS?
    LETB (R0)+ := #SPACE		;NOPE, SPACE PAST
  END					;
  IF R1 LOS #999.			;4 DIGITS?
    LETB (R0)+ := #SPACE		;NOPE, SPACE PAST
  END					;
  IF R1 LOS #99.			;3 DIGITS?
    LETB (R0)+ := #SPACE		;NOPE, SPACE PAST
  END					;
  IF R1 LOS #9.				;2 DIGITS?
    LETB (R0)+ := #SPACE		;NOPE, SPACE PAST
  END					;
  IF R1 EQ #0				;1 DIGIT?
    LETB (R0)+ := #'0			;NOPE, SET 0
    LET R2 := R2 - #1			;SET FLAG TO SKIP CONVERSION
  END					;
ELSE					;NOPE, AT LEAST 5 DIGIT NUMBER
  LET R0 := R0 - #2			;BACK UP IN OUTPUT BUFFER
  LET R2 := R2 + #1			;SET TO ALLOW LEADING ZEROS
END					;
PROBE R2				;
IF RESULT IS PL				;CONVERSION REQ'D?
  $CALL $CDDMG <R0,SP,R2>		;YUP, DO IT
END					;
LETB (R0)+ := #'/			;SET DELIMITER
LET R4 := R0				;COPY BUFFER POINTER
POP R1,R2				;GET NUMBER
IF RESULT IS NE OR R1 NE #0		;NON-ZERO RESULT?
  $CALL $DDIV <#512.,R1,R2>		;YUP, DO IT
ELSE					;NOPE,
  LET R0 := #0				;DUMMY REMAINDER
END					;
IF R0 NE #0				;ANY REMAINDER?
  LET R2 := R2 + #1			;YUP, INCREMENT BLOCK COUNT
END					;
LET R0 := R4				;RESTORE BUFFER POINTER
IF R2 EQ #0				;ZERO BLOCKS?
  LETB (R0)+ := #'0			;YUP, STUFF IT
ELSE					;NOPE
  PUSH R2				;SAVE BLOCK COUNT
  $CALL $CBDMG <R0,R2,#0>		;CONVERT FOR OUTPUT
  POP R2				;RESTORE BLOCK COUNT
END					;
LET R1 := R0				;COPY POINTER
POP R5,R0				;RESTORE NON-VOLATILE AND INPUT R0
LET R1 := R1 - R0			;CALCULATE BYTE COUNT
$RETURN					;BACK TO CALLER
.PAGE
.SBTTL INITIALIZE UNIX VOLUME
;
;
;
PROCEDURE INITVOL,GLOBAL
;
LET R1 := #INLUN			;INPUT LUN FOR FLOPPY READS
LET R2 := #ATTACH+Q.IOLU		;POINT TO ATTACH DPB
LET (R2)+ := R1				;INSERT LUN
LETB (R2) := R1				;AND EVENT FLAG
LET R2 := #DETACH+Q.IOLU		;POINT TO DETACH DPB
LET (R2)+ := R1				;INSERT LUN
LETB (R2) := R1				;AND EVENT FLAG
LET R2 := #UNXRD+Q.IOLU			;POINT TO BLOCK READ DPB
LET (R2)+ := R1				;INSERT LUN
LETB (R2) := R1				;AND EVENT FLAG
LET R3 := R0				;SAVE DEVICE STRING POINTER
$CALL ASSIGN <R0,R1>			;ASSIGN THE LUN
ON.ERROR				;OOPS ASSIGN FAILED
  $CALL ERROR <#6>			;SIGNAL
  $RETURN				;
END					;
DIR$ #ATTACH				;ATTACH DEVICE
ON.ERROR ORB STATUS NE #IS.SUC		;OOPS, ATTACH FAILED
  $CALL ERROR <#7>			;SIGNAL
  $RETURN				;
END					;
LET NXTBLK := #0			;SET TO READ BLOCK #0
$CALL READ				;READ IT
ON.ERROR				;OOPS, READ FAILED
  $CALL ERROR <#16.>			;SIGNAL
  DIR$ #DETACH				;CLEAN UP
  $RETURN				;
END					;
DIR$ #DETACH				;DETACH DEVICE
LET R1 := #OUTLUN			;OUTPUT LUN FOR FLOPPY WRITES
LET R2 := #ATTACH+Q.IOLU		;POINT INTO ATTACH DPB
LET (R2)+ := R1				;INSERT LUN
LETB (R2) := R1				;AND FLAG
LET R2 := #DETACH+Q.IOLU		;POINT INTO DETACH DPB
LET (R2)+ := R1				;INSERT LUN
LETB (R2) := R1				;AND FLAG
LET R2 := #UNXWRT+Q.IOLU		;POINT TO BLOCK WRITE DPB
LET (R2)+ := R1				;INSERT LUN
LETB (R2) := R1				;AND FLAG
$CALL ASSIGN <R3,R1>			;ASSIGN THE LUN
ON.ERROR				;OOPS, ASSIGN FAILED
  $CALL ERROR <#6>			;SIGNAL
  LET CARRY := SET			;
ELSE					;OK
  DIR$ #ATTACH				;ATTACH DEVICE
  ON.ERROR ORB STATUS NE #IS.SUC	;ARE WE OK?
    $CALL ERROR <#7>			;NOPE, SIGNAL
    LET CARRY := SET			;
  ELSE					;YUP, OK
    LET NXTBLK := #0			;SET BLOCK TO WRITE
    $CALL NULBLK			;WRITE OUT NULL BLOCK
    ON.ERROR				;ARE WE OK?
      $CALL ERROR <#17.>		;NOPE, SIGNAL
      LET CARRY := SET			;
    END					;
    LET R0 := R0 L.ROTATE 1		;PRESERVE CARRY
    DIR$ #DETACH			;DETACH DEVICE
    LET R0 := R0 R.ROTATE 1		;RESTORE CARRY
  END					;
END					;
$RETURN					;
;
;
;
.END	TAR