SPL,L,O,M ! NAME: ST.DU ! SOURCE: 92067-18227 ! RELOC: 92067-16185 ! PGMR: G.A.A. ! ! *************************************************************** ! * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * ! * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * ! * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* ! * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ! *************************************************************** ! NAME ST.DU(8) "92067-16185 REV.2040 800731" ! ! MODIFICATION RECORD: ! ! DATE REASON ! 1) 780427 TO CALL IER. ON RETURN FROM CREA. (BL) ! (IER. CALL REMOVED FROM CREA.) ! 2) 780920 TO USE EXTENDED FMP ROUTINES (ECREA,ELOCF,ECLOS) ! 3) 790222 TO KILL DESTINATION FILE IF -5 ERROR ON READ, OR ! -33 ERROR ON WRITE ! 4) 790314 TO CHANGE TYPE 0 TEST FROM < 64 TO <= 20000K ! 5) 800311 TO REPORT WARNING ON TRUNCATION OF RECORDS TO ! 128 WORDS FOR TYPE 2 ! 6) 800731 IF REC FMT=MS, ALLOW ONLY AS,BR,BN,BA AS ! SECONDARY REC FMT (SST #4878) ! ! THIS IS THE RTE FMP FMGR ROUTINE TO STORE ! AND DUMP FILES. ! ! DU,NAME,LU,OP1,OP2,OP3 ! ! O R ! ! ST,LU,NAME,OP1,OP2,OP3,OP4 ! ! ! W H E R E: ! ! ST IS STORE. ! DU IS DUMP. ! ! NAME IS THE FILE TO BE STORED OR DUMPED. ! ! LU IS EITHER THE SOURCE OR DESTINATION ! DEVICE AND MAY BE A FILE REFERENCE. ! ! OP1 IS A MEDIUM ASC CODE AS FOLLOWS: ! AS ASCII DATA ! BR BINARY RELOCATABLE DATA ! BA BINARY ABSOLUTE DATA ! MT MAG TAPE NORMAL FORMAT ! MS MAG TAPE SIO FORMAT ! ! OP2 IS AN END OF FILE OPTION ! FLAG -- TWO ASC CHARACTERS: ! SA SAVE END OF FILES IN THE ! NEW FILE. ! IH INHIBIT ALL LEADER, TRAILER, ! END OF FILE TRANSFERS; ! DOES NOT APPLY TO FINAL ! EOF ON A DISC FILE. ! ! OP3 IS THE NUMBER OF THE FIRST FILE ! TO BE TRANSFERRED (APPLIES TO ! FILES OF TYPE ZERO) (DEFAULT=1) ! ! OP4 IS THE NUMBER OF FILES TO BE ! TRANSFERRED (APPLIES TO FILES ! OF TYPE ZERO) (DEFAULT= ) ! ! N O T E: OP3 AND OP4 ARE RELATIVE TO CURRENT POSITION. ! ! DEFINE EXTERNALS ! LET I.BUF,O.BUF,BUF. BE INTEGER,EXTERNAL ! LET N.OPL,.E.R. BE INTEGER,EXTERNAL ! LET ECREA,OPEN.,ELOCF,ECLOS,CLOS.,\ EXEC,READF,WRITF,\ MSS.,RWNDF,\ IER.,CK.SM BE SUBROUTINE,EXTERNAL LET .DDI,.DMP,.DSB BE SUBROUTINE,EXTERNAL,DIRECT ! LET IFBRK BE FUNCTION,EXTERNAL ! LET DU..,ST.. BE SUBROUTINE ! LET IDMY(2),ISZ(2),JSZ(4),RSIZ(2),ID1(2), \ BLKMP(2),DW1(2),DW2(2),DW4(2) BE INTEGER ! LET SECT2 BE CONSTANT(1757K) LET AS BE CONSTANT (40523K) LET BR BE CONSTANT (41122K) LET BN BE CONSTANT (41116K) LET BA BE CONSTANT (41101K) LET MT BE CONSTANT (46524K) LET MS BE CONSTANT (46523K) LET IH BE CONSTANT (44510K) LET SA BE CONSTANT (51501K) ! INITIALIZE BLKMP TO 0,128 INITIALIZE DW1 TO 0,1 INITIALIZE DW2 TO 0,2 INITIALIZE DW4 TO 0,4 ! ST..: SUBROUTINE(NPD,LISTO,ERD) GLOBAL ERD_ -1 !SET DUMP FLAG DU..(NPD,LISTO,ERD) RETURN END ! DU..: SUBROUTINE(NPS,LISTS,ERS) GLOBAL LI12_[LIS8_[LIS4_@LISTS+4]+4]+4 ! LIS21_[LIS17_[LIS13_[LIS9_[LIS5_[LIS1_\ @LISTS+1]+4]+4]+4]+4]+4 ! ! PRESET DEFAULT OPTIONS ! OBUF,SPDCB_@O.BUF !SET DCB ADDRESS FOR SPACING IBUF_@I.BUF !SET INPUT DCB ADDRESS BUFF,BUFA,BF_@BUF. DO[F1,SIOI,EOFF,CK,SIO,FLG_0;LDR_100000K] DO[SUBF_400K;F2,TYP,DUMP_1] IFNOT ERS+1 THEN [ERS,DUMP_0;SPDCB_IBUF] !SET STORE OPTIONS IF NPS<2 THEN [ERS_55;RETURN] DT_3 !SET DEFAULT TYPE ! ! ANALYZE OPTIONS ! ! FIRST THE TYPE FLAG ! IFNOT $LIS8 THEN GO TO ST3 !OPTION IS NULL GO TO CHECK NEXT IF $LIS9 = MS THEN [SIO_1;BUFA_BF+1;\ LIS9_LIS9+1] IF $LIS9=" " THEN GO TO ST3 IF $LIS9 = AS THEN [SUBF_410K;GO TO ST3] IF $LIS9 = BR THEN[CK,SUBF_310K;\ DT_5; GO TO ST3] IF $LIS9 = BN THEN[SUBF_310K; \ GO TO ST3] IF $LIS9 = BA THEN[CK,SUBF_2310K;TYP_0;\ DT_7;GO TO ST3] IFNOT SIO THEN \ [IF $LIS9 = MT THEN GO TO ST3; \ IF $LIS9 = SA THEN[EOFF_1;GO TO ST2];\ IF $LIS9 = IH THEN[LDR_0;GO TO ST2]] ! STER1:DO[ERS_56; RETURN] ! ! CHECK FOR OP2 ! ST3: IF $LI12#3 THEN GO TO ST2 ! IF $LIS13 = SA THEN[EOFF_1;GO TO ST5] IF $LIS13 = IH THEN[LDR_0;GO TO ST5] ! GO TO STER1 !ILLEGAL OPTION ! OPT2 WAS FOUND IN OP1 LOCATION SO ! ADJUST ADDRESSES AND SKIP ! OPT2 CHECK. ! ! ST2: DO[LIS21_[LIS17_LIS13]+4] ST5: OPEN.(I.BUF,$LIS1,N.OPL ,SUBF+1) !OPEN SOURCE NAMR ELOCF(I.BUF,.E.R.,IDMY,IDMY,ID,ISZ,ILU,INTY,ISZ2) IER. IF INTY=2 THEN [ \IF TYPE 2 AND RECLEN > IF ISZ2 > 128 THEN MSS.(79)] !128 WDS, PRINT WARNING IF $LIS17>0 THEN F1_$LIS17-1 IF $LIS21>0 THEN F2_$LIS21, ELSE \ [IFNOT $LIS21 THEN [IF$LIS17>0 THEN GOTO ST6,ELSE[\ IF INTY THEN F2_9999]]] ! ST6: SUBF_(SUBF AND 110K)+LDR \SET OUTPUT FUNCTION OR[IF (INTY AND 177775K)=5 THEN 100K,ELSE 0] IF $LIS9=AS THEN SUBF_SUBF AND 177677K ! IF A STORE OPERATION, CREATE THE FILE ! SZ1_[SZ_[TY_[OPLS_@N.OPL+5]+2]+1]+1 ! IFNOT ERS+2 THEN[ERS_0;GO TO ST12] !COPY CALL THE FILE IS OPEN IF DUMP THEN GO TO ST10 ! ! SET DEFAULTS ! IFNOT $TY THEN $TY_[IF INTY THEN INTY,\ ELSE DT] IF $SZ THEN [ \IF SIZE SPECIFIED, THEN IF $SZ < 0 THEN \IF SIZE NEGATIVE, THEN [IF $SZ = -1 THEN \IF SIZE = -1, THEN JSZ(1),JSZ(2) _ -1, \MAKE DOUBLE WORD, ELSE ELSE [.B._ -$SZ;.A._0; \MAKE POSITIVE AND CALL .DMP(BLKMP); \MULTIPLY BY BLK MULTIPLIER JSZ(1)_.A.;JSZ(2)_.B.]], \SAVE FOR ECREA ELSE [JSZ(1)_0;JSZ(2)_$SZ]], \SZ POSITIVE, MAKE DOUBLE WD ELSE \SIZE NOT SPECIFIED, SO [IF INTY THEN \IF NOT TYPE 0, DEFAULT SIZE [.B._ISZ(2);.A._ISZ(1); \TO SIZE FROM "FROM" FILE CALL .DDI(DW2)], \CONVERTING SECTORS TO BLOCKS ELSE [.B._ $SECT2;.A._0; \TYPE 0, SO DEFAULT SIZE TO CALL .DDI(DW4)]; \SECTORS PER TRACK/4 JSZ(1)_.A.;JSZ(2)_.B.] !SAVE FOR ECREA JSZ(3)_0 IF $SZ1 THEN JSZ(4)_$SZ1, \IF RECD SIZE, USE IT ELSE [IF INTY THEN $SZ1,JSZ(4)_ISZ2] ! ! CREAT THE FILE ! CLOS.(O.BUF) IF $LIS5 <= 20000K THEN GOTO ST10 ECREA(O.BUF,.E.R.,$LIS5,JSZ,$TY,$OPLS,$(OPLS+1),144,RSIZ) IER. GO TO ST12 ST10: OPEN.(O.BUF,$LIS5,$OPLS,SUBF) ST12: ELOCF(O.BUF,.E.R.,IDMY,IDMY,ID,ISZ,OLU,OUTY) IER. IF INTY=6 THEN $(IBUF+2),INTY_1 IF OUTY=6 THEN $(OBUF+2),OUTY_1 ! ! BOTH IN AND OUT ARE OPEN -- ! LEADER HAS BEEN PUNCHED IF NOT SUPPRESSED. ! ! IF SIO STORE THEN SET IT UP ! IF SIO THEN [IFNOT DUMP THEN[\ SIO_0; SIOI_1;BUFF_[BUFA_BF]+1]] ! UNTIL F1=0 DO[READF($SPDCB,.E.R.,$BUFA,128,ALN);IER.;\ IF ALN<1 THEN[F1_F1- 1; IF IFBRK() THEN GO TO BRK]] ST15: READF(I.BUF,.E.R.,$BUFA,128,ALN) IF IFBRK() THEN[\ IF BREAK THEN BRK: MSS.(0);GO TO KILL] ! SEND BREAK ERROR AND GO FLUSH THE FILE IF .E.R.= -12 THEN [ALN_ -1;GO TO ST16] IF .E.R.= -5 THEN [MSS.(.E.R.);GO TO KILL] !PURGE DESTINATION FL IER. IF ALN>0 THEN GO TO ST20 ! DATA? ! ! NO DATA -- EITHER EOF OR ZERO REG ! ! ! END OF XFER? ! ST16: IFNOT ALN+1 THEN[IF INTY THEN[F2_0;\ GO TO ST18]]!TRUE EOF-QUIT ! IF [F2_F2-1] THEN [IF EOFF THEN[ALN_-1;\ GO TO ST22],ELSE GO TO ST25] ST18: ALN_-1 IF LDR THEN GO TO ST22 ! GO TO EXIT !DONE - NO EOF REQUIRED ! ST20: DO [IF SIOI THEN [ALN_[\ IF $BUFA<0 THEN-$BUFA,ELSE\ ($BUFA+1)>-1];ID_BUFA+1],ELSE\ ID_BUFA ;IF CK THEN[\ CK.SM($ID,TYP)?[GO TO ABO];ALN_($ID-<8)+(1-TYP)*3]] FLG_1 !SET FLAG TO SAY WE WROTE A RECORD ST22: IF ALN>0 THEN[IF SIO THEN[$BUFF_-ALN;ALN_ALN+1]],\ ELSE[IF F2 THEN[IF OUTY THEN ALN_0]] WRITF(O.BUF,.E.R.,$BUFF,ALN) IF .E.R. = -33 THEN[MSS.(.E.R.);GO TO KILL] IER. IF ALN= -1 THEN[IFNOT F2 THEN GOTO EXIT,\ ELSE GO TO ST25 ] IF ALN THEN GO TO ST15 ST25: EXEC (13, ILU,EQT5) IF(EQT5 AND 37400K)=400K THEN [MSS.(2006);\ EXEC(7)] GO TO ST15 ! ABO: MSS.(7) !SEND CHECK SUM ERROR KILL: ID1(1),ID1(2)_-1 !SET TO ABORT THE FILE ENDIT:IF DUMP THEN RETURN IFNOT OUTY THEN RETURN IF ID1(1) < 0 THEN RWNDF(O.BUF) !REWIND TO BE SURE OF PURGE .B._RSIZ(2);.A._RSIZ(1) !ACTUAL FILE SIZE CALL .DDI(DW2) !CONVERT SECTORS TO BLOCKS CALL .DSB(ID1) CALL .DSB(DW1) IDMY(1)_.A.;IDMY(2)_.B. ECLOS(O.BUF,.E.R.,IDMY) !CLOSE AND TRUNCATE IER. RETURN ! EXIT: ELOCF(O.BUF,.E.R.,IDMY,ID1,IOF) IER. IF OUTY < 3 THEN[ \IF TYPE 2 OR 1 IFNOT IOF THEN \ADJUST RB FOR ZERO OFFSET [.B._ID1(2);.A._ID1(1); \ CALL .DSB(DW1); \ ID1(1)_.A.;ID1(2)_.B.]] IFNOT FLG THEN ID1(1),ID1(2)_-1 GO TO ENDIT END ! ! END END$