Trailing-Edge
-
PDP-10 Archives
-
decus_20tap1_198111
-
decus/20-0002/sciss.sai
There is 1 other file named sciss.sai in the archive. Click here to see a list.
COMMENT VALID 00009 PAGES VERSION 3-3(11)
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 HISTORY
C00004 00003 BEGIN "SCISS"
C00007 00004 A GREAT HAIRY KLUGE
C00010 00005 PROCEDURE LIBHED COMMENT PROCEDURE TO GROVEL OVER SAIHED.REL
C00014 00006 PROCEDURE LIBMAK (STRING F)
C00021 00007 MAIN EXECUTION STARTS HERE
C00031 00008 IF RPGSW THEN "SECOND PASS -- PROCESS LIBRARY"
C00036 00009
C00041 ENDMK
C;
COMMENT HISTORY
AUTHOR,SAIL,REASON
025 300300000013 ;
COMMENT
VERSION 3-3(11) 1-11-74 BY JRL USE CMU VERSION
VERSION 3-3(10) 12-4-73 BY RHT ADD LIBHED KLUGE TO SCISS
VERSION 3-3(9) 12-4-73
VERSION 3-3(8) 7-13-73 BY JRL AVOID "RENAME DIFFICULTY" FOR SAIREM
VERSION 3-3(7) 7-4-72 BY DCS FIX "D" BUG WHEN SELECTING FROM PROMPT
VERSION 3-3(6) 6-25-72 BY DCS ADD NAM COMMAND TO ORDER, LIBNAM FEATURE TO SCISS
VERSION 3-3(5) 5-23-72 BY DCS AVOID HDRFIL IF NOT NEEDED
VERSION 3-3(4) 2-24-72 BY DCS ADD RENSW CONTROL, CHANGE PARAMETER INPUT
VERSION 3-3(3) 2-10-72 BY DCS ADD OVERRIDE CAPABILITY FOR INTERMEDIATE FILE CREATION
VERSION 3-3(2) 2-10-72 BY DCS UPGRADE ORDER BUSINESS
VERSION 3-3(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
;
BEGIN "SCISS"
DEFINE VERSIONNUMBER = "'300300000013";
DEFINE
BINI="4",BINO="5",COMO="6",FUNI="7",SYMO="8",CRLF="('15&'12)",
WILLDO="'1",HAVDON="'2",ERROR="'4",
TTY="1",DSKI="2",DSKO="3",
BIT (X,Y)="Y LAND X",PUTBIT (X,Y)="X_X LOR Y",
REMBIT(X,Y)="X_X XOR Y",
TYPE="OUTSTR(",EOM="&('15&'12))",
WRITE="OUT(DSKO,",READ="INPUT(DSKI,1)",
CONTROLC="'3",
TOCRLF="8", OVERDEL="9", COMDEL="11",
KLUGETB="13"
;
REQUIRE VERSIONNUMBER VERSION;
STRING STR,LINE,LINE1,COMNAM,TS,FILE,FFFF,GOGFIL;
STRING LIBNAM, HLBNAM,GASNAM;
INTEGER I,J,TTYCHAR,FILCNT,SWITCH,W,BREAK,EOF,LOW,HIGH,BEOF,ENTSEEN;
INTEGER SYMBOL,SYMBOLS,RELOC,CCOUT,SYMCNT,TYPP,COMNO,SEEN;
INTEGER DELETING, COMMNT, DSCRING, WILLTELL, EACHASK, MAXTHS;
INTEGER NOTINCOM,DELIM,TEMPP,DOLIB,DOFAIL,CT,YV,DOEXTR;
INTEGER ENTPNT,DOHEAD,FILDEX,MAXFIL,GOGDO,EXTR,INTFIL,RENTLIB,GASLIB;
INTEGER WANTNOHDR;
LABEL ENDER,LAB;
EXTERNAL INTEGER RPGSW;
DEFINE MAXCOMP="70", EXTRACT="1", DOITBIT="4", HEADBIT="2",KLUGEBIT="'4000";
DEFINE GOGBIT="8";
STRING ARRAY ORDER,FILES[1:MAXCOMP]; INTEGER ARRAY BITS[1:MAXCOMP];
INTEGER ARRAY SPEC[1:10],BUFR,SYMBLOK[0:'23];
STRING ARRAY FILLST[1:20];
INTEGER ARRAY ENTRS[0:299];
INTEGER ARRAY DOTHIS[1:20];
INTEGER CMUSW,STANSW;
STRING SITEID;
DEFINE ="BEGIN",="END";
COMMENT A GREAT HAIRY KLUGE;
INTEGER HEADKLUGEDONE;
SIMPLE PROCEDURE KLGGZERO;HEADKLUGEDONE_0;
REQUIRE KLGGZERO INITIALIZATION;
PROCEDURE CPYFIL(STRING F1,F2,FIRSTLINE);
INTEGER I,J;
STRING S;
LOOKUP(DSKI,F1,I);
IF I THEN USERERR(1,1,"TROUBLE LOOKING UP:"&F1);
ENTER(DSKO,F2,J);
IF J THEN USERERR(0,0,"TROUBLE WITH ENTER ON:"&F2);
IF LENGTH(FIRSTLINE) THEN OUT(DSKO,FIRSTLINE);
DO
S_INPUT(DSKI,KLUGETB);
OUT(DSKO,S);
UNTIL EOF;
CLOSE(DSKO);
CLOSE(DSKI);
;
PROCEDURE KLUGE(INTEGER COMNO);
IF (BITS[COMNO] LAND KLUGEBIT) THEN RETURN;
IF NOT HEADKLUGEDONE THEN
HEADKLUGEDONE_1;
CPYFIL("HEAD","HEAD.FAI",NULL);
;
IF EQU(ORDER[COMNO],"SAIHED") THEN
FILES[COMNO]_"SAIHED.FAI,HEAD.FAI";
ELSE IF EQU(ORDER[COMNO],"SAILEP") THEN
CPYFIL("LEPRUN","SAILEP.FAI","SEARCH HDRFIL"&CRLF);
FILES[COMNO]_"SAILEP.FAI/R";
ELSE IF EQU(ORDER[COMNO],"SAIREM") THEN
CPYFIL("WRDGET","SAIREM.FAI","SEARCH HDRFIL"&CRLF);
FILES[COMNO]_"SAIREM.FAI/R";
ELSE
OUTSTR("SURPRISE USE OF HAIRY KLUGE: "&ORDER[COMNO]&"
TYPE ANY KEY TO GO ON (SHOULD BE OK)");
INCHRW;
;
;
PROCEDURE LIBHED; COMMENT PROCEDURE TO GROVEL OVER SAIHED.REL;
"LIBHED"
INTEGER COUNT,TYPEWD,BLKSIZ,BRK,EOF; DEFINE SRC="BINI",DST="BINO";
INTEGER PERLINE;
INTEGER ARRAY BLOCK[0:17];
PROCEDURE GETBLK;
"GETBLK"
IF COUNT=0 THEN
TYPEWD _ WORDIN(SRC);
COUNT _ TYPEWD LAND '777777;
TYPEWD _ TYPEWD LSH -18
;
WORDIN(SRC);
ARRYIN(SRC,BLOCK[0],BLKSIZ _ COUNT MIN 18);
COUNT _ COUNT - BLKSIZ
"GETBLK";
PROCEDURE PUTBLK(INTEGER TYP, VAL1, VAL2);
"PUTBLK"
INTEGER CT;
WORDOUT(DST,TYP LSH 18 + (CT_CASE TYP OF (0,0,2,0,1,1,2)));
WORDOUT(DST,IF TYP=5 THEN '2 LSH 33 ELSE 0);
WORDOUT(DST,VAL1);
IF CT=2 THEN WORDOUT(DST,VAL2);
"PUTBLK";
RECURSIVE STRING PROCEDURE R50TO7(INTEGER SYM); "R50TO7"
COMMENT CONVERT RADIX50 TO ASCII;
IF SYM=0 THEN RETURN(NULL) ELSE
INTEGER CHAR; CHAR_SYM MOD '50;
CHAR_IF CHAR LEQ 10 THEN CHAR-1+"0"
ELSE IF CHAR LEQ 10+"Z"-'101 THEN CHAR-11+"A"
ELSE IF CHAR=37 THEN "."
ELSE IF CHAR=38 THEN "$"
ELSE IF CHAR=39 THEN "%"
ELSE 0;
RETURN(R50TO7(SYM % '50)&CHAR) "R50TO7";
IF DOLIB THEN RETURN;
OUTSTR("COPYING (SPECIALLY) SAIHED.REL
");
LOOKUP(SRC,"SAIHED.REL",COUNT);
PERLINE_COUNT_0;
DO GETBLK UNTIL TYPEWD=2;
OPEN(SYMO,"DSK",0,0,3,I,I,I); IF I THEN USERERR(0,0,"NO DSK TODAY");
ENTER(SYMO,"GOGTAB.DEF",I); IF I THEN USERERR(0,0,"CANT ENTER GOGTAB.DEF");
OUT(SYMO,"REQUIRE ""[][]"" DELIMITERS;"&CRLF&
"COMMENT SYMBOLIC USER TABLE INDICES");
DO
INTEGER B,C;
C_BLOCK[0];
IF (LDB(POINT(6,C,5)) LAND '74) = '44 THEN
PUTBLK(4,B_C LAND '37777777777,0);
PUTBLK(6,B,0);
PUTBLK(2,C,BLOCK[1]);
IF (PERLINE LAND '37) THEN OUT(SYMO,";"&CRLF&CRLF&"DEFINE ")
ELSE OUT(SYMO,IF (PERLINE LAND 3) THEN ","&CRLF ELSE ",");
OUT(SYMO,R50TO7(B)&"=['"&CVOS(BLOCK[1])&"]");
PERLINE_PERLINE+1;
PUTBLK(5,0,0);
;
GETBLK
UNTIL TYPEWD=5;
OUT(SYMO,";"&CRLF&CRLF&"REQUIRE UNSTACK!DELIMITERS;"); RELEASE(SYMO);
COMMENT AS FUDGE2 DOES NOT COPY THE LAST ELEMENT WE MUST PROVIDE A DUMMY;
PUTBLK(0,0,0);
CLOSE(SRC);
LOOKUP(SRC,"HEAD.FAI",COUNT);
IF NOT(COUNT) THEN BEGIN
RENAME(SRC,NULL,0,COUNT); COMMENT DELETE HEAD.FAI;
OUTSTR((IF COUNT THEN "RENAME DIFFICULTY WITH HEAD.FAI" ELSE
"HEAD.FAI DELETED")&CRLF) END;
CLOSE(SRC);
"LIBHED";
PROCEDURE LIBMAK (STRING F);
STRING FILN; INTEGER ETWAS;
BEOF_0; ENTPNT_ETWAS_0;
IF DELETING THEN "DEL FAIL"
LOOKUP(BINI,F&".FAI",I);
RENAME (BINI,"",0,I);
OUTSTR((IF I THEN "RENAME DIFFICULTY WITH " ELSE NULL)&
F&(IF I THEN ".FAI " ELSE ".FAI DELETED "));
CLOSE (BINI);
ETWAS_TRUE;
"DEL FAIL";
FILN_F&".REL";
IF EQU(F,"SAIHED") THEN
LIBHED
ELSE IF DOLIB THEN "COP FIL"
LOOKUP (BINI,FILN,I);
IF I THEN OUTSTR( "COPYING "&FILN);
ETWAS_TRUE;
SYMBLOK[1]_SYMCNT_0;
IF I THEN WHILE BEOF DO "COP BLK"
DEFINE WORD="BUFR[0]";
DO WORD _ WORDIN(BINI) UNTIL BEOF WORD0;
TYPP_WORD LAND '77000000;
CCOUT _ WORD LAND '777 ;
ARRYIN (BINI,BUFR[1],CCOUT+1);
IF TYPP='4000000 THEN "ENTRY BLOCK"
ARRBLT(ENTRS[ENTPNT],BUFR[2],CCOUT);
ENTPNT_ENTPNT+CCOUT;
"ENTRY BLOCK" ELSE
"NOT ENTRY"
IF ENTPNT THEN "WRITE ENTRY"
WORDOUT(BINO,'4000000+ENTPNT);
FOR I_0 STEP 18 UNTIL ENTPNT-1 DO "WR ECH"
WORDOUT(BINO,0);
ARRYOUT(BINO,ENTRS[I],18 MIN (ENTPNT-I));
"WR ECH"
"WRITE ENTRY";
ENTPNT_0;
IF TYPP = '5000000 AND SYMCNT THEN "END BLOCK"
COMMENT THIS IS THE END BLOCK -- FORCE OUT SYMBOLS.;
SYMBLOK[0] _ '2000000 +SYMCNT ;
ARRYOUT (BINO,SYMBLOK[0],SYMCNT+2);
"END BLOCK";
IF TYPP '2000000 THEN "NOT SYMBOLS"
COMMENT COPY THE BLOCK TO THE OUTPUT FILE;
ARRYOUT (BINO,BUFR[0],CCOUT+2);
"NOT SYMBOLS" ELSE
COMMENT THESE ARE SYMBOLS. COPY THEM IF SYMBOLS
ARE REQUESTED. OTHERWISE,
IGNORE UNLESS INTERNAL OR EXTERNAL.;
FOR I_2 STEP 2 UNTIL CCOUT+1 DO
IF LDB(POINT(1,BUFR[I],2))1 THEN
"SYMS"
SYMCNT _ SYMCNT +2;
SYMBLOK[SYMCNT]_BUFR[I];
SYMBLOK[SYMCNT+1]_BUFR[I+1];
SYMBLOK[1]_SYMBLOK[1] LOR (((BUFR[1]
ROT (2*I)) LAND '17 ) ROT (-2*SYMCNT));
COMMENT LAST LINE WAS UPDATING RELOCATION BITS.;
IF SYMCNT ='22 THEN
SYMBLOK[0] _ '2000022 ;
ARRYOUT (BINO,SYMBLOK[0],'24);
SYMCNT_SYMBLOK[1]_0;
;
"SYMS";
IF TYPP ='5000000 THEN DONE
"NOT ENTRY"
"COP BLK"
"COP FIL";
IF DELETING THEN "DEL FIL"
CLOSE (BINI);
LOOKUP (BINI,FILN,I);
RENAME (BINI,"",0,I); ETWAS_TRUE;
OUTSTR((IF I THEN " RENAME FAILURE FOR " ELSE " ")&
FILN & (IF I THEN NULL ELSE " DELETED"));
"DEL FIL";
IF ETWAS THEN TYPE NULL EOM;
;
BOOLEAN PROCEDURE YESNO(STRING S);
OUTSTR(S&"?");
RETURN(IF (YV_INCHWL)="N" THEN FALSE ELSE YV)
"YESNO";
COMMENT -- BLOCK TYPE MISMATCH -- HAVE"YESNO", NEED ;
BOOLEAN PROCEDURE SUBEQU(STRING S1,S2);
RETURN(EQU(S1,S2[1 FOR LENGTH(S1)]));
STRING PROCEDURE COMPRESS(STRING L,M);
"COMPRESS"
IF DSCRING NOTINCOM M=";" LENGTH(M)
SUBEQU("COMPIL",M) THEN RETURN(NULL)
ELSE RETURN(L&CRLF)
"COMPRESS";
PROCEDURE GETLINE;
"GETLINE"
LINE1_LINE_INPUT(DSKI,TOCRLF);
TS_SCAN(LINE1,OVERDEL,I);
IF DSCRINGSUBEQU("DSCR",LINE1) THEN DSCRING_TRUE;
IF SUBEQU("COMMENT",LINE1)
SUBEQU("Comment",LINE1)
SUBEQU("comment",LINE1) THEN
TS_SCAN(LINE1_LINE1[8 TO ],OVERDEL,I);
DELIM_I; SETBREAK(COMDEL,DELIM,NULL,"IN");
I_LOP(LINE1);
I_0; TS_SCAN(LINE1,COMDEL,BREAK); IF BREAKDELIM THEN
DO LINE1_INPUT(DSKI,COMDEL) UNTIL BREAK=DELIM;
LINE1_NULL
;
OUT(DSKO,COMPRESS(LINE,LINE1));
IF DSCRING(LINE1="" LINE1=";") THEN DSCRING_FALSE;
"GETLINE";
BOOLEAN PROCEDURE FIND(STRING S);
"FIND"
FOR COMNO_1 STEP 1 UNTIL MAXTHS DO
IF EQU(S,ORDER[COMNO]) THEN RETURN(TRUE);
RETURN(FALSE)
"FIND";
PROCEDURE MARKIT(INTEGER C);
INTEGER I;
FOR I_1 STEP 1 UNTIL MAXFIL DO
IF EQU(FILES[C],FILLST[I]) THEN
DOTHIS[I]_TRUE; DONE
;
IF BITS[C] LAND EXTRACT THEN FILES[C]_ORDER[C]&"/R";
"MARKIT";
COMMENT -- BLOCK TYPE MISMATCH -- HAVE"MARKIT", NEED ;
COMMENT MAIN EXECUTION STARTS HERE;
OPEN(DSKI,"DSK",1,5,0,400,BREAK,EOF);
OPEN(DSKO,"DSK",1,0,5,00,W,W);
OPEN(BINI,"DSK",'10,7,0,400,BREAK,BEOF);
OPEN(BINO,"DSK",'10,0,7,00,W,W);
OPEN(COMO,"DSK",1,0,2,00,W,W);
BREAKSET(1,""&'15,"I");
BREAKSET(1,'12,"O");
BREAKSET(1,NULL,"N");
BREAKSET(2,","&'15,"I");
SETBREAK(TOCRLF,'12,'15&'14,"IN");
SETBREAK(OVERDEL," ",NULL,"XNR");
SETBREAK(KLUGETB,'12,NULL,"INA");
OUTSTR("SITE ID (<CR> OK FOR SU-AI) = ");
SITEID_INCHWL;
IF EQU(SITEID,"SU-AI") OR LENGTH(SITEID)=0 THEN
STANSW_1;
ELSE
STANSW_0;
;
IF EQU(SITEID,"CMU") THEN CMUSW_1 ELSE CMUSW_0;
GASLIB_EACHASK_WILLTELL_GOGDO_RENTLIB_WANTNOHDR_FALSE;
DELETING_DOLIB_DOHEAD_DOEXTR_DOFAIL_INTFIL_TRUE;
IF YESNO("STANDARD") THEN "ASK"
STRING ANSWER; INTEGER FROMPASS1;
OUTSTR("
TYPE THE NUMBERS OF THOSE PARAMETERS YOU WISH TO AFFECT:
INDEX DESCRIPTION
");
IF NOT CMUSW THEN
OUTSTR(IF RPGSW THEN "
1 PASS 2 NOW
2 DON'T CHAIN TO FAIL
3 DON'T CREATE INTERMEDIATE FILES
4 MAKE RE-ENTRANT LIBRARY
5 SELECT ENTRIES FROM PROMPT-LIST
6 SPECIFY ENTRIES EXPLICITLY
7 DON'T DELETE INTERMEDIATE FILES (PASS 2)
8 DON'T MAKE A LIBRARY (PASS 2)
" ELSE "
1 DON'T DELETE INTERMEDIATE FILES
2 DON'T MAKE A LIBRARY
3 MAKE A RE-ENTRANT LIBRARY
4 SELECT ENTRIES FROM PROMPT-LIST
5 SPECIFY ENTRIES EXPLICITLY
");
IF CMUSW THEN
OUTSTR(IF RPGSW THEN "
1 PASS 2 NOW
2 DON'T CHAIN TO FAIL
3 DON'T CREATE INTERMEDIATE FILES
4 MAKE RE-ENTRANT LIBRARY
5 SELECT ENTRIES FROM PROMPT-LIST
6 SPECIFY ENTRIES EXPLICITLY
7 DON'T DELETE INTERMEDIATE FILES (PASS 2)
8 DON'T MAKE A LIBRARY (PASS 2)
9 MAKE GAS LIBRARY (IMPLIES REENTRANT)
" ELSE "
1 DON'T DELETE INTERMEDIATE FILES
2 DON'T MAKE A LIBRARY
3 MAKE A RE-ENTRANT LIBRARY
4 SELECT ENTRIES FROM PROMPT-LIST
5 SPECIFY ENTRIES EXPLICITLY
6 MAKE GAS LIBRARY (IMPLIES REENTRANT)
");
OUTSTR("*");
ANSWER_INCHWL;
FROMPASS1_FALSE;
WHILE LENGTH(ANSWER) DO
LABEL TOOBIG; INTEGER ANSCODE,I;
ANSCODE_INTSCAN(ANSWER,I); IF ANSCODE THEN DONE;
IF RPGSW THEN CASE ANSCODE MIN 9 OF
[1]
RPGSW_TRUE; FROMPASS1_TRUE
;
[2] DOFAIL_FALSE;
[3] INTFIL_FALSE;
[4] RENTLIB_TRUE;
[5] EACHASK_TRUE;
[6] WILLTELL_TRUE;
[7] GO TO TOOBIG;
[8] GO TO TOOBIG;
[9] IF NOT CMUSW THEN GO TO TOOBIG ELSE
RENTLIB_GASLIB_TRUE;
[10]
ELSE
CASE (IF FROMPASS1 THEN ANSCODE MIN 6 ELSE
(CASE ANSCODE MIN 8 OF (0,0,0,0,3,4,5,1,2,6))) OF
[1] DELETING_FALSE;
[2] DOLIB_FALSE;
[3] RENTLIB_TRUE;
[4] EACHASK_TRUE;
[5] WILLTELL_TRUE;
[6] IF NOT CMUSW THEN GO TO TOOBIG ELSE RENTLIB_GASLIB_TRUE;
[7]
TOOBIG:OUTSTR(CVS(ANSCODE)&" TOO BIG -- IGNORED"&('15&'12))
;
;
"ASK";
IF RENTLIB THEN DOLIB_TRUE;
W_CALL (W,"PJOB");
COMNAM_"0"&CVS( W % 10 )&CVS( W MOD 10)&"FAI.TMP";
I_0;
COMMENT READ IN THE ORDER CODE;
GOGDO_FALSE; COMMENT ON IF COMPIL SPEC WANTS GOGOL;
LOOKUP (DSKI,"ORDER",I);
IF I THEN
TYPE "CAN'T FIND ORDER" EOM; GO ENDER
;
LINE_READ; COMMENT GET COMMENT LINE;
LINE_READ; COMMENT GET REST OF COMMENT LINE;
MAXTHS_MAXFIL_0;
DOTHIS[1]_FALSE; ARRBLT(DOTHIS[2],DOTHIS[1],19);
WHILE SUBEQU("END",FFFF_READ) DO "GSPEC"
STRING GGGG; GGGG_FFFF[1 TO 3]; FFFF_FFFF[5 TO ];
EXTR_0;
IF EQU("NAM",GGGG) THEN "LIBRARY NAME"
LIBNAM_"LIBSA"&(GGGG_SCAN(FFFF,2,I))&".REL";
HLBNAM_"HLBSA"&GGGG&".REL";
GASNAM_"GLBSA"&GGGG&".REL";
"LIBRARY NAME" ELSE
IF EQU("ALL",GGGG) THEN
WHILE LENGTH(FFFF) DO "PREP HDRFIL"
GGGG_SCAN(FFFF,2,I); IF GGGG="!" THEN
GGGG_GOGFIL_GGGG[2 TO ];
FILLST[MAXFIL_MAXFIL+1]_GGGG;
DOTHIS[MAXFIL]_TRUE
"PREP HDRFIL" ELSE "LIB LIST"
LABEL DONEONELIBL;
IF EQU("HDR",GGGG) THEN "STD LIB"
IF FFFF[INF FOR 1]="*" THEN
IF GASLIB THEN
OUTSTR(READ&" NOT BEING DONE BECAUSE THIS IS GASSY"&CRLF);
GO TO DONEONELIBL;
ELSE FFFF_FFFF[1 TO INF-1];
;
EXTR_IF EQU(FFFF,GOGFIL) THEN EXTRACT+GOGBIT ELSE EXTRACT;
FOR I_1 STEP 1 UNTIL MAXFIL DO IF EQU(FFFF,FILLST[I]) THEN DONE;
IF I>MAXFIL THEN FILLST[MAXFIL_MAXFIL+1]_FFFF
"STD LIB" ELSE IF EQU("HED",GGGG) THEN EXTR_HEADBIT+KLUGEBIT
ELSE EXTR_KLUGEBIT;
LINE_(READ)[2 TO ];
WHILE LENGTH(LINE) DO "ONE LIB"
ORDER[MAXTHS_MAXTHS+1]_"SAI"&SCAN(LINE,2,J);
BITS[MAXTHS]_EXTR;
FILES[MAXTHS]_FFFF
"ONE LIB";
DONEONELIBL:
"LIB LIST"
"GSPEC";
CLOSE(DSKI);
IF WILLTELL THEN "GET ORDER"
INTEGER K,KK,J; K_0;
IF EACHASK THEN TYPE "TYPE `Y', `N', OR `DONE'" EOM;
FOR I_1 STEP 1 UNTIL MAXTHS DO
TS_ORDER[I];
IF EACHASK (KK_YESNO(TS))="Y" THEN
IF (J_BITS[I]) LAND GOGBIT THEN GOGDO_TRUE;
BITS[I]_J LOR DOITBIT;
MARKIT(I)
ELSE IF KK="D" THEN
IF (I_I-1)<0 K=0 THEN DONE ELSE EACHASK_FALSE;
K_KK
"GET ORDER" ELSE
"TAKE ORDER"
TS_NULL;
TYPE "TYPE LIBRARY TITLES, `DONE' WHEN DONE" EOM;
NEEDNEXT WHILE EQU("DONE",TS) DO
OUTSTR("*");
TS_INCHWL; NEXT;
IF SUBEQU("SAI",TS)LENGTH(TS)=6FIND(TS) THEN
IF (J_BITS[COMNO]) LAND GOGBIT THEN GOGDO_TRUE;
BITS[COMNO]_J LOR DOITBIT;
MARKIT(COMNO)
ELSE
TYPE TS&" INVALID -- TRY AGAIN " EOM;
;
"TAKE ORDER";
IF RPGSW THEN "SECOND PASS -- PROCESS LIBRARY"
IF DELETING AND WANTNOHDR THEN
LOOKUP(BINI,"HDRFIL",I);
RENAME (BINI,"",0,I);
IF I THEN TYPE "RENAME DIFFICULTY WITH HDRFIL" EOM
ELSE TYPE "HDRFIL DELETED" EOM;
CLOSE (BINI);
IF RENTLIB THEN
LOOKUP(BINI,"SAIREN.FAI",I);
RENAME(BINI,"",0,I);
IF I THEN TYPE "RENAME DIFFICULTY WITH SAIREN" EOM
ELSE TYPE "SAIREN.FAI DELETED" EOM;
CLOSE (BINI)
;
I_0;
IF DOLIB THEN
ENTER (BINO,IF GASLIB THEN GASNAM ELSE IF RENTLIB THEN HLBNAM ELSE LIBNAM,I);
IF I THEN
TYPE "CAN'T ENTER "&LIBNAM&".REL" EOM; GO ENDER
;
FOR COMNO_1 STEP 1 UNTIL MAXTHS DO IF BITS[COMNO] LAND DOITBIT THEN
LIBMAK (ORDER[COMNO]);
CLOSE (BINO); COMMENT THIS IS THE LIBRARY;
IF DOLIB THEN
TYPE "TRY OUT YOUR NEW LIBRARY!" EOM
ELSE
TYPE "READY FOR WHATEVER" EOM
;
"SECOND PASS -- PROCESS LIBRARY" ELSE "FIRST PASS"
INTEGER PTYSW;
ENTER (COMO,COMNAM,I);
DOHEAD_DOEXTR_FALSE;
IF I THEN TYPE "CANNOT ENTER COMMAND FILE" EOM;
INTEGER FUNTIM,HEDTIM;
INTEGER PROCEDURE FILTIM; INTEGER ARRAY X[0:6];
FILEINFO(X);
RETURN( ((X[1] LAND '700000) LSH 8) LOR
(((X[2] LAND '7777)) LSH 11) LOR ((X[2] LSH -12) LAND '3777) );
COMMENT Check creation date of HDRFIL.FUN to see if we need a new one;
OPEN(FUNI,"DSK",0,0,0,I,I,I);
LOOKUP(FUNI,"HDRFIL.FUN",I); IF I THEN WANTNOHDR_FALSE ELSE
FUNTIM_FILTIM; CLOSE(FUNI);
LOOKUP(FUNI,"HEAD",I); HEDTIM_FILTIM; CLOSE(FUNI);
LOOKUP(FUNI,"GOGOL",I); HEDTIM_FILTIM MAX HEDTIM; CLOSE(FUNI);
WANTNOHDR_IF FUNTIM>HEDTIM THEN TRUE ELSE FALSE;
RELEASE(FUNI); ;
;
IF WANTNOHDR THEN OUT(COMO,"HDRFIL/R_HDRFIL"&CRLF);
FOR COMNO_1 STEP 1 UNTIL MAXTHS DO
IF BITS[COMNO] LAND DOITBIT THEN
STRING SRCFIL;
IF BITS[COMNO] LAND EXTRACT THEN DOEXTR_TRUE;
IF BITS[COMNO] LAND HEADBIT THEN DOHEAD_TRUE;
KLUGE(COMNO);
OUT(COMO,ORDER[COMNO]&"/R_"&(IF RENTLIB THEN "SAIREN.FAI," ELSE NULL)&
FILES[COMNO]&CRLF);
TYPE ORDER[COMNO]&" WILL BE ASSEMBLED" EOM
;
OUT(COMO,"DSK:SCISS!"&CRLF);
CLOSE(COMO); CLOSE(DSKO);
IF RENTLIB THEN
ENTER(DSKO,"SAIREN.FAI",I); IF I THEN
USERERR(0,0,"TROUBLE WITH SAIREN");
OUT(DSKO,"RENSW__1"&CRLF&CRLF);
IF GASLIB THEN OUT(DSKO,"?GASSW__1"&CRLF&CRLF);
CLOSE(DSKO)
;
IF DOHEADINTFIL THEN
ENTER(DSKO,"SAIHED.FAI",I); IF I THEN
USERERR(0,0,"TROUBLE WITH SAIHED");
WRITE CRLF&"HEDSYM__1" EOM;
CLOSE (DSKO);
;
IF INTFILDOEXTR THEN "CR INT FIL"
NOTINCOM_FALSE;
ENTER(DSKO,IF WANTNOHDR THEN "JUNK" ELSE "HDRFIL",I);
IF I THEN USERERR(0,0,"TROUBLE WITH HDRFIL");
WRITE "
UNIVERSAL HDRFIL
ALWAYS__0" EOM;
CT_0; PTYSW_0; FILDEX_0;
WHILE TRUE DO "DO FILE"
LABEL D;
PROCEDURE OPNFIL; "OPNFIL"
IF SUBEQU("HEAD",FILLST[FILDEX+1]) AND WANTNOHDR THEN FILDEX_FILDEX+1;
WHILE (FILDEX_FILDEX+1) MAXFIL DO IF DOTHIS[FILDEX] THEN
FILE_FILLST[FILDEX];
CLOSE(DSKI);
DSCRING_FALSE;
OUTSTR("LOOKING AT "&FILE&CRLF);
LOOKUP(DSKI,FILE,I); IF I THEN USERERR(0,0,"CAN'T FIND "&
FILE);
EOF_FALSE;
DONE
;
"OPNFIL";
COMMENT -- BLOCK TYPE MISMATCH -- HAVE"OPNFIL", NEED ;
OPNFIL; IF FILDEX>MAXFIL THEN DONE;
DO "READ THE LINES"
GETLINE;
IF SUBEQU("COMPIL",LINE) THEN "IS A COMPILE"
IF CT=MAXTHS+1 PTYSWCT=MAXTHS THEN DONE;
IF EQU(FILE,GOGFIL)GOGDO THEN
OUTSTR("ABANDONING "&FILE&" AFTER HDRFIL"&CRLF);
WRITE "END" EOM; COMMENT END OF UNIVERSAL FILE;
OPNFIL;IF FILDEX>MAXFIL THEN GO D
;
IF FIND(TS_"SAI"&LINE[8 FOR 3])
BITS[COMNO] LAND (DOITBIT+EXTRACT)=DOITBIT+EXTRACT THEN
"WANT THIS ONE"
NOTINCOM_FALSE; WRITE "END" EOM; CLOSE(DSKO);
CT_CT+1;
ENTER(DSKO,TS&".FAI",I);
IF I THEN USERERR(0,0,"TROUBLE WITH SAI"&TS);
TYPE TS&" FOUND" EOM;
IF EQU(TS,"PTY") THEN PTYSW_TRUE;
COMMNT_DSCRING_FALSE;
WRITE "SEARCH HDRFIL" EOM;
WRITE LINE EOM
"WANT THIS ONE"
ELSE NOTINCOM_TRUE
"IS A COMPILE"
ELSE IF NOTINCOM SUBEQU("ENDCOM",LINE1)
THEN "THERE"
NOTINCOM_TRUE
"THERE";
"READ THE LINES" UNTIL EOF ((MAXTHS=CT)PTYSW) (CT=MAXTHS+1);
IF MAXTHS=CTPTYSW CT=MAXTHS+1 THEN DONE;
IF FALSE THEN D: DONE;
"DO FILE";
"CR INT FIL";
CLOSE(DSKO);
COMMENT NOW CHAIN TO FAIL, ONE WAY OR ANOTHER. USE PRIVATE FAIL IF EXISTS;
CLOSE(DSKI);
LOOKUP(DSKI,IF STANSW THEN "FAIL.DMP" ELSE "FAIL.SAV",EOF);
SPEC[1]_CVSIX(IF EOF THEN "SYS" ELSE "DSK");
SPEC[2]_CVFIL(IF STANSW THEN "FAIL.DMP"
ELSE IF EOF THEN "FAIL" ELSE "FAIL.SAV"
,SPEC[3],SPEC[5]);
SPEC[4]_IF STANSW THEN 1 ELSE 0;
SPEC[6]_0;
IF DOFAIL THEN CALL(
(IF STANSW THEN 0 ELSE '1000000)+POINT(0,SPEC[1],35),
IF STANSW THEN "SWAP" ELSE "RUN" );
"FIRST PASS";
ENDER:
"SCISS";