perm filename SCISS.SAI[S,AIL]9 blob
sn#189240 filedate 1975-12-04 generic text, type T, neo UTF8
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 VERSION_NUMBER = "'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 VERSION_NUMBER 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="60", 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);
⊃ "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∨WORD≠0;
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 ¬DSCRING∧SUBEQU("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 BREAK≠DELIM 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,2,0,400,BREAK,EOF);
OPEN(DSKO,"DSK",1,0,2,00,W,W);
OPEN(BINI,"DSK",'10,4,0,400,BREAK,BEOF);
OPEN(BINO,"DSK",'10,0,4,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)=6∧FIND(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 DOHEAD∧INTFIL THEN ⊂
ENTER(DSKO,"SAIHED.FAI",I); IF I THEN
USERERR(0,0,"TROUBLE WITH SAIHED");
WRITE CRLF&"↓HEDSYM←←1" EOM;
CLOSE (DSKO);
⊃;
IF INTFIL∧DOEXTR 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∨¬PTYSW∧CT=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=CT∧¬PTYSW ∨ 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;
SPEC[1]←CVSIX("SYS");
SPEC[2]←CVFIL(IF STANSW THEN "FAIL.DMP" ELSE "FAIL",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";