perm filename SCISS.NEW[S,AIL] blob
sn#229801 filedate 1976-08-05 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00010 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 HISTORY
C00004 00003 BEGIN "SCISS"
C00007 00004 A GREAT HAIRY KLUGE
C00010 00005 PROCEDURE KLUGE(INTEGER COMNO)
C00012 00006 PROCEDURE LIBHED(STRING FLN) COMMENT PROCEDURE TO GROVEL OVER SAIHED.REL
C00016 00007 PROCEDURE LIBMAK (STRING FINTEGER ITYP)
C00023 00008 MAIN EXECUTION STARTS HERE
C00035 00009 IF RPGSW THEN ⊂ "SECOND PASS -- PROCESS LIBRARY"
C00040 00010 BAIL
C00044 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"
EXTERNAL PROCEDURE BAIL;
DEFINE VERSION_NUMBER = "'300300000013";
DEFINE
CRLF="('15&'12)",
WILLDO="'1",HAVDON="'2",ERROR="'4",
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"
;
INTEGER BINI,BINO,COMO,FUNI,SYMO,TTY,DSKI,DSKO;
REQUIRE VERSION_NUMBER VERSION;
STRING STR,LINE,LINE1,COMNAM,TS,FILE,FFFF,GOGFIL;
STRING LIBNAM, HLBNAM,GASNAM;
INTEGER I,J,TTYCHAR,FILCNT,SWITCH,W,BRKCHR,EOF,LOW,HIGH,BEOF,ENTSEEN;
INTEGER SYMBOL,SYMBOLS,RELOC,CCOUT,SYMCNT,TYPP,COMNO,SEEN,IQ;
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,TYMSW,BTHLIB;
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";
REQUIRE "<><>" DELIMITERS;
IFC EQU(COMPILER!BANNER[LENGTH(SCANC(COMPILER!BANNER,"-",NULL,
"IA"))+1 FOR 8],"TYMSHARE") THENC
DEFINE TYMSWC=<TRUE>; ELSEC DEFINE TYMSWC=<FALSE>; ENDC;
REQUIRE UNSTACK!DELIMITERS;
IFC TYMSWC THENC INTEGER RPGCHL,RPGEOF; ENDC;
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);
⊃;
INTEGER PROCEDURE FILTIM;
BEGIN INTEGER ARRAY X[0:6];
FILEINFO(X);
RETURN ( (IFC TYMSWC THENC (X[1] LAND '140000) LSH 9 ELSEC
(X[1] LAND '700000) LSH 8 ENDC) LOR
((X[2] LAND '7777) LSH 11) LOR ((X[2] LSH -12)
LAND '3777));
END "FILTIM";
PROCEDURE TIMCHK(STRING S1,S2;INTEGER NUM);
BEGIN INTEGER TIM3,TIM2,FLG; STRING S3;
TIM2←0;
WHILE (S3←SCAN(S2,2,TIM3)) NEQ NULL DO BEGIN
LOOKUP (FUNI,S3,FLG);
IF FLG NEQ 0 THEN BEGIN TIM2←'377777777777; DONE; END;
TIM2←TIM2 MAX FILTIM; END;
IF RENTLIB OR BTHLIB THEN LOOKUP (FUNI,"SAH"&S1[4 TO INF]&".REL",FLG)
ELSE LOOKUP (FUNI,S1&".REL",FLG);
IF NOT RENTLIB AND BTHLIB THEN BEGIN
IF FLG=0 THEN BEGIN TIM3←FILTIM;
LOOKUP (FUNI,S1&".REL",FLG); END ELSE
TIM3←0; END;
IF FLG NEQ 0 OR TIM2 GEQ TIM3 MAX FILTIM THEN
BITS[NUM]←BITS[NUM] LOR DOITBIT;
END "TIMCHK";
PROCEDURE KLUGE(INTEGER COMNO);
⊂
IF RPGSW THEN BEGIN BITS[I]←BITS[I] LOR DOITBIT;
RETURN; END;
IF ¬(BITS[COMNO] LAND KLUGEBIT) THEN BEGIN
TIMCHK(ORDER[COMNO],FILES[COMNO],COMNO); RETURN; END;
IF EQU(ORDER[COMNO],"SAIHED") THEN
⊂
FILES[COMNO]←"SAIHED.FAI,HEAD";
TIMCHK(ORDER[COMNO],"SAIHED.FAI,HEAD",COMNO);
⊃
ELSE IF EQU(ORDER[COMNO],"SAILEP") THEN
⊂
CPYFIL("LEPRUN","SAILEP.FAI","SEARCH HDRFIL"&CRLF);
TIMCHK("SAILEP","LEPRUN,HDRFIL.FUN,GOGOL,HEAD",COMNO);
FILES[COMNO]←"SAILEP.FAI/R";
⊃
ELSE IF EQU(ORDER[COMNO],"SAIREM") THEN
⊂
CPYFIL("WRDGET","SAIREM.FAI","SEARCH HDRFIL"&CRLF);
TIMCHK("SAIREM","WRDGET,HDRFIL.FUN,GOGOL,HEAD",COMNO);
FILES[COMNO]←"SAIREM.FAI/R";
⊃
ELSE
⊂
OUTSTR("SURPRISE USE OF HAIRY KLUGE: "&ORDER[COMNO]&"
TYPE ANY KEY TO GO ON (SHOULD BE OK)");
INCHRW;
TIMCHK(ORDER[COMNO],FILES[COMNO],COMNO);
⊃;
⊃;
PROCEDURE LIBHED(STRING FLN); 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,FLN,COUNT);
IF COUNT NEQ 0 THEN USERERR (0,0,"MISSING SAIHED.REL");
PERLINE←COUNT←0;
DO GETBLK UNTIL TYPEWD=2;
SYMO←GETCHAN;
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;INTEGER ITYP);
⊂
STRING FILN; INTEGER ETWAS;
BEOF←0; ENTPNT←ETWAS←0;
IF DELETING THEN ⊂ "DEL FAIL"
LOOKUP(BINI,F&".FAI",I);
IF I=0 THEN BEGIN
RENAME (BINI,"",0,I);
OUTSTR((IF I THEN "RENAME DIFFICULTY WITH " ELSE NULL)&
F&(IF I THEN ".FAI " ELSE ".FAI DELETED "));END;
CLOSE (BINI);
ETWAS←TRUE;
⊃ "DEL FAIL";
IF ITYP NEQ 0 THEN FILN←"SAH"&F[4 TO INF]&".REL" ELSE
FILN←F&".REL";
IF EQU(F,"SAIHED") THEN
LIBHED(FILN)
ELSE IF DOLIB THEN ⊂ "COP FIL"
LOOKUP (BINI,FILN,I);
IF ¬I THEN OUTSTR( "COPYING "&FILN) ELSE
OUTSTR ("MISSING "&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*19+17)/18);
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,BRKCHR); IF BRKCHR≠DELIM THEN
DO LINE1←INPUT(DSKI,COMDEL) UNTIL BRKCHR=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]) AND (BITS[C] LAND DOITBIT) THEN ⊂
IF BITS[C] LAND GOGBIT THEN GOGDO←TRUE;
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;
DSKI←GETCHAN;
OPEN(DSKI,"DSK",1,2,0,400,BRKCHR,EOF);
DSKO←GETCHAN;
OPEN(DSKO,"DSK",1,0,2,00,W,W);
BINI←GETCHAN;
OPEN(BINI,"DSK",'10,4,0,400,BRKCHR,BEOF);
BINO←GETCHAN;
OPEN(BINO,"DSK",'10,0,4,00,W,W);
COMO←GETCHAN;
OPEN(COMO,"DSK",1,0,2,00,W,W);
FUNI←GETCHAN;
OPEN (FUNI,"DSK",0,0,0,I,I,I);
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");
GASLIB←EACHASK←WILLTELL←GOGDO←RENTLIB←WANTNOHDR←FALSE;
BTHLIB←DELETING←DOLIB←DOHEAD←DOEXTR←DOFAIL←INTFIL←TRUE;
IFC TYMSWC THENC IF RPGSW THEN BEGIN
OPEN (RPGCHL←GETCHAN,"DSK",'14,1,0,RPGEOF,RPGEOF,RPGEOF);
LOOKUP (RPGCHL,("000"&CVS(CALL(0,"PJOB")))[INF-2 FOR 3]&
"SCI.TMP",RPGEOF);
IF RPGEOF=0 THEN BEGIN
TYMSW←WORDIN(RPGCHL); CMUSW←WORDIN(RPGCHL);
STANSW←WORDIN(RPGCHL); RENTLIB←WORDIN(RPGCHL);
EACHASK←WORDIN(RPGCHL); WILLTELL←WORDIN(RPGCHL);
DELETING←WORDIN(RPGCHL); DOLIB←WORDIN(RPGCHL);
GASLIB←WORDIN(RPGCHL); BTHLIB←WORDIN(RPGCHL) END END;
IF NOT RPGSW OR RPGEOF NEQ 0 THEN BEGIN ENDC
OUTSTR("SITE ID (<CR> OK FOR "&IFC TYMSWC THENC "TYMSHARE"
ELSEC "SU-AI" ENDC &") = ");
SITEID←INCHWL;
STANSW←TYMSW←CMUSW←0;
IF EQU(SITEID,"SU-AI") THEN STANSW←1;
IF EQU(SITEID,"TYMSHARE") THEN TYMSW←1;
IF EQU(SITEID,"CMU") THEN CMUSW←1;
IF LENGTH(SITEID=0) THEN IFC TYMSWC THENC TYMSW ELSEC STANSW ENDC←1;
IF TYMSW THEN DELETING←FALSE;
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)
9 MAKE LOW SEG LIBRARY
10 DO DELETE INTERMEDIATE FILES (PASS 2)
" ELSE "
4 MAKE A RE-ENTRANT LIBRARY
5 SELECT ENTRIES FROM PROMPT-LIST
6 SPECIFY ENTRIES EXPLICITLY
7 DON'T DELETE INTERMEDIATE FILES
8 DON'T MAKE A LIBRARY
9 MAKE LOW SEG LIBRARY
10 DO DELETE INTERMEDIATE FILES
");
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 LOW SEG LIBRARY
10 DO DELETE INTERMEDIATE FILE (PASS 2)
11 MAKE GAS LIBRARY (IMPLIES REENTRANT)
" ELSE "
4 MAKE A RE-ENTRANT LIBRARY
5 SELECT ENTRIES FROM PROMPT-LIST
6 SPECIFY ENTRIES EXPLICITLY
7 DON'T DELETE INTERMEDIATE FILES
8 DON'T MAKE A LIBRARY
9 MAKE LOW SEG LIBRARY
10 DO DELETE INTERMEDIATE FILES
11 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 11 OF ⊂
[1] ⊂
RPGSW←TRUE; FROMPASS1←TRUE
⊃;
[2] DOFAIL←FALSE;
[3] INTFIL←FALSE;
[4] RENTLIB←TRUE;
[5] EACHASK←TRUE;
[6] WILLTELL←TRUE;
[7] DELETING←FALSE;
[8] DOLIB←FALSE;
[9] BTHLIB←FALSE;
[10] DELETING←TRUE;
[11] IF NOT CMUSW THEN GO TO TOOBIG ELSE
RENTLIB←GASLIB←TRUE;
[10]
⊃ ELSE
CASE (CASE ANSCODE MIN 12 OF (0,0,0,0,3,4,5,1,2,6,7,8,9)) OF ⊂
[1] DELETING←FALSE;
[2] DOLIB←FALSE;
[3] RENTLIB←TRUE;
[4] EACHASK←TRUE;
[5] WILLTELL←TRUE;
[6] BTHLIB←FALSE;
[7] DELETING←TRUE;
[8] IF NOT CMUSW THEN GO TO TOOBIG ELSE RENTLIB←GASLIB←TRUE;
[9]
TOOBIG:OUTSTR(CVS(ANSCODE)&" TOO BIG -- IGNORED"&('15&'12))
⊃;
⊃;
⊃ "ASK";
IFC TYMSWC THENC END;
IF NOT RPGSW THEN BEGIN
OPEN (RPGCHL←GETCHAN,"DSK",'14,0,1,RPGEOF,RPGEOF,RPGEOF);
ENTER(RPGCHL,("000"&CVS(CALL (0,"PJOB")))[INF-2 FOR 3]&
"SCI.TMP",RPGEOF);
WORDOUT(RPGCHL,TYMSW);WORDOUT(RPGCHL,CMUSW); WORDOUT(RPGCHL,STANSW);
WORDOUT(RPGCHL,RENTLIB);WORDOUT(RPGCHL,EACHASK);WORDOUT(RPGCHL,WILLTELL);
WORDOUT(RPGCHL,DELETING);WORDOUT(RPGCHL,DOLIB);WORDOUT(RPGCHL,GASLIB);
WORDOUT(RPGCHL,BTHLIB); RELEASE(RPGCHL) END; ENDC;
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 IF EQU("FAI",GGGG) THEN EXTR←0 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 ⊂
KLUGE(I);
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 ⊂
KLUGE(I);
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);
IF I=0 THEN BEGIN
RENAME (BINI,"",0,I);
IF I THEN TYPE "RENAME DIFFICULTY WITH HDRFIL" EOM
ELSE TYPE "HDRFIL DELETED" EOM; END;
CLOSE (BINI);
IF RENTLIB OR BTHLIB 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)
⊃
⊃;
IF DOLIB THEN FOR IQ←IF GASLIB THEN 2 ELSE IF RENTLIB THEN 1
ELSE 0 STEP 1 UNTIL IF GASLIB THEN 2 ELSE IF RENTLIB
OR BTHLIB THEN 1 ELSE 0 DO BEGIN
I←0;
ENTER (BINO,(GASNAM←CASE IQ OF (LIBNAM,HLBNAM,GASNAM)),I);
IF I THEN ⊂
TYPE "CAN'T ENTER "&GASNAM EOM; GO ENDER
⊃;
FOR COMNO←1 STEP 1 UNTIL MAXTHS DO IF BITS[COMNO] LAND DOITBIT THEN
LIBMAK (ORDER[COMNO],IQ);
CLOSE (BINO); COMMENT THIS IS THE LIBRARY;
END;
IF DOLIB THEN ⊂
TYPE "RUN CARMEL ON YOUR NEW LIBRARY(S)!" 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;
COMMENT Check creation date of HDRFIL.FUN to see if we need a new one;
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;
⊃;
⊃;
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 LOR KLUGEBIT) THEN DOEXTR←TRUE;
IF BITS[COMNO] LAND HEADBIT THEN DOHEAD←TRUE;
IF RENTLIB OR BTHLIB THEN OUT (COMO,"SAH"&ORDER[COMNO]
[4 TO INF]&"/R←SAIREN.FAI,"&FILES[COMNO]&CRLF);
IF NOT RENTLIB THEN OUT(COMO,ORDER[COMNO]&"/R←"&
FILES[COMNO]&CRLF);
TYPE ORDER[COMNO]&" WILL BE ASSEMBLED" EOM
⊃;
OUT(COMO,"DSK:SCISS!"&CRLF);
CLOSE(COMO); CLOSE(DSKO);
IF RENTLIB OR BTHLIB 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);
⊃;
BAIL;
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";