@CAT,P UUSIG*1100-001-001.,F///500 @ELT,IQ UUSIG*1100-001-001.GEN/4R4,,,,COB COPY ProgId IN UCS-PROC REPLACING P1 BY Gen. / ***************************************************************** * Gen Program Description * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Gen is a UCOB program that reads other COBOL programs, * * decides how to precompile and/or compile them, then reads * * compiler-generated object code (relocatable or object module) * * and decides how to @MAP or @LINK it. Along the way, it * * enforces SBA programming standards about where COPY procs * * ought to come from, where subprogram object code ought to * * come from, minimum DBank addresses, what database to map in, * * how detailed the listing print file must be, etc, etc, etc. * * * * Gen executes as a ZOOM system processor. The user types the * * @GEN line and Gen does the rest, almost always without * * bothering the user with a lot of questions that the user * * doesn't necessarily know how to answer correctly anyway. * * * * The keys to its acceptance have been its utter mindlessness, * * its dynamic nature and its stability. So, therefore, whoso- * * ever puts in a new change "must answer me these questions 3": * * * * (1) Am I being lazy, asking for input from the user * * when I ought to be able to figure it out myself * * with a little extra work? * * * * (2) Am I being lazy, defining a static table of programs * * and their characteristics to derive some information * * that I ought to be able to figure out myself * * dynamically with a little extra work? * * * * (3) Have I tested all logic paths (and there are boat- * * loads of them) before releasing this new feature? * * * ***************************************************************** ***************************************************************** * Acknowledged Kludges * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 1) UserUcobKeywords allows temporary ad hoc solutions to * * unforseen situations. It should not be used liberally * * and/or when a cleaner solution is available. For example,* * use @GEN,M rather than coding the MONITOR keyword. * * * * 2) UserDirs also allow temporary ad hoc solutions to * * unforseen situations. They are needed less often, now * * that GENDIR can read Object Modules. * * * ***************************************************************** / ***************************************************************** * REVISION HISTORY * ***************************************************************** * * * ------------------------F O R M A T-------------------------- * * CHANGE CHANGE CHANGED RMIS * * NUMBER DATE BY NUMBER DESCRIPTION OF CHANGE * * ------ ------ ------------- ------ ------------------------- * * CH-NNN MMDDYY FMLLLLLLLLLLL NNNNNN XXXXXXXXXXXXXXXXXXXXXXXXX * * ------------------------------------------------------------- * * 123093 SRSeaquist 940026 Initial Implementation * ***************************************************************** ***************************************************************** * Gen's Compile/Map ECL: * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * @GEN,RL File.Gen * * * * Since Gen often has to be regenned in conjunction with its * * subprograms, a special add element called GEN/GEN exists to * * allow genning them in sync with one another: * * * * @SETC ## * * @ADD,L S.Gen/Gen * * * * where ## is an octal number identifying which modules to gen. * * Read Gen/Gen to see which bits currently gen which programs. * * Of course, Gen/Gen uses @GEN to gen Gen and its subprograms. * * It assumes that you have attached the usename of S to the * * file containing the source code. * * * * There's an older version of Gen/Gen called Gen-Manually/Gen * * that calls @UCOB and @LINK directly, so that a bug in Gen * * won't hinder you in genning the fix. It can also be used * * when you install Gen for the very first time at a site * * (because Gen/Gen uses @GEN to gen Gen). * * * * Both addstreams copy the output zoom into S., so that it can * * tested as @S.GEN before installation as @GEN. There is also * * a test addstream (@ADD,L S.Test/Gen). * ***************************************************************** / INPUT-OUTPUT SECTION. FILE-CONTROL. SELECT AddFile ASSIGN TO DISC 'Add$.Add$'. COPY GenApp-Select IN UCS-PROC. SELECT CardFile ASSIGN TO CARD-READER. SELECT EditsFile ASSIGN TO DISC 'Edits$.Add$'. I-O-CONTROL. APPLY EXREF ON GenProdLibs. DATA DIVISION. FILE SECTION. FD AddFile BLOCK CONTAINS 1792 CHARACTERS LABEL RECORDS ARE STANDARD. 01 AddRec PIC X(80). COPY GenApp-Fd IN UCS-PROC. FD CardFile BLOCK CONTAINS 1792 CHARACTERS LABEL RECORDS ARE STANDARD. 01 CardRec PIC X(80). FD EditsFile BLOCK CONTAINS 1792 CHARACTERS LABEL RECORDS ARE STANDARD. 01 EditsRec PIC X(80). WORKING-STORAGE SECTION. * System COPY Procs are S-OFF'd: S-OFF COPY UcsGeneral-Ws IN UCS-PROC. 01 StartOfGensDBank PIC X(04). COPY Convert-Octal-Ws IN UCS-PROC. COPY ErAcsf-Ws IN UCS-PROC. COPY ErFitem-Ws IN UCS-PROC. COPY ErIo-Ws IN UCS-PROC REPLACING Io-Buf-Words BY 1792. COPY ErSnap-Ws IN UCS-PROC. COPY FP-Chg-Elt IN UCS-PROC REPLACING Interface-Level BY FP-Chg-Elt-Interface-Level Work-Area-Size BY FP-Chg-Elt-Work-Area-Size Elt-Name BY FP-Chg-Elt-Elt-Name Elt-Version BY FP-Chg-Elt-Elt-Version . COPY FP-Defs IN UCS-PROC. COPY FP-Errors IN UCS-PROC. COPY FP-File-Id IN UCS-PROC REPLACING Interface-Level BY FP-File-Id-Interface-Level Directory-Id BY FP-File-Id-Directory-Id Filename BY FP-File-Id-Filename Qualifier BY FP-File-Id-Qualifier . COPY FP-Rtn-Elt-Info-Short IN UCS-PROC REPLACING Elt-Array-Size BY 1. COPY Loc-Ws IN UCS-PROC. COPY PrePro-Ws IN UCS-PROC REPLACING Max BY 4. COPY Sdf-Constants-Ws IN UCS-PROC. COPY Sdf-Packet-Ws IN UCS-PROC. COPY Sdf-Record-Ws IN UCS-PROC. COPY Toc-Constants-Ws IN UCS-PROC. COPY Toc-Packet-Ws IN UCS-PROC. COPY Toc-Record-Ws IN UCS-PROC. COPY UcsInitReg-Ws IN UCS-PROC. SLIST / 01 BreakdownCobLine. 05 CC-01-06 PIC X(06). 05 Indicator-Area PIC X(01). 05 CobLine. 10 Area-A PIC X(04). 10 Area-B PIC X(61). 05 CC-73-80 PIC X(08). 01 ConvertNameAscii PIC X(12). 01 ConvertNameFd PIC X(08). / 01 Counters-Etc. 05 EltRelatedInfo. 10 EltFlags. 15 FlagCallsComp PIC 1(06) BINARY-1 VALUE 0. 15 FlagCallsOldDPS PIC 1(06) BINARY-1 VALUE 0. 15 FlagCallsPads PIC 1(06) BINARY-1 VALUE 0. 15 FlagCallsRdmr PIC 1(06) BINARY-1 VALUE 0. 15 FlagCompiler PIC 1(06) BINARY-1 VALUE 0. 15 FlagDivision PIC 1(06) BINARY-1 VALUE 0. 15 FlagEmbeddedSQL PIC 1(06) BINARY-1 VALUE 0. 15 FlagIgnoreThisn PIC 1(06) BINARY-1 VALUE 0. 15 FlagInvokeSeen PIC 1(06) BINARY-1 VALUE 0. 15 FlagLitState PIC 1(06) BINARY-1 VALUE 0. 15 FlagRemState PIC 1(06) BINARY-1 VALUE 0. 15 FlagNonTrivial PIC 1(06) BINARY-1 VALUE 0. 15 FlagProgIdIsBad PIC 1(06) BINARY-1 VALUE 0. 15 FlagPrtdAcob PIC 1(06) BINARY-1 VALUE 0. 15 FlagPrtdOvLibs PIC 1(06) BINARY-1 VALUE 0. 15 FlagPrtdUcob PIC 1(06) BINARY-1 VALUE 0. 15 FlagSir PIC 1(06) BINARY-1 VALUE 0. 15 FlagThisIsSubr PIC 1(06) BINARY-1 VALUE 0. 15 FlagUsesAlter PIC 1(06) BINARY-1 VALUE 0. 15 FlagUsesCol7 PIC 1(06) BINARY-1 VALUE 0. 15 FlagUsesCol7AU PIC 1(06) BINARY-1 VALUE 0. 15 FlagUsesCol7PT PIC 1(06) BINARY-1 VALUE 0. 15 FlagUsesDateTim PIC 1(06) BINARY-1 VALUE 0. 15 FlagUsesGoTo PIC 1(06) BINARY-1 VALUE 0. 15 FlagUsesMcFlag PIC 1(06) BINARY-1 VALUE 0. 15 FlagUsesMonitor PIC 1(06) BINARY-1 VALUE 0. 15 FlagUsesNote PIC 1(06) BINARY-1 VALUE 0. 15 FlagUsesSOff PIC 1(06) BINARY-1 VALUE 0. 15 PIC 1(12) BINARY-1 VALUE 0. 10 LineCtr PIC 1(18) BINARY-1 VALUE 0. 10 PrevStringPtr PIC 1(09) BINARY-1 VALUE 0. 10 PrevUnstringPtr PIC 1(09) BINARY-1 VALUE 0. 10 PrevToken PIC X(32) VALUE LOW-VALUES. 10 Tok1A PIC X(30) VALUE LOW-VALUES. 10 Tok1U PIC X(30) VALUE LOW-VALUES. 10 TokenCtr PIC 1(36) BINARY-1 VALUE 0. 10 TokenCtrRedefined REDEFINES TokenCtr. 15 TokenCtrDiv512 PIC 1(27). 15 TokenCtrMod512 PIC 1(09). 10 UserInfo. 15 UserDirCtr PIC 1(09) VALUE 0. 15 UserDirIdx PIC 1(09) VALUE 0. Odd #! 15 UserDir OCCURS 5 PIC X(66) VALUE LOW-VALUES. 15 UserUcobKeywords PIC X(68) VALUE LOW-VALUES. /01 Counters-Etc, continued: 05 FileRelatedInfo. 10 EltInCtr PIC 1(18) BINARY-1 VALUE 0. 10 EltOutCtr PIC 1(18) BINARY-1 VALUE 0. 10 FileFlags. 15 FlagMassCompile PIC 1(06) BINARY-1 VALUE 0. 15 FlagSelfIsCatd PIC 1(06) BINARY-1 VALUE 0. 15 PIC 1(24) BINARY-1 VALUE 0. 10 LineTot PIC 1(36) BINARY-1 VALUE 0. 10 TokenTot PIC 1(36) BINARY-1 VALUE 0. 05 Loop-Control. 10 i PIC 1(18) BINARY-1. 10 j PIC 1(18) BINARY-1. 10 k PIC 1(18) BINARY-1. 10 l PIC 1(18) BINARY-1. 05 String-Control. 10 StringDelim PIC X(01). 10 StringPtr PIC 1(09) BINARY-1. 05 Tally PIC 1(18). 05 Unstring-Control. 10 UnstringDelim PIC X(01). 10 UnstringPtr PIC 1(09) BINARY-1. 01 Dummy PIC S1(36) VALUE +0. / 01 Gen-Constants. 05 Gen-Con-Compiler-Related. 10 Gen-Con-Cmp-Unknown PIC 1(06) BINARY-1 VALUE 0. 10 Gen-Con-Cmp-Acob PIC 1(06) BINARY-1 VALUE 1. 10 Gen-Con-Cmp-Ucob PIC 1(06) BINARY-1 VALUE 2. 05 Gen-Con-Div-Related. 10 Gen-Con-Div-Pre-Id PIC 1(06) BINARY-1 VALUE 0. 10 Gen-Con-Div-Id PIC 1(06) BINARY-1 VALUE 1. 10 Gen-Con-Div-Env PIC 1(06) BINARY-1 VALUE 2. 10 Gen-Con-Div-Data PIC 1(06) BINARY-1 VALUE 3. 10 Gen-Con-Div-Proc PIC 1(06) BINARY-1 VALUE 4. 05 Gen-Con-Lit-Related. 10 Gen-Con-NotInLit PIC 1(06) BINARY-1 VALUE 0. 10 Gen-Con-BegLit PIC 1(06) BINARY-1 VALUE 1. 10 Gen-Con-InLit PIC 1(06) BINARY-1 VALUE 2. 10 Gen-Con-EndLit PIC 1(06) BINARY-1 VALUE 3. 05 Gen-Con-Rem-Related. 10 Gen-Con-NotInRem PIC 1(06) BINARY-1 VALUE 0. 10 Gen-Con-InRem PIC 1(06) BINARY-1 VALUE 1. 05 Gen-Con-Tbl-Sizes. Odd #! 10 Gen-Con-UserDirMax PIC 1(09) BINARY-1 VALUE 5. 10 PIC 1(09) BINARY-1 VALUE 0. 05 Gen-Con-True PIC 1(18) BINARY-1 VALUE 4060. 05 Gen-Version PIC X(03) VALUE '4.4'. 05 Gen-xRx PIC X(03) VALUE '4R4'. 05 GenDir-Version PIC X(03) VALUE '1.4'. 05 GenDir-xRx PIC X(03) VALUE '1R4'. 05 Indent PIC X(04) VALUE SPACES. COPY GenApp-Ws IN UCS-PROC. / 01 Hold-Names. * Whenever any of these names disturb word-alignment, they * occur in adjacent pairs that restore word-alignment. 05 Disp-Image PIC X(80) VALUE SPACES. 05 NameAppGroup PIC X(12) VALUE SPACES. 05 NameAppGroupIn PIC X(12) VALUE SPACES. 05 NameAppGroupSql PIC X(12) VALUE SPACES. 05 NameBrkpt PIC X(12) VALUE SPACES. 05 NameCompilerInput PIC X(60) VALUE SPACES. 05 NameCompilerOutput PIC X(60) VALUE SPACES. 05 NameCopyProc PIC X(32) VALUE SPACES. 05 NameDBankMin PIC X(08) VALUE SPACES. pair 05 NameEditorFullScreen PIC X(10) VALUE '@QED,RL'. pair 05 NameEditorUnisys PIC X(10) VALUE '@ED,QR'. pair 05 NameEditorUnisysCopy PIC X(10) VALUE '@ED,QN'. pair 05 NameEditorUnisysInput PIC X(10) VALUE '@ED,IQ'. 05 NameEltIn PIC X(12) VALUE SPACES. pair 05 NameEltGenDir PIC X(06) VALUE 'GenDir'. pair 05 NameEltGenDirUC PIC X(06) VALUE 'GENDIR'. 05 NameEltOut PIC X(12) VALUE SPACES. pair 05 NameEltSelf PIC X(06) VALUE 'Gen'. pair 05 NameEltSelfUC PIC X(26). 05 NameEltSubr PIC X(12) VALUE SPACES. 05 NameEltSysdta PIC X(12) VALUE SPACES. 05 NameEltVerAbs PIC X(28) VALUE SPACES. 05 NameEltVerIn PIC X(28) VALUE SPACES. 05 NameEltVerInSysdta PIC X(28) VALUE SPACES. 05 NameEltVerOut PIC X(28) VALUE SPACES. 05 NameEltVerRel PIC X(28) VALUE SPACES. 05 NameEntry PIC X(12) VALUE SPACES. 05 NameEntryCB PIC X(12) VALUE SPACES. 05 NameFCyc PIC X(04) VALUE SPACES. 05 NameFile PIC X(12) VALUE SPACES. 05 NameFileIn PIC X(12) VALUE SPACES. 05 NameGenSignon PIC X(80) VALUE SPACES. 05 NameProgId PIC X(32) VALUE SPACES. 05 NameQual PIC X(12) VALUE SPACES. 05 NameQualFile PIC X(28) VALUE SPACES. 05 NameQualFileEcl PIC X(28) VALUE SPACES. 05 NameQualFileGenApp PIC X(28) VALUE SPACES. 05 NameQualFileIn PIC X(28) VALUE SPACES. 05 NameQualFileOut PIC X(28) VALUE SPACES. 05 NameQualFileSelf PIC X(28) VALUE SPACES. 05 NameQualFileSelfOnly PIC X(28) VALUE SPACES. 05 NameQualFileSelfProd PIC X(12) VALUE 'SYS$LIB$*SBA'. 05 NameQualIn PIC X(12) VALUE SPACES. 05 NameSchemaFile PIC X(12) VALUE SPACES. 05 NameSourceIn PIC X(60) VALUE SPACES. 05 NameSrcOrObj PIC X(16) VALUE SPACES. 05 NameSubschema PIC X(12) VALUE SPACES. 05 NameVerIn PIC X(12) VALUE SPACES. 05 NameVerInOrig PIC X(12) VALUE SPACES. 05 NameVerOut PIC X(12) VALUE SPACES. 05 NameVerRel PIC X(12) VALUE SPACES. 05 NameXRef PIC X(12) VALUE SPACES. 05 Token PIC X(32) VALUE SPACES. / 01 OldCalls. 05 PIC 1(18) VALUE 0. 05 OldCallMax PIC 1(18) VALUE 62. 05 PIC X(20) VALUE 'CALLPAGING OLDDPS'. 05 PIC X(20) VALUE 'CCDTAC COMPOOL'. 05 PIC X(20) VALUE 'CCDTCR COMPOOL'. 05 PIC X(20) VALUE 'CCSTLG COMPOOL'. 05 PIC X(20) VALUE 'CCSTOV COMPOOL'. 05 PIC X(20) VALUE 'CHANGEPID OLDDPS'. 05 PIC X(20) VALUE 'CINIT COMPOOL'. 05 PIC X(20) VALUE 'CLEARCONV OLDDPS'. 05 PIC X(20) VALUE 'CLOSE OLDDPS'. 05 PIC X(20) VALUE 'CRELOG COMPOOL'. 05 PIC X(20) VALUE 'CRTOTP COMPOOL'. 05 PIC X(20) VALUE 'CRTRNO COMPOOL'. 05 PIC X(20) VALUE 'CRTRNU COMPOOL'. 05 PIC X(20) VALUE 'CRTSCH COMPOOL'. 05 PIC X(20) VALUE 'CTRMN8 COMPOOL'. 05 PIC X(20) VALUE 'DPSABORT OLDDPS'. 05 PIC X(20) VALUE 'DPSDUMP OLDDPS'. 05 PIC X(20) VALUE 'ENDMESSAGE OLDDPS'. 05 PIC X(20) VALUE 'ENDPAGING OLDDPS'. 05 PIC X(20) VALUE 'ERRMSG OLDDPS'. 05 PIC X(20) VALUE 'FIELDERROR OLDDPS'. 05 PIC X(20) VALUE 'FINISH OLDDPS'. 05 PIC X(20) VALUE 'GETFIELD OLDDPS'. 05 PIC X(20) VALUE 'GETINPUT OLDDPS'. 05 PIC X(20) VALUE 'GETLINE OLDDPS'. 05 PIC X(20) VALUE 'GETRESET OLDDPS'. 05 PIC X(20) VALUE 'GETSCRATCH OLDDPS'. 05 PIC X(20) VALUE 'GETSCREEN OLDDPS'. 05 PIC X(20) VALUE 'GETTERMINAL OLDDPS'. 05 PIC X(20) VALUE 'GETTRACE OLDDPS'. 05 PIC X(20) VALUE 'GETUSERFLDS OLDDPS'. 05 PIC X(20) VALUE 'GETWS OLDDPS'. 05 PIC X(20) VALUE 'INITIALIZE OLDDPS'. 05 PIC X(20) VALUE 'INITIALIZE1 OLDDPS'. 05 PIC X(20) VALUE 'LOGOFF OLDDPS'. 05 PIC X(20) VALUE 'OPENSCREEN OLDDPS'. 05 PIC X(20) VALUE 'PAGESTATUS OLDDPS'. 05 PIC X(20) VALUE 'PASSOFF OLDDPS'. 05 PIC X(20) VALUE 'PGETSCRATCH OLDDPS'. 05 PIC X(20) VALUE 'PPUTSCRATCH OLDDPS'. 05 PIC X(20) VALUE 'PUTSCRATCH OLDDPS'. 05 PIC X(20) VALUE 'PUTSCREEN OLDDPS'. 05 PIC X(20) VALUE 'PUTUSERFLDS OLDDPS'. 05 PIC X(20) VALUE 'READ OLDDPS'. 05 PIC X(20) VALUE 'RELEASE OLDDPS'. 05 PIC X(20) VALUE 'RETRIEVE OLDDPS'. 05 PIC X(20) VALUE 'SCREENGET OLDDPS'. 05 PIC X(20) VALUE 'SCREENRESET OLDDPS'. 05 PIC X(20) VALUE 'SEND OLDDPS'. 05 PIC X(20) VALUE 'SENDBELL OLDDPS'. 05 PIC X(20) VALUE 'SENDERROR OLDDPS'. 05 PIC X(20) VALUE 'SENDFRAME OLDDPS'. 05 PIC X(20) VALUE 'SETBELL OLDDPS'. 05 PIC X(20) VALUE 'SETCONV OLDDPS'. 05 PIC X(20) VALUE 'SETPAGING OLDDPS'. 05 PIC X(20) VALUE 'SETTERMINAL OLDDPS'. 05 PIC X(20) VALUE 'SETTRX OLDDPS'. 05 PIC X(20) VALUE 'STORE OLDDPS'. 05 PIC X(20) VALUE 'STOREINDEX OLDDPS'. 05 PIC X(20) VALUE 'TERMINATE OLDDPS'. 05 PIC X(20) VALUE 'USERERROR OLDDPS'. 05 PIC X(20) VALUE 'USERMESSAGE OLDDPS'. 01 REDEFINES OldCalls. 05 PIC 1(36). 05 OldCallTbl OCCURS 62 ASCENDING KEY OldCallName INDEXED BY OldCallIdx, OldCallIdx2. 10 OldCallName PIC X(12). 10 PIC X(01). 10 OldCallType PIC X(07). / 01 Hold-Opts. 05 Gen-Opts PIC X(28) VALUE SPACES. 05 Gen-Opts-All PIC X(28) VALUE SPACES. 05 Processor-Opts. 10 Acob-Opts. 15 Acob-Opt-Copy PIC X(01). 15 Acob-Opt-NoMoni PIC X(01). 15 Acob-Opt-Source PIC X(01). 15 Acob-Opt-Subr PIC X(01). 15 Acob-Opt-XRef PIC X(01). 10 Acob-Extra-Opts. 15 Acob-Opt-Debug PIC X(01). 15 Acob-Opt-Float PIC X(01). 15 Acob-Opt-Syntax PIC X(01). 15 Acob-Opt-Table PIC X(01). 10 Dcd-Opts. 15 Dcd-Opt-Admlpd PIC X(01). 10 Ucob-Opts. 15 Ucob-Opt-Copy PIC X(12). 15 Ucob-Opt-Debug PIC X(12). 15 Ucob-Opt-Moni PIC X(08). 15 Ucob-Opt-Optim PIC X(12). 15 Ucob-Opt-Source PIC X(08). 15 Ucob-Opt-Syntax PIC X(08). 15 Ucob-Opt-Subr PIC X(12). 15 Ucob-Opt-XRef PIC X(08). / 01 Opt-Txts. 05 A-Txt PIC X(01) VALUE 'A'. 05 B-Txt PIC X(01) VALUE 'B'. 05 C-Txt PIC X(01) VALUE 'C'. 05 D-Txt PIC X(01) VALUE 'D'. 05 E-Txt PIC X(01) VALUE 'E'. 05 F-Txt PIC X(01) VALUE 'F'. 05 G-Txt PIC X(01) VALUE 'G'. 05 H-Txt PIC X(01) VALUE 'H'. 05 I-Txt PIC X(01) VALUE 'I'. 05 J-Txt PIC X(01) VALUE 'J'. 05 K-Txt PIC X(01) VALUE 'K'. 05 L-Txt PIC X(01) VALUE 'L'. 05 M-Txt PIC X(01) VALUE 'M'. 05 N-Txt PIC X(01) VALUE 'N'. 05 O-Txt PIC X(01) VALUE 'O'. 05 P-Txt PIC X(01) VALUE 'P'. 05 Q-Txt PIC X(01) VALUE 'Q'. 05 R-Txt PIC X(01) VALUE 'R'. 05 S-Txt PIC X(01) VALUE 'S'. 05 T-Txt PIC X(01) VALUE 'T'. 05 U-Txt PIC X(01) VALUE 'U'. 05 V-Txt PIC X(01) VALUE 'V'. 05 W-Txt PIC X(01) VALUE 'W'. 05 X-Txt PIC X(01) VALUE 'X'. 05 Y-Txt PIC X(01) VALUE 'Y'. 05 Z-Txt PIC X(01) VALUE 'Z'. 01 REDEFINES Opt-Txts. 05 Opt-Txt OCCURS 26 PIC X(01). / * Besides allowing logical options that are independent of the * actual GEN option used, this table also expands the flags to * to 6th-word boundaries, for efficient access. 01 OptsLogical. 05 OptAcob PIC 1(06). 05 OptAdmlpSourceListing PIC 1(06). 05 OptCompFile PIC 1(06). 05 OptDCD PIC 1(06). 05 OptErrorDetection PIC 1(06). 05 OptFloatingPointCompute PIC 1(06). 05 OptHelp PIC 1(06). 05 OptLongListings PIC 1(06). 05 OptMonitor PIC 1(06). 05 OptNoListings PIC 1(06). 05 OptProd PIC 1(06). 05 OptFullScreenEditor PIC 1(06). 05 OptReleaseGen PIC 1(06). 05 OptSyntaxOnly PIC 1(06). 05 OptTest PIC 1(06). 05 OptUcob PIC 1(06). 05 OptSubprogram PIC 1(06). 05 OptDontAddAddElement PIC 1(06). 05 OptDontMapReentrantTip PIC 1(06). 05 OptSmallBusAdminBranch3 PIC 1(06). 01 OptsLogical-Txts. 05 OptAcob-Txt PIC X(01). 05 OptLongListings-Txt PIC X(01). 05 OptMonitor-Txt PIC X(01). 05 OptNoListings-Txt PIC X(01). 05 OptUcob-Txt PIC X(01). / 01 Pics. 05 Pic9 PIC 9. 05 Pic99 PIC 99. 05 Pic999 PIC 999. 05 Pic9999 PIC 9999. 05 Pic99999 PIC 99999. 05 Pic999999 PIC 999999. 05 PicPara PIC X(05). 05 PIC X(01). 05 PicX06 PIC X(06). 05 PicX12 PIC X(12). 05 PicZ9 PIC Z9. 05 PicZz9 PIC ZZ9. 05 PicZzz9 PIC ZZZ9. 05 PicZzzz9 PIC ZZZZ9. 05 PicZzzzz9 PIC ZZZZZ9. 05 PicZCzz9 PIC Z,ZZ9. 05 PicZzCzz9 PIC ZZ,ZZ9. 05 PicZzzCzz9 PIC ZZZ,ZZ9. 05 PicZCzzzCzz9 PIC Z,ZZZ,ZZ9. 05 PicZzCzzzCzz9 PIC ZZ,ZZZ,ZZ9. 05 PicZzzCzzzCzz9 PIC ZZZ,ZZZ,ZZ9. 05 PicZCzzzCzzzCzz9 PIC Z,ZZZ,ZZZ,ZZ9. 01 PicDateDisplay. 05 PicDate. 10 PicMM PIC 9(02). 10 PIC X(01) VALUE '/'. 10 PicDD PIC 9(02). 10 PIC X(01) VALUE '/'. 10 PicYY PIC 9(02). 10 PIC X(01) VALUE ' '. 05 PicTime. 10 PicHH PIC 9(02). 10 PIC X(01) VALUE ':'. 10 PicMins PIC 9(02). 10 PIC X(01) VALUE ':'. 10 PicSS PIC 9(02). 01 PicDateGenUsed PIC X(17) VALUE SPACES. 01 PicDateGenVersion PIC X(17) VALUE SPACES. 01 PicDateSystem. 05 PicCC PIC 9(02). 05 PicDate. 10 PicYY PIC 9(02). 10 PicMM PIC 9(02). 10 PicDD PIC 9(02). 05 PicTime. 10 PicHH PIC 9(02). 10 PicMins PIC 9(02). 10 PicSS PIC 9(02). / 01 SCS-Table. 05 SCS-Hold-App PIC X(08) VALUE SPACES. 05 SCS-Hold-Name PIC X(24) VALUE ' '. 05 SCS-Hold-Val PIC X(66) VALUE ' '. 05 PIC X(02) VALUE ' '. 05 SCS-Char PIC 1(09) VALUE 0. 05 SCS-Found PIC 1(09) VALUE 0. 05 SCS-Max PIC 1(09) VALUE 30. 05 SCS-Nbr PIC 1(09) VALUE 0. 05 SCS-Tbl OCCURS 0 TO 30 TIMES DEPENDING ON SCS-Nbr INDEXED BY SCS-Idx. 10 SCS-Name PIC X(24) VALUE ' '. 10 SCS-Val PIC X(66) VALUE ' '. 10 SCS-ValQ PIC X(66) VALUE ' '. 01 TestLibs. 05 TestLibMax PIC 1(18) BINARY-1 VALUE 8. 05 TestLibNbr PIC 1(18) BINARY-1 VALUE 0. 05 TestLibText. 10 TestLibTbl OCCURS 8 INDEXED BY TestLibIdx. 15 TestLibUse PIC X(12) VALUE SPACES. 01 TestProcs. 05 TestProcMax PIC 1(18) BINARY-1 VALUE 30. 05 TestProcNbr PIC 1(18) BINARY-1 VALUE 0. 05 TestProcText. 10 TestProcTbl OCCURS 30 INDEXED BY TestProcIdx. 15 TestProcName PIC X(30) VALUE SPACES. / 01 TimeVars. 05 TimeBeg. 10 BegHH PIC 9(02). 10 BegMM PIC 9(02). 10 BegSS PIC 9(02). 10 BegHuns PIC 9(02). 05 TimeBegComp PIC 1(36) BINARY-1. 05 TimeDur. 10 DurHH PIC 9(02). 10 PIC X(01) VALUE ':'. 10 DurMM PIC 9(02). 10 PIC X(01) VALUE ':'. 10 DurSS PIC 9(02). 10 PIC X(01) VALUE '.'. 10 DurHuns PIC 9(02). 10 PIC X(01) VALUE ' '. 05 TimeDurComp PIC 1(36) BINARY-1. 05 TimeEnd. 10 EndHH PIC 9(02). 10 EndMM PIC 9(02). 10 EndSS PIC 9(02). 10 EndHuns PIC 9(02). 05 TimeEndComp PIC 1(36) BINARY-1. / 01 Tokens. 05 PIC 1(18) BINARY-1 VALUE 0. 05 PIC 1(18) BINARY-1 VALUE 92. 05 PIC X(32) VALUE 'ALPHABETIC-LOWER 18'. 05 PIC X(32) VALUE 'ALPHABETIC-UPPER 18'. 05 PIC X(32) VALUE 'ALPHANUMERIC 18'. 05 PIC X(32) VALUE 'ALTER 01'. 05 PIC X(32) VALUE 'BINARY 20'. 05 PIC X(32) VALUE 'BINARY-1 20'. 05 PIC X(32) VALUE 'CLASS 18'. 05 PIC X(32) VALUE 'CLASS-NAME 19'. 05 PIC X(32) VALUE 'COMP-4 19'. 05 PIC X(32) VALUE 'COMPUTATIONAL-4 19'. 05 PIC X(32) VALUE 'CONTENT 18'. 05 PIC X(32) VALUE 'CONTINUE 18'. 05 PIC X(32) VALUE 'CONVERTING 18'. 05 PIC X(32) VALUE 'COPY 02'. 05 PIC X(32) VALUE 'DATA 03'. 05 PIC X(32) VALUE 'DATE-TIME 04'. 05 PIC X(32) VALUE 'DAY-OF-WEEK 18'. 05 PIC X(32) VALUE 'DISP-1 19'. 05 PIC X(32) VALUE 'DISP-2 20'. 05 PIC X(32) VALUE 'DISPLAY-1 19'. 05 PIC X(32) VALUE 'DISPLAY-2 20'. 05 PIC X(32) VALUE 'END-ADD 18'. 05 PIC X(32) VALUE 'END-CALL 18'. 05 PIC X(32) VALUE 'END-COMPUTE 18'. 05 PIC X(32) VALUE 'END-DELETE 18'. 05 PIC X(32) VALUE 'END-DIVIDE 18'. 05 PIC X(32) VALUE 'END-EVALUATE 18'. 05 PIC X(32) VALUE 'END-EXEC 20'. 05 PIC X(32) VALUE 'END-IF 18'. 05 PIC X(32) VALUE 'END-MULTIPLY 18'. 05 PIC X(32) VALUE 'END-PERFORM 18'. 05 PIC X(32) VALUE 'END-READ 18'. 05 PIC X(32) VALUE 'END-RECEIVE 18'. 05 PIC X(32) VALUE 'END-RETURN 18'. 05 PIC X(32) VALUE 'END-REWRITE 18'. 05 PIC X(32) VALUE 'END-SEARCH 18'. 05 PIC X(32) VALUE 'END-START 18'. 05 PIC X(32) VALUE 'END-STRING 18'. 05 PIC X(32) VALUE 'END-SUBTRACT 18'. 05 PIC X(32) VALUE 'END-UNSTRING 18'. 05 PIC X(32) VALUE 'END-WRITE 18'. 05 PIC X(32) VALUE 'ENVIRONMENT 05'. 05 PIC X(32) VALUE 'EQUALS 19'. 05 PIC X(32) VALUE 'EVALUATE 18'. 05 PIC X(32) VALUE 'EXAMINE 19'. 05 PIC X(32) VALUE 'EXCEEDS 19'. 05 PIC X(32) VALUE 'EXEC 20'. 05 PIC X(32) VALUE 'EXHIBIT 19'. 05 PIC X(32) VALUE 'EXTERNAL 20'. 05 PIC X(32) VALUE 'FALSE 20'. 05 PIC X(32) VALUE 'FUNCTION 18'. 05 PIC X(32) VALUE 'GLOBAL 20'. 05 PIC X(32) VALUE 'GO 06'. 05 PIC X(32) VALUE 'ID 07'. 05 PIC X(32) VALUE 'IDENTIFICATION 07'. 05 PIC X(32) VALUE 'INITIALIZE 18'. 05 PIC X(32) VALUE 'INVOKE 08'. 05 PIC X(32) VALUE 'LINKAGE 09'. 05 PIC X(32) VALUE 'MASS-STORAGE 19'. 05 PIC X(32) VALUE 'MASS-STORAGE-123 19'. 05 PIC X(32) VALUE 'MASS-STORAGE-28 19'. 05 PIC X(32) VALUE 'MASS-STORAGE-56 19'. 05 PIC X(32) VALUE 'MCFLAG 10'. 05 PIC X(32) VALUE 'MODE-1 20'. 05 PIC X(32) VALUE 'MODE-2 20'. 05 PIC X(32) VALUE 'MODE-3 20'. 05 PIC X(32) VALUE 'MODE-4 20'. 05 PIC X(32) VALUE 'MONITOR 11'. 05 PIC X(32) VALUE 'NOTE 12'. 05 PIC X(32) VALUE 'NUMERIC-EDITED 20'. 05 PIC X(32) VALUE 'OBJECT-COMPUTER 17'. 05 PIC X(32) VALUE 'ORDER 20'. 05 PIC X(32) VALUE 'OTHER 18'. 05 PIC X(32) VALUE 'PACKED-DECIMAL 20'. 05 PIC X(32) VALUE 'PADDING 20'. 05 PIC X(32) VALUE 'PROCEDURE 13'. 05 PIC X(32) VALUE 'PROGRAM-ID 14'. 05 PIC X(32) VALUE 'PURGE 20'. 05 PIC X(32) VALUE 'REFERENCE 18'. 05 PIC X(32) VALUE 'REMARKS 15'. 05 PIC X(32) VALUE 'REPLACE 20'. 05 PIC X(32) VALUE 'SEQUENTIAL-FILE 19'. 05 PIC X(32) VALUE 'SOURCE-COMPUTER 17'. 05 PIC X(32) VALUE 'SQL 16'. 05 PIC X(32) VALUE 'STANDARD-2 20'. 05 PIC X(32) VALUE 'TEST 18'. 05 PIC X(32) VALUE 'THEN 18'. 05 PIC X(32) VALUE 'TRANSFORM 19'. 05 PIC X(32) VALUE 'TRUE 20'. 05 PIC X(32) VALUE 'UNEQUAL 19'. 05 PIC X(32) VALUE 'UNISERVO 19'. 05 PIC X(32) VALUE 'UNISERVOS 19'. 01 REDEFINES Tokens. 05 PIC 1(18) BINARY-1. 05 TokenMax PIC 1(18) BINARY-1. 05 TokenTbl OCCURS 92 TIMES ASCENDING KEY IS TokenName INDEXED BY TokenIdx. 10 TokenName PIC X(30). 10 TokenGoToDepOnVal PIC 9(02). / 01 VerifyTables. 05 TableIsAscending PIC 1(18) BINARY-1. 05 VerifyIdx PIC 1(18) BINARY-1. 05 VerifyPrev PIC X(32). 01 EndOfGensDBank PIC 1(36). * APPLY EXREF items aren't really in our DBank. They reside * in separate compilation-units. They are defined here so that * we can use them. It's sorta like LINKAGE, only not really. * * Steve Seaquist * 04/29/93 01 GenProdLibs. 05 ProdLibAsc PIC 1(06) BINARY-1. 05 ProdLibAts PIC 1(06) BINARY-1. 05 ProdLibCpf PIC 1(06) BINARY-1. 05 ProdLibDuo PIC 1(06) BINARY-1. 05 ProdLibMax PIC 1(06) BINARY-1. 05 ProdLibUcs PIC 1(06) BINARY-1. 05 ProdLibTbl OCCURS 1 TO 999 TIMES DEPENDING ON ProdLibMax ASCENDING KEY IS ProdLibUse INDEXED BY ProdLibIdx. 10 ProdLibUse PIC X(12). 10 ProdLibFile PIC X(24). 10 ProdLibOverride PIC 1(18) BINARY-1. 10 ProdLibRel PIC 1(18) BINARY-1. 10 ProdLibSeen PIC 1(18) BINARY-1. 10 ProdLibWeAsgdIt PIC 1(18) BINARY-1. / PROCEDURE DIVISION. 0000-Main-Section SECTION. 0000-Main. COPY UcsInitReg-Pd IN UCS-PROC. COPY PrePrm-Pd IN UCS-PROC. IF (NbrETs > 0) MOVE EltSlashVer (1) TO NameEltSelfUC. PERFORM 0010-MapPhysicalOptsToLogical. (temp)* The following is a violation of SBA programming standards, (temp)* but it was requested by a branch chief: (temp) (temp) IF (OptSmallBusAdminBranch3 > 0) (temp) MOVE 'MSP*DSPF' TO ProdLibFile (ProdLibAsc), (temp) ProdLibFile (ProdLibAts), (temp) ProdLibFile (ProdLibCpf). PERFORM 0020-Blank-Out-Unused-Opts. PERFORM 0030-Build-Gen-Opts. MOVE Gen-Opts TO Gen-Opts-All. MOVE ' ' TO A-Txt, U-Txt, Gen-Opts. PERFORM 0030-Build-Gen-Opts. /0000-Main, continued: MOVE FUNCTION WHEN-COMPILED TO PicDateSystem. MOVE CORRESPONDING PicDateSystem TO PicDateDisplay. MOVE PicDateDisplay TO PicDateGenVersion. ACCEPT PicDate OF PicDateSystem FROM DATE. ACCEPT PicTime OF PicDateSystem FROM TIME. MOVE CORRESPONDING PicDateSystem TO PicDateDisplay. MOVE PicDateDisplay TO PicDateGenUsed. MOVE SPACES TO NameGenSignon. STRING NameEltSelfUC DELIMITED BY ' ' ' (COBOL Gen Util ' Gen-Version ', created ' PicDateGenVersion ', used ' PicDateGenUsed ')' DELIMITED BY SIZE INTO NameGenSignon. DISPLAY NameGenSignon UPON Prtr-Out. (temp) DISPLAY 'GEN 4.4 allows embedded SQL pgms to use TCOMP/QCOMP' (temp) ' SchemaFiles (if also DML) ' UPON Prtr-Out. (temp) DISPLAY ' fixes non-versioned UCOB main programs call' (temp) 'ing versioned subprograms. ' UPON Prtr-Out. /0000-Main, continued: MOVE '@USE Ecl$.,My*Ecl$. . ' TO Acsf-Image. PERFORM 8030-ErAcsf. CALL 'AscFd' USING 4 'Ecl$' 12 Fitem-Pkt Dummy. PERFORM 8050-ErFitem. (asgd) IF (Fitem-Equip-Code > 0) (temp) AND (Fitem-Temporary > 0) PERFORM 8130-Get-QualFile ELSE MOVE '@USE Ecl$.,GenUtil*Ecl$. . ' TO Acsf-Image PERFORM 8030-ErAcsf MOVE '@ASG,A Ecl$. . ' TO Acsf-Image PERFORM 8030-ErAcsf PERFORM 8130-Get-QualFile MOVE '@FREE,R Ecl$. . ' TO Acsf-Image PERFORM 8030-ErAcsf . MOVE NameQualFile TO NameQualFileEcl. IF (OptHelp > 0) PERFORM 0040-Help-Mode ELSE PERFORM 0050-Init-ProdLibs PERFORM 0060-Process-Spec-Fields. COPY PostPr-Pd IN UCS-PROC. PERFORM 9000-Terminate. STOP RUN. / 0010-MapPhysicalOptsToLogical. * The following allows us to change the meanings of option * option letters very easily. At sites other than SBA, * this mapping also allows easily tailoring GEN to a site's * needs. For example, the I-Option could be mapped to the * fullscreen editor option if the site uses IPF. MOVE A-Opt TO OptAcob. MOVE 'A' TO OptAcob-Txt. MOVE B-Opt TO OptAdmlpSourceListing. MOVE C-Opt TO OptCompFile. MOVE D-Opt TO OptDCD. MOVE E-Opt TO OptErrorDetection. MOVE F-Opt TO OptFloatingPointCompute. MOVE H-Opt TO OptHelp. MOVE L-Opt TO OptLongListings. MOVE 'L' TO OptLongListings-Txt. MOVE M-Opt TO OptMonitor. MOVE 'M' TO OptMonitor-Txt. MOVE N-Opt TO OptNoListings. MOVE 'N' TO OptNoListings-Txt. MOVE P-Opt TO OptProd. MOVE Q-Opt TO OptFullScreenEditor. MOVE R-Opt TO OptReleaseGen. MOVE S-Opt TO OptSyntaxOnly. MOVE T-Opt TO OptTest. MOVE U-Opt TO OptUcob. MOVE 'U' TO OptUcob-Txt. MOVE V-Opt TO OptSubprogram. MOVE X-Opt TO OptDontAddAddElement. MOVE Y-Opt TO OptDontMapReentrantTip. MOVE Z-Opt TO OptSmallBusAdminBranch3. / 0020-Blank-Out-Unused-Opts. PERFORM VARYING i FROM 1 BY 1 UNTIL i > 26 IF (Partbl-Opt (i) = 0) MOVE ' ' TO Opt-Txt (i) END-IF END-PERFORM. 0030-Build-Gen-Opts. MOVE 0 TO j. PERFORM VARYING i FROM 1 BY 1 UNTIL i > 26 IF (Opt-Txt (i) NOT = ' ') ADD 1 TO j MOVE Opt-Txt (i) TO Gen-Opts (j:1) END-IF END-PERFORM. / 0040-Help-Mode. DISPLAY 'Help Mode.' UPON Prtr-Out. IF (OptLongListings > 0) PERFORM 0041-Help-Extensively ELSE PERFORM 0042-Help-Briefly. 0041-Help-Extensively. * Since the users never see images processed by ErAcsf, * we can go ahead and use the usename ECL$. Images that * use NameQualFileEcl are generally doing so in Add$.Add$, * where we prefer for filenames to be explicit. MOVE '@ADD,L ECL$.Addelt/GenDoc' TO Acsf-Image. PERFORM 8030-ErAcsf. 0042-Help-Briefly. * On a standard UTS terminal screen, we have room for only 20: DISPLAY 'A - ACOB (forced)' UPON Prtr-Out. DISPLAY 'B - "Before" line nbrs (@ADMLP,S)' UPON Prtr-Out. DISPLAY 'C - "COMP" databases during compile' UPON Prtr-Out. DISPLAY 'D - DCD inline source xref for ACOB' UPON Prtr-Out. DISPLAY 'E - Error handling' UPON Prtr-Out. DISPLAY 'F - Floating-point in COMPUTEs' UPON Prtr-Out. DISPLAY 'H - Help (@GEN,HL = users manuals)' UPON Prtr-Out. DISPLAY 'L - Long listings, long @DOWN if release gen' UPON Prtr-Out. DISPLAY 'M - Monitor' UPON Prtr-Out. DISPLAY 'N - No listings, no @DOWN if release gen' UPON Prtr-Out. DISPLAY 'P - ********* PRODUCTION DEVELOPMENT GEN - If DB, ' 'gen to QUERY, else simple gen' UPON Prtr-Out. DISPLAY 'Q - Q/EDitor to view brkpt file' UPON Prtr-Out. DISPLAY 'R - ********* RELEASE GEN - stds enforced, ' 'DOWN, short gen TEST, long gen QUERY' UPON Prtr-Out. DISPLAY 'S - Syntax only compile, no map/link' UPON Prtr-Out. DISPLAY 'T - *Default* TEST DEVELOPMENT GEN - If DB, ' 'gen to TEST, else simple gen' UPON Prtr-Out. DISPLAY 'U - UCOB (forced)' UPON Prtr-Out. DISPLAY 'V - Subprogram (forced)' UPON Prtr-Out. DISPLAY 'X - Don''t @ADD Add$.Add$' UPON Prtr-Out. DISPLAY 'Y - Non-reentrant map (for TIP only)' UPON Prtr-Out. DISPLAY 'Z - (special option, Branch 3 only)' UPON Prtr-Out. / 0050-Init-ProdLibs. CALL 'AscFd' USING 6 'TmpUse' 12 Fitem-Pkt Dummy. PERFORM VARYING ProdLibIdx FROM 1 BY 1 UNTIL ProdLibIdx > ProdLibMax MOVE SPACES TO Acsf-Image STRING '@USE TmpUse.,My*' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO Acsf-Image PERFORM 8030-ErAcsf PERFORM 8050-ErFitem (asgd) IF (Fitem-Equip-Code > 0) (temp) AND (Fitem-Temporary > 0) PERFORM 0051-Init-ProdLib END-IF END-PERFORM. MOVE '@FREE,A TmpUse.' TO Acsf-Image. PERFORM 8040-ErAcsf-AllowFacReject. 0051-Init-ProdLib. IF (ProdLibIdx = ProdLibAsc) MOVE Gen-Con-True TO ProdLibOverride (ProdLibCpf) ELSE IF (ProdLibIdx = ProdLibCpf OR ProdLibDuo) DISPLAY 'Do not use MY*COB$PF to override COB$PF' UPON Prtr-Out DISPLAY 'Use MY*ASC-PROC instead.' UPON Prtr-Out PERFORM 9010-Terminate-In-Error STOP RUN . MOVE Gen-Con-True TO ProdLibOverride (ProdLibIdx). / 0060-Process-Spec-Fields. CALL 'AscFd' USING 7 'CsInt$$' 12 Fitem-Pkt Dummy. PERFORM 8130-Get-QualFile. MOVE NameQualFile TO NameQualFileSelf. UNSTRING NameQualFile DELIMITED BY '(' INTO NameQualFileSelfOnly. IF (Fitem-Temporary = 0) MOVE 1 TO FlagSelfIsCatd. CALL 'AscFd' USING 4 'SI$$' 12 Fitem-Pkt Dummy. PERFORM 8130-Get-QualFile. MOVE NameQualFile TO NameQualFileIn. MOVE NameQual TO NameQualIn. MOVE NameFile TO NameFileIn. * GenApp-Pd must be PERFORM'd after establishing * NameQualFileEcl and NameQualFileIn: PERFORM GenApp-Pd. CALL 'AscFd' USING 4 'RO$$' 12 Fitem-Pkt Dummy. PERFORM 8130-Get-QualFile. MOVE NameQualFile TO NameQualFileOut. PERFORM 8110-Get-EltVerOut. Gen IF (Fitem-Needs-Write-Key > 0) keepa OR (Fitem-Write-Inhibited > 0) rollin PERFORM 0061-Warn-Output-To-Temp. PERFORM 1000-Compile. 0061-Warn-Output-To-Temp. Gen DISPLAY NameQualFileOut 'is write-inhibited' UPON Prtr-Out. keepa DISPLAY 'Absolutes will go to the temporary file "Out.".' rollin UPON Prtr-Out. all night MOVE '@ASG,T Out.,F///9999' TO Acsf-Image. long. PERFORM 8030-ErAcsf. MOVE 'Out(0)' TO NameQualFileOut. / 1000-Compile. IF (0 < OptDontAddAddElement AND OptLongListings) PERFORM 8160-Verify-CmpTables. MOVE '@ASG,T Add$.,F///262143' TO Acsf-Image. PERFORM 8030-ErAcsf. OPEN OUTPUT AddFile. IF (FlagSelfIsCatd > 0) AND (NameQualFileSelfOnly NOT = NameQualFileSelfProd) MOVE '@FREE,AR CsInt$$.' TO AddRec WRITE AddRec. IF (Init-Brkptd > 0) AND (Init-Demand) MOVE '@BRKPT PRINT$' TO AddRec WRITE AddRec. MOVE Si-Int-Filename TO Toc-Pkt-Int-Filename. MOVE Si-Toc-Record TO Toc-Record. IF (Toc-Rec-EltName = SPACES OR LOW-VALUES OR ALL '@') AND (Toc-Rec-VerName = SPACES OR LOW-VALUES OR ALL '@') MOVE 1 TO FlagMassCompile PERFORM 1001-Get-TimeBeg PERFORM 1010-Mass-Compile PERFORM 1002-Get-TimeEnd MOVE EltInCtr TO PicZzzCzz9 DISPLAY Indent 'in ' PicZzzCzz9 ' COB(s)' UPON Prtr-Out ELSE PERFORM 1001-Get-TimeBeg PERFORM 1020-Single-Compile PERFORM 1002-Get-TimeEnd . CLOSE AddFile. IF (OptDontAddAddElement > 0) DISPLAY 'No dynamic @ADD, as requested.' UPON Prtr-Out DISPLAY 'Gen ECL is in Add$.Add$' UPON Prtr-Out PERFORM 1003-List-SCSs ELSE IF (EltOutCtr = 0) DISPLAY 'Nothing found, nothing genned.' UPON Prtr-Out ELSE MOVE '@ADD,L Add$.Add$' TO Acsf-Image PERFORM 8030-ErAcsf . / 1001-Get-TimeBeg. ACCEPT TimeBeg FROM TIME. COMPUTE TimeBegComp = (BegHH * 360000) + (BegMM * 6000) + (BegSS * 100) + BegHuns. 1002-Get-TimeEnd. ACCEPT TimeEnd FROM TIME. COMPUTE TimeEndComp = (EndHH * 360000) + (EndMM * 6000) + (EndSS * 100) + EndHuns. Crossd IF (TimeEndComp < TimeBegComp) midnit ADD 86400000 TO TimeEndComp. COMPUTE TimeDurComp = TimeEndComp - TimeBegComp. DIVIDE TimeDurComp BY 360000 GIVING DurHH REMAINDER TimeDurComp. DIVIDE TimeDurComp BY 6000 GIVING DurMM REMAINDER TimeDurComp. DIVIDE TimeDurComp BY 100 GIVING DurSS REMAINDER DurHuns. MOVE LineTot TO PicZzzCzzzCzz9. MOVE TokenTot TO PicZCzzzCzzzCzz9. DISPLAY 'Gen took ' TimeDur 'to analyze ' PicZCzzzCzzzCzz9 ' tokens from ' PicZzzCzzzCzz9 ' lines' UPON Prtr-Out. 1003-List-SCSs. IF (SCS-Nbr > 0) DISPLAY 'Source Code Substitution Table:' UPON Prtr-Out PERFORM VARYING SCS-Idx FROM 1 BY 1 UNTIL SCS-Idx > SCS-Nbr MOVE SPACES TO Disp-Image STRING Indent DELIMITED BY SIZE SCS-Name (SCS-Idx) DELIMITED BY ' ' ' = "' DELIMITED BY SIZE SCS-Val (SCS-Idx) DELIMITED BY LOW-VALUE '"' DELIMITED BY SIZE INTO Disp-Image DISPLAY Disp-Image UPON Prtr-Out END-PERFORM. / 1010-Mass-Compile. DISPLAY 'No SI element name, assuming mass-compile mode:' UPON Prtr-Out. IF (NOT (NameEltVerOut = SPACES OR 'T' OR 'X')) DISPLAY 'RO element name ("' NameEltVerOut '") ignored in mass-compiles.' UPON Prtr-Out MOVE SPACES TO NameEltVerOut. PERFORM Toc-Acc-Open-Retr. IF (Toc-Pkt-Status = Toc-Con-NoErr) PERFORM 1011-Mass-Compile-Extra-Opens PERFORM Toc-Acc-Fetch-Frst PERFORM 1012-Mass-Compile-Loop UNTIL (Toc-Pkt-Status NOT = Toc-Con-Found) PERFORM 1013-Mass-Compile-Extra-Closes IF (Toc-Pkt-Status = Toc-Con-AtEnd) PERFORM Toc-Acc-Close IF (Toc-Pkt-Status = Toc-Con-NoErr) NEXT SENTENCE ELSE DISPLAY Toc-Pkt-Status-Text UPON Prtr-Out ELSE DISPLAY Toc-Pkt-Status-Text UPON Prtr-Out ELSE DISPLAY Toc-Pkt-Status-Text UPON Prtr-Out . 1011-Mass-Compile-Extra-Opens. MOVE '@ASG,T Edits$.,F///9999' TO Acsf-Image. PERFORM 8030-ErAcsf. OPEN OUTPUT EditsFile. / 1012-Mass-Compile-Loop. IF (Toc-Rec-Is-Sym AND Toc-Rec-Is-Cob) AND (Toc-Rec-DeleteFlag = 0) PERFORM 8100-Get-EltVerIn ADD 1 TO EltInCtr PERFORM 1050-Process-Cob. PERFORM Toc-Acc-Fetch-Next. 1013-Mass-Compile-Extra-Closes. MOVE '@CAT,P LstMassComp.,F2///9999' TO Acsf-Image. AlrCat PERFORM 8040-ErAcsf-AllowFacReject. CLOSE EditsFile. MOVE '@BRKPT PRINT$,LstMassComp.' TO AddRec. WRITE AddRec. MOVE '@ADD,L Edits$.Add$' TO AddRec. WRITE AddRec. MOVE '@BRKPT PRINT$' TO AddRec. WRITE AddRec. MOVE '@USE Lst.,LstMassComp.' TO AddRec. WRITE AddRec. MOVE '@ASG,A Lst.' TO AddRec. WRITE AddRec. IF (OptFullScreenEditor > 0) MOVE NameEditorFullScreen TO AddRec MOVE 'LstMassComp.' TO AddRec (11:) WRITE AddRec MOVE 'LEndMaps' TO AddRec WRITE AddRec ELSE MOVE NameEditorUnisys TO AddRec MOVE 'LstMassComp.' TO AddRec (11:) WRITE AddRec MOVE '@ADD Ecl$.AddElt/MassComp' TO AddRec WRITE AddRec . / 1020-Single-Compile. (sym) MOVE 1 TO Toc-Rec-Type. PERFORM 8100-Get-EltVerIn. PERFORM Toc-Acc-Fetch-By-Name. IF (Toc-Pkt-Status = Toc-Con-Found) PERFORM 1050-Process-Cob ELSE IF (Toc-Pkt-Status = Toc-Con-NotFound) PERFORM 1021-Couldnt-Find-Elt ELSE DISPLAY Toc-Pkt-Status-Text UPON Prtr-Out. 1021-Couldnt-Find-Elt. MOVE SPACES TO Disp-Image. STRING NameEltVerIn DELIMITED BY ' ' ' could not be found in file ' DELIMITED BY SIZE NameQualFileIn DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO Disp-Image. DISPLAY Disp-Image UPON Prtr-Out. / 1050-Process-Cob. DISPLAY 'Scanning ' NameEltVerIn UPON Prtr-Out. IF (NOT Toc-Rec-Is-Cob) DISPLAY Indent 'Elt not typed as COB' UPON Prtr-Out. IF (OptReleaseGen > 0) DISPLAY Indent 'Release gen' UPON Prtr-Out ELSE DISPLAY Indent 'Development gen' UPON Prtr-Out. PERFORM VARYING ProdLibIdx FROM 1 BY 1 UNTIL ProdLibIdx > ProdLibMax MOVE 0 TO ProdLibSeen (ProdLibIdx) ProdLibWeAsgdIt (ProdLibIdx) END-PERFORM. MOVE LOW-VALUES TO EltRelatedInfo. Preset IF (OptAcob > OptUcob) all MOVE Gen-Con-Cmp-Acob TO FlagCompiler flags DISPLAY Indent 'ACOB' UPON Prtr-Out whose ELSE IF (OptUcob > OptAcob) values MOVE Gen-Con-Cmp-Ucob TO FlagCompiler are DISPLAY Indent 'UCOB' UPON Prtr-Out. forced by gen IF (OptMonitor > 0) opts. MOVE 1 TO FlagUsesMonitor. MOVE SPACES TO NameSubschema, NameSchemaFile, Processor-Opts, TestLibText, TestProcText, Token. MOVE 0 TO TestLibNbr, TestProcNbr. MOVE Toc-Pkt-Int-Filename TO Sdf-Pkt-Int-Filename. MOVE Toc-Rec-TextAddr TO Sdf-Pkt-Sector-Addr. MOVE Toc-Rec-TextLen TO Sdf-Pkt-Sector-Limit. /1050-Compile, continued: PERFORM Sdf-Acc-Open-Input. PERFORM 8000-Check-Status-Sdf. PERFORM Sdf-Acc-Fetch-Frst. PERFORM 1200-Process-Sdf-Label. PERFORM 1100-Process-Token UNTIL (Sdf-Pkt-Status NOT = Sdf-Con-Found). IF (Sdf-Pkt-Status NOT = Sdf-Con-AtEnd) D PERFORM 8080-ErSnap DISPLAY Indent Sdf-Pkt-Status-Text UPON Prtr-Out. PERFORM 1051-Reset-DateTime-If-Release. DISPLAY Indent LineCtr ' lines.' UPON Prtr-Out. PERFORM Sdf-Acc-Close. PERFORM 8000-Check-Status-Sdf. IF (FlagCompiler = Gen-Con-Cmp-Unknown) MOVE Gen-Con-Cmp-Acob TO FlagCompiler DISPLAY Indent 'Can''t guess which compiler to use. ' 'Assuming ACOB.' UPON Prtr-Out. IF (FlagUsesMonitor > 0) IF (OptReleaseGen > 0) IF (FlagUsesMcFlag > 0) DISPLAY Indent 'Releasing MONITOR, be careful' UPON Prtr-Out ELSE DISPLAY Indent 'Releasing MONITOR without any ' 'MCFLAG in PD!!!' UPON Prtr-out ELSE IF (FlagCompiler = Gen-Con-Cmp-Acob) IF (FlagUsesMcFlag > 0) DISPLAY Indent 'MCFLAG in PD, so MONITOR ' 'starts with MCFLAG=0' UPON Prtr-Out ELSE DISPLAY Indent 'MCFLAG not in PD, so MONITOR ' 'starts with MCFLAG=1' UPON Prtr-Out. IF (FlagDivision = Gen-Con-Div-Pre-Id) DISPLAY Indent 'No Division headers!' UPON Prtr-Out DISPLAY Indent 'Assuming not COBOL!' UPON Prtr-Out ELSE IF (FlagIgnoreThisn = 0) ADD 1 TO EltOutCtr PERFORM 3000-Generate-CompileStream. / 1051-Reset-DateTime-If-Release. IF (FlagDivision > Gen-Con-Div-Pre-Id) AND (FlagIgnoreThisn = 0) AND (OptReleaseGen > 0) PERFORM 1052-Reset-DateTime. 1052-Reset-DateTime. MOVE LOW-VALUES TO FP-File-Id. MOVE FP-Interface-Level-1 TO FP-File-Id-Interface-Level. MOVE 'STD' TO FP-File-Id-Directory-Id. MOVE NameQualIn TO FP-File-Id-Qualifier. MOVE NameFileIn TO FP-File-Id-Filename. MOVE LOW-VALUES TO FP-Chg-Elt. MOVE FP-Interface-Level-1 TO FP-Chg-Elt-Interface-Level. MOVE 6000 TO FP-Chg-Elt-Work-Area-Size. MOVE NameEltIn TO FP-Chg-Elt-Elt-Name. MOVE NameVerIn TO FP-Chg-Elt-Elt-Version. MOVE 1 TO Sym-Type, Wait-On-Facilities, Chg-Omn-Sym-Subtype, Chg-Date-Time, Exclusive-Assign. MOVE FP-Elt-Subtype-Cob TO New-Omn-Sym-Subtype. COPY Call-FP-Chg-Elt-Short IN UCS-PROC. IF (None OF Error-Class) DISPLAY Indent 'Source date/time reset' UPON Prtr-Out ELSE DISPLAY Indent 'Source date/time NOT SET' UPON Prtr-Out. / 1100-Process-Token. IF (FlagLitState < Gen-Con-InLit) PERFORM 2000-Evaluate-Token THRU 2999-Exit. PERFORM 1110-Get-Token. 1110-Get-Token. MOVE SPACES TO Token. PERFORM 1111-Get-Token-Loop UNTIL (Token NOT = SPACES) OR (Sdf-Pkt-Status NOT = Sdf-Con-Found). 1111-Get-Token-Loop. IF (UnstringPtr > 65) PERFORM Sdf-Acc-Fetch-Next PERFORM 1210-Ignore-Trivia MOVE Gen-Con-NotInLit TO FlagLitState ELSE IF (FlagLitState = Gen-Con-BegLit) MOVE Gen-Con-InLit TO FlagLitState ELSE IF (FlagLitState = Gen-Con-EndLit) MOVE Gen-Con-NotInLit TO FlagLitState . IF (Sdf-Pkt-Status = Sdf-Con-Found) PERFORM 1112-Unstring. / 1112-Unstring. MOVE UnstringPtr TO PrevUnstringPtr. UNSTRING CobLine DELIMITED BY ALL ' ' OR '.' OR ',' OR '''' INTO Token DELIMITER IN UnstringDelim WITH POINTER UnstringPtr. IF (UnstringDelim = '''') EVALUATE FlagLitState WHEN Gen-Con-NotInLit MOVE Gen-Con-BegLit TO FlagLitState WHEN Gen-Con-InLit MOVE Gen-Con-EndLit TO FlagLitState IF (PrevToken = 'CALL') PERFORM 1113-NeedToDetectCertainCALLs END-IF WHEN OTHER DISPLAY Indent 'Literal evaluation failure' UPON Prtr-Out PERFORM 8020-Display-Sdf-Line END-EVALUATE. 1113-NeedToDetectCertainCALLs. IF (Token = 'ACOB$RDMR') MOVE 1 TO FlagCallsRdmr ELSE IF (Token = 'PADS$') MOVE 1 TO FlagCallsPads ELSE SEARCH ALL OldCallTbl Ignore* AT END Ignore* CONTINUE WHEN OldCallName (OldCallIdx) = Token SET OldCallIdx2 TO OldCallIdx PERFORM 1114-OldCall END-SEARCH. / 1114-OldCall. IF (OldCallType (OldCallIdx2) = 'COMPOOL') PERFORM 1115-CallsCompool ELSE IF (OldCallType (OldCallIdx2) = 'OLDDPS') PERFORM 1116-CallsOldDPS. 1115-CallsCompool. IF (FlagCallsComp = 0) DISPLAY Indent 'Uses COMPOOL primitives ' '(not UCOB compatible)' UPON Prtr-Out. MOVE 1 TO FlagCallsComp. 1116-CallsOldDPS. IF (FlagCallsOldDPS = 0) DISPLAY Indent 'Uses old DPS names ' '(not UCOB compatible)' UPON Prtr-Out. MOVE 1 TO FlagCallsOldDPS. / 1200-Process-Sdf-Label. IF (Sdf-Icw-Is-Ctrl > 0) AND (Sdf-Icw-Ctrl-Type = Sdf-Con-Label) IF (Sdf-Icw-Sdf-Type = Sdf-Con-TypeIsSir) MOVE 1 TO FlagSir Debug * DISPLAY Indent 'SIR$' UPON Prtr-Out Debug * ELSE Debug * DISPLAY Indent 'Not SIR$' UPON Prtr-Out END-IF ELSE DISPLAY Indent 'SDF Label not found' UPON Prtr-Out MOVE Sdf-Con-AtEnd TO Sdf-Pkt-Status. PERFORM 1210-Ignore-Trivia. 1210-Ignore-Trivia. MOVE 0 TO FlagNonTrivial. PERFORM 1211-Ignore-Trivia-Loop UNTIL (FlagNonTrivial > 0) OR (Sdf-Pkt-Status NOT = Sdf-Con-Found). / 1211-Ignore-Trivia-Loop. invis, IF (Sdf-Icw-Is-Ctrl > 0) del'd OR ((FlagSir > 0) AND (Sdf-Icw-Sir-Del-Cyc > 0)) PERFORM Sdf-Acc-Fetch-Next ELSE ADD 1 TO LineCtr, LineTot PERFORM 1212-Process-Cols-1-6 PERFORM 1213-Process-Cols-7-72. 1212-Process-Cols-1-6. IF (Sdf-Image (1:5) = 'S-OFF' OR 'SLIST') MOVE 1 TO FlagUsesSOff ELSE IF (Sdf-Image (1: 5) = '@UCOB') MOVE Sdf-Image (8:65) TO UserUcobKeywords ELSE IF (Sdf-Image (1: 7) = 'LINK: *') ADD 1 TO UserDirCtr IF (UserDirCtr > Gen-Con-UserDirMax) IF (UserDirCtr = Gen-Con-UserDirMax + 1) DISPLAY Indent 'Maximum "LINK:" lines (' Gen-Con-UserDirMax ') exceeded.' UPON Prtr-Out END-IF DISPLAY Indent '"LINK:" ignored: ' Sdf-Image (8:65) UPON Prtr-Out ELSE MOVE Sdf-Image (8:65) TO UserDir (UserDirCtr) . / 1213-Process-Cols-7-72. EVALUATE FUNCTION UPPER-CASE (Sdf-Image (7:1)) Keep WHEN '*' WHEN's PERFORM Sdf-Acc-Fetch-Next in order WHEN '/' of PERFORM Sdf-Acc-Fetch-Next how likely WHEN 'A' to be MOVE 1 TO FlagUsesCol7, FlagUsesCol7AU seen. IF (OptUcob = 0) More PERFORM 1214-NoComment effi- ELSE cient. PERFORM Sdf-Acc-Fetch-Next END-IF WHEN 'U' MOVE 1 TO FlagUsesCol7, FlagUsesCol7AU IF (OptUcob > 0) PERFORM 1214-NoComment ELSE PERFORM Sdf-Acc-Fetch-Next END-IF WHEN 'P' MOVE 1 TO FlagUsesCol7, FlagUsesCol7PT IF (OptProd + OptReleaseGen > 0) PERFORM 1214-NoComment ELSE PERFORM Sdf-Acc-Fetch-Next END-IF WHEN 'T' MOVE 1 TO FlagUsesCol7, FlagUsesCol7PT IF (OptProd + OptReleaseGen = 0) PERFORM 1214-NoComment ELSE PERFORM Sdf-Acc-Fetch-Next END-IF WHEN OTHER PERFORM 1214-NoComment. / 1214-NoComment. IF (Sdf-Image (8:65) = SPACES) PERFORM Sdf-Acc-Fetch-Next ELSE PERFORM 1215-NonTrivial. 1215-NonTrivial. MOVE 1 TO FlagNonTrivial. MOVE Sdf-Image TO BreakdownCobLine. MOVE FUNCTION UPPER-CASE (CobLine) TO CobLine. MOVE 1 TO UnstringPtr. / 2000-Evaluate-Token. ADD 1 TO TokenCtr, TokenTot. Debug * PERFORM 2001-Process-Token-Trace. IF (FlagRemState = Gen-Con-InRem) EVALUATE Token WHEN 'DATA' GO TO 2030-Process-Data WHEN 'ENVIRONMENT' GO TO 2050-Process-Env WHEN 'PROCEDURE' GO TO 2130-Process-Procedure ELSE SEARCH ALL TokenTbl WHEN TokenName (TokenIdx) = Token GO TO 2010-Process-Alter 2020-Process-Copy 2030-Process-Data 2040-Process-Date-Time 2050-Process-Env 2060-Process-Go 2070-Process-Id 2080-Process-Invoke 2090-Process-Linkage 2100-Process-McFlag 2110-Process-Monitor 2120-Process-Note 2130-Process-Procedure 2140-Process-ProgramId 2150-Process-Remarks 2160-Process-SQL 2170-Process-SrcOrObjComputer 2180-Process-UcobIfNotDD 2190-Set-Flag-To-Acob 2200-Set-Flag-To-Ucob DEPENDING ON TokenGoToDepOnVal (TokenIdx) . Substi GO TO 2500-See-If-SCS. / 2001-Process-Token-Trace. Debug * IF (TokenCtrMod512 = 0) Debug * DISPLAY Indent TokenCtr ' tokens' UPON Prtr-Out. MOVE SPACES TO Disp-Image. MOVE PrevUnstringPtr TO PicZ9. MOVE UnstringPtr TO PicZz9. STRING Indent 'Token = "' DELIMITED BY SIZE Token DELIMITED BY ' ' '", Delim = "' UnstringDelim '", PrevUnstringPtr = ' PicZ9 ', UnstringPtr = ' PicZz9 DELIMITED BY SIZE INTO Disp-Image. DISPLAY Disp-Image UPON Prtr-Out. / 2010-Process-Alter. MOVE 1 TO FlagUsesAlter. GO TO 2999-Exit. 2020-Process-Copy. PERFORM 1110-Get-Token. IF (Sdf-Pkt-Status = Sdf-Con-Found) MOVE Token TO NameCopyProc IF (Token (1:6) = 'PROGID') MOVE Gen-Con-NotInRem TO FlagRemState MOVE Gen-Con-Div-Env TO FlagDivision END-IF IF (UnstringDelim = '.') PERFORM 2025-Add-A-Ref-To-Cobpf ELSE PERFORM 1110-Get-Token IF (Sdf-Pkt-Status = Sdf-Con-Found) IF (Token = 'IN' OR 'OF') PERFORM 2021-Process-Lib ELSE IF (Token = 'REPLACING') OR ((Token = ' ') AND (UnstringDelim = '.')) PERFORM 2025-Add-A-Ref-To-Cobpf ELSE DISPLAY Indent 'Expected IN/OF, found ' Token UPON Prtr-Out PERFORM 8020-Display-Sdf-Line ELSE DISPLAY Indent 'EOF before IN/OF' UPON Prtr-Out ELSE DISPLAY Indent 'EOF in COPY before copy proc name' UPON Prtr-Out . GO TO 2999-Exit. /2020-Process-Copy, continued: * Everything on this page is PERFORM'd, so (unlike other 2000 * series paragraphs) there must not be any "GO TO 2999-Exit" * in any of these paragraphs! 2021-Process-Lib. PERFORM 1110-Get-Token. IF (Sdf-Pkt-Status = Sdf-Con-Found) SEARCH ALL ProdLibTbl AT END PERFORM 2022-Process-TestLib WHEN ProdLibUse (ProdLibIdx) = Token MOVE Gen-Con-True TO ProdLibSeen (ProdLibIdx) IF (ProdLibOverride (ProdLibIdx) = Gen-Con-True) Once AND (FlagPrtdOvLibs = 0) per MOVE 1 TO FlagPrtdOvLibs pgm. DISPLAY Indent 'Override libraries' UPON Prtr-Out END-IF . 2022-Process-TestLib. SET TestLibIdx TO 1. SEARCH TestLibTbl VARYING TestLibIdx AT END PERFORM 2023-Add-A-New-TestLib WHEN TestLibUse (TestLibIdx) = Token NEXT SENTENCE. PERFORM 2024-Add-A-New-TestProc. 2023-Add-A-New-TestLib. IF (TestLibNbr < TestLibMax) ADD 1 TO TestLibNbr MOVE Token TO TestLibUse (TestLibNbr). 2024-Add-A-New-TestProc. IF (TestProcNbr < TestProcMax) ADD 1 TO TestProcNbr MOVE NameCopyProc TO TestProcName (TestProcNbr) First IF (TestProcNbr = 1) time DISPLAY Indent 'Non-standard IN/OF libname(s)' thru. UPON Prtr-Out. 2025-Add-A-Ref-To-Cobpf. MOVE Gen-Con-True TO ProdLibSeen (ProdLibCpf). PERFORM 2024-Add-A-New-TestProc. / 2030-Process-Data. Area A IF (PrevUnstringPtr < 5) MOVE Gen-Con-NotInRem TO FlagRemState MOVE Gen-Con-Div-Data TO FlagDivision. GO TO 2999-Exit. 2040-Process-Date-Time. IF (FlagUsesDateTim = 0) DISPLAY Indent 'ACCEPTs from DATE-TIME' UPON Prtr-Out. MOVE 1 TO FlagUsesDateTim. GO TO 2190-Set-Flag-To-Acob. 2050-Process-Env. Area A IF (PrevUnstringPtr < 5) MOVE Gen-Con-NotInRem TO FlagRemState MOVE Gen-Con-Div-Env TO FlagDivision. GO TO 2999-Exit. 2060-Process-Go. MOVE 1 TO FlagUsesGoTo. GO TO 2999-Exit. 2070-Process-Id. Area A IF (PrevUnstringPtr < 5) MOVE Gen-Con-NotInRem TO FlagRemState MOVE Gen-Con-Div-Id TO FlagDivision. GO TO 2999-Exit. / 2080-Process-Invoke. IF (FlagInvokeSeen > 0) GO TO 2999-Exit. PERFORM 1110-Get-Token. IF (Sdf-Pkt-Status = Sdf-Con-Found) IF (Token = 'SUBSCHEMA') PERFORM 1110-Get-Token IF (Sdf-Pkt-Status = Sdf-Con-Found) GO TO 2081-Process-Invoke-Subschema ELSE NEXT SENTENCE ELSE IF (Token = 'ALL' OR 'FORM' OR 'RECORD' OR 'SELECT' OR 'TABLE' OR 'VIEW') GO TO 2200-Set-Flag-To-Ucob ELSE GO TO 2081-Process-Invoke-Subschema. DISPLAY Indent 'EOF in INVOKE before ' 'subschema name' UPON Prtr-Out. GO TO 2999-Exit. 2081-Process-Invoke-Subschema. MOVE 1 TO FlagInvokeSeen. MOVE Token TO NameSubschema. * (Fall-thru to 2082-Process-Invoke-File.) 2082-Process-Invoke-File. PERFORM 1110-Get-Token. IF (Sdf-Pkt-Status = Sdf-Con-Found) IF (Token = 'IN') Ignore GO TO 2082-Process-Invoke-File ELSE IF (Token = 'FILE') PERFORM 1110-Get-Token IF (Sdf-Pkt-Status = Sdf-Con-Found) MOVE Token TO NameSchemaFile DISPLAY Indent 'Database' Debug * ', using ' NameSubschema Debug * ' of ' NameSchemaFile UPON Prtr-Out GO TO 2999-Exit. DISPLAY Indent 'EOF or bad syntax in INVOKE before ' 'schema filename' UPON Prtr-Out. GO TO 2999-Exit. / 2090-Process-Linkage. Area A IF (PrevUnstringPtr < 5) DISPLAY Indent 'Subprogram' UPON Prtr-Out MOVE 1 TO FlagThisIsSubr. GO TO 2999-Exit. 2100-Process-McFlag. IF (FlagDivision = Gen-Con-Div-Proc) MOVE 1 TO FlagUsesMcFlag IF (0 = OptLongListings AND OptReleaseGen) DISPLAY Indent 'Development gen with MONITOR. ' 'Scan stops at first PD ref to MCFLAG.' UPON Prtr-Out PERFORM 2132-Process-Procedure-AtEnd. GO TO 2999-Exit. 2110-Process-Monitor. IF (FlagDivision = Gen-Con-Div-Proc) MOVE 1 TO FlagUsesMonitor. GO TO 2190-Set-Flag-To-Acob. 2120-Process-Note. DISPLAY Indent 'NOTE verb: chg to comments!' UPON Prtr-Out. MOVE 1 TO FlagUsesNote. GO TO 2190-Set-Flag-To-Acob. / 2130-Process-Procedure. Area A IF (PrevUnstringPtr < 5) PERFORM 2131-Process-Procedure. GO TO 2999-Exit. 2131-Process-Procedure. MOVE Gen-Con-NotInRem TO FlagRemState. MOVE Gen-Con-Div-Proc TO FlagDivision. IF (OptSubprogram > 0) AND (FlagThisIsSubr = 0) DISPLAY Indent 'Looks like a main program, but will be ' 'compiled as a subprogram.' UPON Prtr-Out. IF (0 = OptLongListings AND OptReleaseGen) IF (OptMonitor = 0) DISPLAY Indent 'Development gen without ' OptLongListings-Txt ' or ' OptMonitor-Txt ' ' 'Option. Scan stops at PROCEDURE DIVISION.' UPON Prtr-Out PERFORM 2132-Process-Procedure-AtEnd ELSE DISPLAY Indent 'Continuing scan into PROCEDURE ' 'DIVISION to see whether to set MCFLAG.' UPON Prtr-Out. 2132-Process-Procedure-AtEnd. MOVE Sdf-Con-AtEnd TO Sdf-Pkt-Status. Just PERFORM VARYING ProdLibIdx FROM 1 BY 1 in UNTIL ProdLibIdx > ProdLibMax case IF (ProdLibIdx NOT = ProdLibCpf) used MOVE Gen-Con-True TO ProdLibSeen (ProdLibIdx) later END-IF in PD. END-PERFORM. / 2140-Process-ProgramId. Area A IF (PrevUnstringPtr < 5) PERFORM 1110-Get-Token IF (Sdf-Pkt-Status = Sdf-Con-Found) MOVE Token TO NameProgId IF (NameProgId (1:12) NOT = NameEltIn) DISPLAY Indent 'Program-Id not same as elt name' UPON Prtr-Out MOVE 1 TO FlagProgIdIsBad END-IF ELSE DISPLAY Indent 'EOF in Program-Id para' UPON Prtr-Out. GO TO 2999-Exit. / 2150-Process-Remarks. Area A IF (PrevUnstringPtr < 5) AND (FlagDivision = Gen-Con-Div-Id) MOVE Gen-Con-InRem TO FlagRemState GO TO 2190-Set-Flag-To-Acob. GO TO 2999-Exit. 2160-Process-SQL. MOVE 1 TO FlagEmbeddedSQL. GO TO 2200-Set-Flag-To-Ucob. 2170-Process-SrcOrObjComputer. Area A IF (PrevUnstringPtr < 5) MOVE Token TO NameSrcOrObj PERFORM 1110-Get-Token IF (Sdf-Pkt-Status = Sdf-Con-Found) IF (Token = LOW-VALUES OR SPACES) PERFORM 1110-Get-Token IF (Sdf-Pkt-Status = Sdf-Con-Found) PERFORM 2172-Process-SrcOrObjImplName ELSE PERFORM 2171-Process-SrcOrObjEOF ELSE PERFORM 2172-Process-SrcOrObjImplName ELSE PERFORM 2171-Process-SrcOrObjEOF . GO TO 2999-Exit. 2171-Process-SrcOrObjEOF. DISPLAY Indent 'EOF in SOURCE- or OBJECT-COMPUTER paragraph' UPON Prtr-Out. 2172-Process-SrcOrObjImplName. IF (Token NOT = 'UNISYS-2200') DISPLAY Indent NameSrcOrObj 'should be UNISYS-2200' UPON Prtr-Out. 2180-Process-UcobIfNotDD. IF (FlagDivision NOT = Gen-Con-Div-Data) GO TO 2200-Set-Flag-To-Ucob. DISPLAY Indent 'UCOB reserved word used in Data Division: ' Token UPON Prtr-Out. GO TO 2999-Exit. / 2190-Set-Flag-To-Acob. IF (FlagCompiler = Gen-Con-Cmp-Unknown) DISPLAY Indent 'ACOB' UPON Prtr-Out MOVE Gen-Con-Cmp-Acob TO FlagCompiler MOVE Token TO Tok1A ELSE IF (FlagCompiler = Gen-Con-Cmp-Ucob) AND (OptAcob + OptUcob = 0) MOVE Token TO Tok1A PERFORM 2201-Abort-Cmp-Unresolvable . GO TO 2999-Exit. 2200-Set-Flag-To-Ucob. IF (FlagCompiler = Gen-Con-Cmp-Unknown) DISPLAY Indent 'UCOB' UPON Prtr-Out MOVE Gen-Con-Cmp-Ucob TO FlagCompiler MOVE Token TO Tok1U ELSE IF (FlagCompiler = Gen-Con-Cmp-Acob) AND (OptAcob + OptUcob = 0) MOVE Token TO Tok1U PERFORM 2201-Abort-Cmp-Unresolvable . GO TO 2999-Exit. 2201-Abort-Cmp-Unresolvable. DISPLAY Indent 'ACOB and UCOB syntax found!' UPON Prtr-Out. DISPLAY Indent '1st ACOB token: "' Tok1A '"' UPON Prtr-Out. DISPLAY Indent '1st UCOB token: "' Tok1U '"' UPON Prtr-Out. DISPLAY Indent 'Can''t decide which to use.' UPON Prtr-Out. DISPLAY Indent 'This pgm will not be genned.' UPON Prtr-Out. DISPLAY Indent 'Regen it using the ' OptAcob-Txt ' or ' OptUcob-Txt ' option.' UPON Prtr-Out. MOVE Sdf-Con-AtEnd TO Sdf-Pkt-Status. MOVE 1 TO FlagIgnoreThisn. / 2500-See-If-SCS. Short IF (Token (1:4) NOT = 'GEN-') cut GO TO 2999-Exit. MOVE 0 TO Tally. INSPECT Token TALLYING Tally FOR CHARACTERS BEFORE ' '. IF (Token (Tally - 3:4) = '-SUB') MOVE Token (5:Tally - 8) TO SCS-Hold-Name MOVE 0 TO SCS-Found SET SCS-Idx TO 1 SEARCH SCS-Tbl AT END PERFORM 2501-Add-A-SCS-Val WHEN SCS-Name (SCS-Idx) = SCS-Hold-Name SET SCS-Found TO SCS-Idx END-SEARCH IF (SCS-Found = 0) DISPLAY Indent 'Source Code Substitution table over' 'flow (> ' SCS-Max ')' UPON Prtr-Out. GO TO 2999-Exit. 2501-Add-A-SCS-Val. IF (SCS-Nbr < SCS-Max) ADD 1 TO SCS-Nbr MOVE SPACES TO SCS-Tbl (SCS-Nbr) MOVE SCS-Hold-Name TO SCS-Name (SCS-Nbr) IF (SCS-Hold-Name (1:4) = 'APP-') MOVE Token (9:Tally - 12) TO SCS-Hold-Name IF (OptCompFile > 0) MOVE GenAppQualTestComp TO SCS-Hold-App PERFORM 2502-Ask-SCS-Val-For-App MOVE SCS-Hold-Val TO SCS-Val (SCS-Idx) MOVE GenAppQualProdComp TO SCS-Hold-App PERFORM 2502-Ask-SCS-Val-For-App MOVE SCS-Hold-Val TO SCS-ValQ (SCS-Idx) ELSE MOVE GenAppQualTest TO SCS-Hold-App PERFORM 2502-Ask-SCS-Val-For-App MOVE SCS-Hold-Val TO SCS-Val (SCS-Idx) MOVE GenAppQualProd TO SCS-Hold-App PERFORM 2502-Ask-SCS-Val-For-App MOVE SCS-Hold-Val TO SCS-ValQ (SCS-Idx) ELSE MOVE LOW-VALUES TO SCS-Hold-App PERFORM 2504-Ask-SCS-Val MOVE SCS-Hold-Val TO SCS-Val (SCS-Idx) END-IF MOVE SCS-Nbr TO SCS-Found . /2500-See-If-SCS, continued: 2502-Ask-SCS-Val-For-App. IF (SCS-Hold-App (1:1) = 'T') IF (OptTest + OptReleaseGen > 0) OR (OptProd = 0) PERFORM 2503-Trim-Spaces-And-Ask END-IF ELSE IF (SCS-Hold-App (1:1) = 'Q') AND (OptProd + OptReleaseGen > 0) PERFORM 2503-Trim-Spaces-And-Ask. 2503-Trim-Spaces-And-Ask. MOVE 0 TO Tally. INSPECT SCS-Hold-App TALLYING Tally FOR CHARACTERS BEFORE ' '. MOVE LOW-VALUES TO SCS-Hold-App (Tally + 2:). PERFORM 2504-Ask-SCS-Val. 2504-Ask-SCS-Val. DISPLAY Indent 'Enter source code to be used as ' SCS-Hold-App SCS-Hold-Name UPON Prtr-Out. MOVE SPACES TO SCS-Hold-Val. ACCEPT SCS-Hold-Val FROM Card-In. Cob-68* INSPECT SCS-Hold-Val REPLACING TRAILING ' ' BY LOW-VALUES. PERFORM VARYING SCS-Char FROM 66 BY -1 UNTIL SCS-Char < 1 IF (SCS-Hold-Val (SCS-Char:1) = ' ') MOVE LOW-VALUE TO SCS-Hold-Val (SCS-Char:1) ELSE MOVE 1 TO SCS-Char END-IF END-PERFORM. IF (Init-Brkptd > 0) MOVE SPACES TO Disp-Image STRING Indent '"' DELIMITED BY SIZE SCS-Hold-Val DELIMITED BY LOW-VALUE '"' DELIMITED BY SIZE INTO Disp-Image DISPLAY Disp-Image UPON Prtr-Out. 2999-Exit. MOVE Token TO PrevToken. / 3000-Generate-CompileStream. Extrnl IF ((OptUcob > 0) OR (FlagCompiler = Gen-Con-Cmp-Ucob)) data AND (FlagDivision < Gen-Con-Div-Proc) tables MOVE 1 TO FlagThisIsSubr. IF (OptLongListings + OptReleaseGen = 0) MOVE '@ASG FreesAndAsgs.,F///9999' TO Acsf-Image PERFORM 8030-ErAcsf MOVE '@BRKPT PRINT$,FreesAndAsgs.' TO AddRec WRITE AddRec ELSE PERFORM 3001-Write-Brkpt-To-NameBrkpt. PERFORM 3010-Warnings. PERFORM 3020-Down-Release-Gens. PERFORM 3030-Assigns. IF (OptLongListings + OptReleaseGen = 0) MOVE '@BRKPT PRINT$' TO AddRec WRITE AddRec PERFORM 3001-Write-Brkpt-To-NameBrkpt. DCD IF (0 < OptDCD) w/o AND (0 = OptLongListings + OptProd + OptReleaseGen + OptTest) DMS: PERFORM 3050-Compile-No-AppGroup ELSE IF (NameSubschema NOT = SPACES) OR (FlagEmbeddedSQL > 0) OR (FlagUsesCol7PT > 0) PERFORM 3040-Compile-To-AppGroup ELSE PERFORM 3050-Compile-No-AppGroup. IF (OptLongListings + OptReleaseGen = 0) MOVE '@BRKPT PRINT$' TO AddRec WRITE AddRec MOVE '@ASG Frees.,F///9999' TO Acsf-Image PERFORM 8030-ErAcsf MOVE '@BRKPT PRINT$,Frees.' TO AddRec WRITE AddRec. PERFORM 3080-Frees. IF (FlagMassCompile = 0) OR (Init-Demand) MOVE '@BRKPT PRINT$' TO AddRec WRITE AddRec. PERFORM 3090-AutoEdit. / 3001-Write-Brkpt-To-NameBrkpt. MOVE SPACES TO NameBrkpt. STRING 'Lst' DELIMITED BY SIZE NameEltIn (1:9) DELIMITED BY ' ' INTO NameBrkpt. MOVE SPACES TO Acsf-Image. STRING '@CAT,P ' DELIMITED BY SIZE NameBrkpt DELIMITED BY ' ' '.,F2///9999' DELIMITED BY SIZE INTO Acsf-Image. PERFORM 8040-ErAcsf-AllowFacReject. * Note: Allowing a fac reject on the @CAT isn't as scary as * it may seem. We expect the file to already be cat'd * in a majority of cases (repeated genning). If it * ever proves necessary to test bits of Acsf-Status, * do so here and abort before the following @BRKPT. MOVE SPACES TO AddRec. STRING '@BRKPT PRINT$,' DELIMITED BY SIZE NameBrkpt DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO AddRec. WRITE AddRec. * Also note that using the "comma format" of @BRKPT causes the * Exec to do an auto-assign and auto-free, which relieves us * of the burdon to do so. PERFORM 3002-Top-O-The-Brkpt. / 3002-Top-O-The-Brkpt. MOVE '@MSG,N Genned by:' TO AddRec. WRITE AddRec. MOVE '@MSG,N @' TO AddRec. MOVE 12 TO StringPtr. STRING NameQualFileSelf DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltSelf DELIMITED BY ' ' INTO AddRec WITH POINTER StringPtr. IF (Gen-Opts-All NOT = ' ') STRING ',' DELIMITED BY SIZE Gen-Opts-All DELIMITED BY ' ' INTO AddRec WITH POINTER StringPtr. MOVE 50 TO StringPtr. STRING '; <-- ' Gen-Version ', ' PicDateGenVersion DELIMITED BY SIZE INTO AddRec WITH POINTER StringPtr. WRITE AddRec. MOVE SPACES TO AddRec. STRING ' ' DELIMITED BY SIZE NameQualFileIn DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltVerIn DELIMITED BY ' ' ',;' DELIMITED BY SIZE INTO AddRec. WRITE AddRec. MOVE SPACES TO AddRec. STRING ' ' DELIMITED BY SIZE NameQualFileOut DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltVerOut DELIMITED BY ' ' INTO AddRec. WRITE AddRec. /3002-Top-O-The-Brkpt, continued: MOVE '@SETC,N . Banner appears 1st page if symmed to F100P' TO AddRec. WRITE AddRec. IF (OptReleaseGen = 0) MOVE '@BANNER Development,Gen,' TO AddRec MOVE NameEltIn TO AddRec (27:) ELSE MOVE '@BANNER Release,Gen,' TO AddRec MOVE NameEltIn TO AddRec (23:). WRITE AddRec. MOVE '@SETC,P . Banner appears 1st page if symmed to F100P' TO AddRec. WRITE AddRec. / 3010-Warnings. IF (TestLibNbr > 0) OR (TestProcNbr > 0) OR (ProdLibSeen (ProdLibCpf) = Gen-Con-True) PERFORM 3011-Warn-Non-Std-Libraries. PERFORM 3012-Warn-Override-Libraries. PERFORM 3016-Warn-Release-Problems. / 3011-Warn-Non-Std-Libraries. MOVE '@BANNER NonStandard,Libraries' TO AddRec. WRITE AddRec. MOVE NameEditorUnisysInput TO AddRec (1:10). MOVE 'TPF$.Warning' TO AddRec (11:). WRITE AddRec. MOVE 'Test copy libraries were used: ' TO AddRec. WRITE AddRec. IF (ProdLibSeen (ProdLibCpf) = Gen-Con-True) MOVE ' COB$PF (no IN/OF clause)' TO AddRec WRITE AddRec END-IF PERFORM VARYING TestLibIdx FROM 1 BY 1 UNTIL TestLibIdx > TestLibNbr MOVE SPACES TO AddRec STRING Indent DELIMITED BY SIZE TestLibUse (TestLibIdx) DELIMITED BY ' ' INTO AddRec WRITE AddRec END-PERFORM. MOVE 'Program not releasable until the ' TO AddRec. WRITE AddRec. MOVE 'following procs are also released.' TO AddRec. WRITE AddRec. PERFORM VARYING TestProcIdx FROM 1 BY 1 UNTIL TestProcIdx > TestProcNbr MOVE SPACES TO AddRec STRING Indent DELIMITED BY SIZE TestProcName (TestProcIdx) DELIMITED BY ' ' INTO AddRec WRITE AddRec END-PERFORM. MOVE '@EDIT mcc &' TO AddRec. WRITE AddRec. MOVE '&rem!&rem!&p!&rem!&rem!&omit' TO AddRec. WRITE AddRec. / 3012-Warn-Override-Libraries. * It doesn't matter whether a ProdLibUse was seen. The file * could be referenced later in a map directive, and GENDIR * doesn't create "Override*" files. So do this always: CALL 'AscFd' USING 6 'TmpUse' 12 Fitem-Pkt Dummy. MOVE 0 TO FlagPrtdOvLibs. PERFORM VARYING ProdLibIdx FROM 1 BY 1 UNTIL ProdLibIdx > ProdLibMax IF (ProdLibOverride (ProdLibIdx) = Gen-Con-True) AND (NOT (ProdLibIdx = ProdLibCpf OR ProdLibDuo)) PERFORM 3013-Warn-Override-Continue END-IF END-PERFORM. IF (0 < OptReleaseGen AND GenAppFlagFromSI) MOVE '@BANNER Override,GenApp$' TO AddRec WRITE AddRec. MOVE '@FREE,A TmpUse.' TO Acsf-Image. PERFORM 8040-ErAcsf-AllowFacReject. 3013-Warn-Override-Continue. Once IF (FlagPrtdOvLibs = 0) AND (OptReleaseGen > 0) per MOVE 1 TO FlagPrtdOvLibs print MOVE '@BANNER Override,Libraries' TO AddRec file. WRITE AddRec . MOVE SPACES TO AddRec. STRING '@PRT,TL My*' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO AddRec. WRITE AddRec. MOVE SPACES TO Acsf-Image. STRING '@USE TmpUse.,Override*' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO Acsf-Image. PERFORM 8030-ErAcsf. PERFORM 8050-ErFitem. unasgd IF (Fitem-Equip-Code = 0) PERFORM 3014-Warn-Override-Create-Lib. / 3014-Warn-Override-Create-Lib. MOVE SPACES TO AddRec. STRING '@FREE Override*' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '. . in case cat''d' DELIMITED BY SIZE INTO AddRec. PERFORM 3015-Warn-Override-Create-File. MOVE SPACES TO AddRec. STRING '@FREE Override*' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '. . in case temp too' DELIMITED BY SIZE INTO AddRec. PERFORM 3015-Warn-Override-Create-File. MOVE SPACES TO AddRec. STRING '@ASG,T Override*' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '.,F///99999' DELIMITED BY SIZE INTO AddRec. PERFORM 3015-Warn-Override-Create-File. MOVE SPACES TO AddRec. STRING '@COPY ' DELIMITED BY SIZE ProdLibFile (ProdLibIdx) DELIMITED BY ' ' '.,Override*' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO AddRec. WRITE AddRec. MOVE SPACES TO AddRec. STRING '@COPY,P My*' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '.,Override*' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO AddRec. WRITE AddRec. Prep MOVE SPACES TO AddRec. in STRING '@PACK,P Override*' DELIMITED BY SIZE case ProdLibUse (ProdLibIdx) DELIMITED BY ' ' RLIB'd '.' DELIMITED BY SIZE INTO AddRec. WRITE AddRec. 3015-Warn-Override-Create-File. IF (FlagMassCompile > 0) Do it MOVE AddRec TO Acsf-Image now. PERFORM 8030-ErAcsf ELSE Later. WRITE AddRec. / 3016-Warn-Release-Problems. IF (FlagUsesAlter > 0) MOVE '@BANNER Bad-Verbs,Uses-Alter' TO AddRec WRITE AddRec. IF (FlagUsesDateTim > 0) MOVE '@BANNER Bad-Verbs,Accepts,Date-Time' TO AddRec WRITE AddRec. * IF (FlagUsesGoTo > 0) * MOVE '@BANNER Bad-Verbs,Uses-Go-To' TO AddRec * WRITE AddRec. IF (FlagUsesNote > 0) MOVE '@BANNER Bad-Verbs,Uses-Note' TO AddRec WRITE AddRec. IF (FlagProgIdIsBad > 0) MOVE '@BANNER Bad-ProgId,Not-EltName' TO AddRec WRITE AddRec. IF (FlagUsesMonitor > 0) AND (FlagUsesMcFlag = 0) MOVE '@BANNER Contains,MONITOR,No-McFlag' TO AddRec WRITE AddRec. / 3020-Down-Release-Gens. IF (OptReleaseGen > 0) IF (OptNoListings > 0) MOVE SPACES TO AddRec STRING '@MSG,N @DOWNER suppressed by @' DELIMITED BY SIZE NameEltSelf DELIMITED BY ' ' ',' OptNoListings-Txt ' option.' DELIMITED BY SIZE INTO AddRec WRITE AddRec ELSE PERFORM 3021-Down-Continue. 3021-Down-Continue. MOVE '@DOWNER' TO AddRec. IF (OptLongListings + OptSmallBusAdminBranch3 > 0) MOVE 8 TO StringPtr STRING ',' DELIMITED BY SIZE L-Txt, Z-Txt DELIMITED BY ' ' ' ' DELIMITED BY SIZE INTO AddRec WITH POINTER StringPtr ELSE MOVE 11 TO StringPtr. STRING NameQualFileIn DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltVerIn DELIMITED BY ' ' INTO AddRec WITH POINTER StringPtr. WRITE AddRec. / 3030-Assigns. PERFORM 3031-Assign-Tmp. PERFORM 3035-Assign-Libraries. 3031-Assign-Tmp. IF (FlagMassCompile > 0) MOVE '@MSG,N Prevent PCT overflow in mass compile by f - 'reeing previous gen''s Tmp:' TO AddRec WRITE AddRec MOVE '@FREE Tmp. . in case catalogued' TO AddRec WRITE AddRec MOVE '@FREE Tmp. . in case temp too' TO AddRec WRITE AddRec. MOVE SPACES TO AddRec. STRING '@USE Tmp.,Tmp' DELIMITED BY SIZE NameEltIn (1:9) DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO AddRec. WRITE AddRec. MOVE '@ASG Tmp.,F///9999' TO AddRec. WRITE AddRec. MOVE '@ERS Tmp. . in case catalogued' TO AddRec. WRITE AddRec. IF (NameSchemaFile = SPACES) MOVE SPACES TO AddRec STRING '@COPY,S ' DELIMITED BY SIZE NameQualFileGenApp DELIMITED BY ' ' '.GenApp$,Tmp.' DELIMITED BY SIZE INTO AddRec WRITE AddRec ELSE PERFORM 3032-Pass-Source-SchemaFile. / 3032-Pass-Source-SchemaFile. MOVE NameEditorUnisysCopy TO AddRec. MOVE 11 TO StringPtr. STRING NameQualFileGenApp DELIMITED BY ' ' '.GenApp$,Tmp.GenApp$' DELIMITED BY SIZE INTO AddRec WITH POINTER StringPtr. WRITE AddRec. MOVE 'F S' TO AddRec. WRITE AddRec. MOVE 'D 9999' TO AddRec. WRITE AddRec. MOVE 'LAST' TO AddRec. WRITE AddRec. MOVE 'I Sch: ' TO AddRec (1:7). MOVE NameSchemaFile TO AddRec (8:). WRITE AddRec. MOVE 'EXIT' TO AddRec. WRITE AddRec. / 3035-Assign-Libraries. PERFORM VARYING ProdLibIdx FROM 1 BY 1 UNTIL ProdLibIdx > ProdLibMax IF (ProdLibSeen (ProdLibIdx) = Gen-Con-True) OR (ProdLibOverride (ProdLibIdx) = Gen-Con-True) PERFORM 3036-Assign-Library ELSE IF (ProdLibIdx NOT = ProdLibCpf) MOVE '@MSG,N Standard Lib ' TO AddRec ( 1:23) MOVE ProdLibUse (ProdLibIdx) TO AddRec (24:12) MOVE 'not needed this time.' TO AddRec (36:) WRITE AddRec END-IF END-IF END-PERFORM. PERFORM 3038-Assign-Dual-Proc. / 3036-Assign-Library. MOVE SPACES TO AddRec. STRING '@FREE,A ' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '. . Use name' DELIMITED BY SIZE INTO AddRec. WRITE AddRec. MOVE SPACES TO AddRec. STRING '@FREE ' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '. . In case temp file assigned' DELIMITED BY SIZE INTO AddRec. WRITE AddRec. Magic IF (ProdLibFile (ProdLibIdx) NOT = LOW-VALUES) PERFORM 3037-Assign-Library. / 3037-Assign-Library. IF (ProdLibOverride (ProdLibIdx) = Gen-Con-True) MOVE SPACES TO AddRec STRING '@FREE,R ' DELIMITED BY SIZE ProdLibFile (ProdLibIdx) DELIMITED BY ' ' '. . Be extra sure not prod' DELIMITED BY SIZE INTO AddRec WRITE AddRec IF (ProdLibIdx = ProdLibCpf) MOVE SPACES TO AddRec STRING '@USE ' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '.,' DELIMITED BY SIZE 'Override*' DELIMITED BY SIZE ProdLibUse (ProdLibAsc) DELIMITED BY ' ' '. . Already assigned' DELIMITED BY SIZE INTO AddRec WRITE AddRec ELSE MOVE SPACES TO AddRec STRING '@USE ' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '.,' DELIMITED BY SIZE 'Override*' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '. . Already assigned' DELIMITED BY SIZE INTO AddRec WRITE AddRec ELSE MOVE SPACES TO AddRec STRING '@USE ' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '.,' DELIMITED BY SIZE ProdLibFile (ProdLibIdx) DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO AddRec WRITE AddRec MOVE SPACES TO AddRec STRING '@ASG,A ' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO AddRec WRITE AddRec. / 3038-Assign-Dual-Proc. IF (ProdLibSeen (ProdLibDuo) = Gen-Con-True) MOVE SPACES TO AddRec MOVE 1 TO StringPtr STRING '@USE ' DELIMITED BY SIZE ProdLibUse (ProdLibDuo) DELIMITED BY ' ' '.,' DELIMITED BY SIZE INTO AddRec WITH POINTER StringPtr IF (FlagCompiler = Gen-Con-Cmp-Ucob) STRING ProdLibUse (ProdLibUcs) DELIMITED BY ' ' '. ACOB/UCOB Sensitive' DELIMITED BY SIZE INTO AddRec WITH POINTER StringPtr ELSE STRING ProdLibUse (ProdLibAsc) DELIMITED BY ' ' '. ACOB/UCOB Sensitive' DELIMITED BY SIZE INTO AddRec WITH POINTER StringPtr END-IF WRITE AddRec . / 3040-Compile-To-AppGroup. IF (OptReleaseGen > 0) IF (GenAppNbrTest NOT = GenAppNbrProd) PERFORM 3041-Compile-To-App-Test END-IF MOVE 'C' TO Acob-Opt-Copy MOVE 'R' TO Acob-Opt-XRef MOVE 'S' TO Acob-Opt-Source MOVE ',LISTCOPY' TO Ucob-Opt-Copy MOVE ',XREF' TO Ucob-Opt-XRef MOVE ',SOURCE' TO Ucob-Opt-Source PERFORM 3042-Compile-To-App-Prod ELSE IF (OptNoListings = 0) MOVE 'C' TO Acob-Opt-Copy MOVE 'S' TO Acob-Opt-Source MOVE ',LISTCOPY' TO Ucob-Opt-Copy MOVE ',SOURCE' TO Ucob-Opt-Source IF (OptLongListings > 0) MOVE 'R' TO Acob-Opt-XRef MOVE ',XREF' TO Ucob-Opt-XRef END-IF END-IF IF (OptTest > 0) OR (OptTest + OptProd = 0) PERFORM 3041-Compile-To-App-Test END-IF IF (OptProd > 0) PERFORM 3042-Compile-To-App-Prod END-IF . MOVE '@DoNoMo: MSG,N' TO AddRec. WRITE AddRec. IF (NameSchemaFile NOT = SPACES) MOVE SPACES TO AddRec STRING '@FREE,R ' DELIMITED BY SIZE NameSchemaFile DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO AddRec WRITE AddRec. / 3041-Compile-To-App-Test. MOVE GenAppQualTest TO NameAppGroupSql. IF (OptCompFile > 0) MOVE GenAppQualTestComp TO NameAppGroup PERFORM 3045-Compile-To-App ELSE MOVE GenAppQualTest TO NameAppGroup PERFORM 3045-Compile-To-App . 3042-Compile-To-App-Prod. MOVE GenAppQualProd TO NameAppGroupSql. IF (OptCompFile > 0) MOVE GenAppQualProdComp TO NameAppGroup PERFORM 3045-Compile-To-App ELSE MOVE GenAppQualProd TO NameAppGroup PERFORM 3045-Compile-To-App . / 3045-Compile-To-App. MOVE SPACES TO AddRec. STRING '@HDG,P *** ' 'Compiling ' DELIMITED BY SIZE NameQualFileIn DELIMITED BY ' ' '''s ' DELIMITED BY SIZE NameEltVerIn DELIMITED BY ' ' ' TO ' DELIMITED BY SIZE NameAppGroup DELIMITED BY ' ' ' ***' DELIMITED BY SIZE INTO AddRec. WRITE AddRec. PERFORM 8120-Get-EltVerRel. PERFORM 8140-Get-SourceIn. * At this point, we know we have to compile to an application * group, but that could be because we're DMS, or because we're * RDMS with embedded SQL, or because we have P or T in column * 7. Only DMS needs to do more here: IF (NameSubschema = SPACES) MOVE NameSourceIn TO NameCompilerInput PERFORM 3060-Dcd-AndOr-Compile ELSE PERFORM 3046-Compile-To-App-DMS. / 3046-Compile-To-App-DMS. MOVE SPACES TO Disp-Image. STRING '@FREE,AR ' DELIMITED BY SIZE NameSchemaFile DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO Disp-Image. WRITE AddRec FROM Disp-Image. ",AR" MOVE SPACES TO Disp-Image (6:3). WRITE AddRec FROM Disp-Image. MOVE SPACES TO AddRec. STRING '@USE ' DELIMITED BY SIZE NameSchemaFile DELIMITED BY ' ' '.,' DELIMITED BY SIZE NameAppGroup DELIMITED BY ' ' '*' DELIMITED BY SIZE NameSchemaFile DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO AddRec. WRITE AddRec. MOVE '@ASG,A' TO Disp-Image (1:6). WRITE AddRec FROM Disp-Image. IF (FlagCompiler = Gen-Con-Cmp-Ucob) MOVE NameSourceIn TO NameCompilerInput ELSE MOVE SPACES TO NameCompilerInput STRING 'Tmp.DmlOut' DELIMITED BY SIZE NameEltIn (1:6) DELIMITED BY ' ' '/' DELIMITED BY SIZE NameVerRel DELIMITED BY ' ' INTO NameCompilerInput PERFORM 3047-Compile-To-App-ADMLP. PERFORM 3060-Dcd-AndOr-Compile. / 3047-Compile-To-App-ADMLP. MOVE 'Y' TO Dcd-Opt-Admlpd. MOVE SPACES TO AddRec. STRING '@ADMLP,CEXZ ' DELIMITED BY SIZE NameSourceIn DELIMITED BY ' ' ',' DELIMITED BY SIZE NameCompilerInput DELIMITED BY ' ' INTO AddRec. IF (OptAdmlpSourceListing > 0) MOVE 'SXZ' TO AddRec (10 : 3). WRITE AddRec. MOVE '@TEST TOP/4/T1 . ok?' TO AddRec. WRITE AddRec. MOVE '@JUMP DoAcob . yes' TO AddRec. WRITE AddRec. MOVE NameEditorUnisysInput TO AddRec (1:10). MOVE 'TPF$.MsgToPgmr' TO AddRec (11:). WRITE AddRec. MOVE SPACES TO AddRec. STRING 'END Msg: The @ADMLP of ' DELIMITED BY SIZE NameEltVerIn DELIMITED BY ' ' ' to ' DELIMITED BY SIZE NameAppGroup DELIMITED BY ' ' ' aborted.' DELIMITED BY SIZE INTO AddRec. WRITE AddRec. MOVE '@ADD Ecl$.AddElt/MsgToPgmr' TO AddRec. WRITE AddRec. IF (OptAdmlpSourceListing = 0) MOVE SPACES TO AddRec STRING '@ADMLP,CESXZ ' DELIMITED BY SIZE NameSourceIn DELIMITED BY ' ' ',' DELIMITED BY SIZE NameCompilerInput DELIMITED BY ' ' INTO AddRec WRITE AddRec. MOVE '@JUMP DoNoMo' TO AddRec. WRITE AddRec. MOVE '@DoAcob: MSG,N' TO AddRec. WRITE AddRec. / 3050-Compile-No-AppGroup. MOVE SPACES TO AddRec. STRING '@HDG,P *** ' 'Compiling ' DELIMITED BY SIZE NameQualFileIn DELIMITED BY ' ' '''s ' DELIMITED BY SIZE NameEltVerIn DELIMITED BY ' ' ' ***' DELIMITED BY SIZE INTO AddRec. WRITE AddRec. MOVE SPACES TO NameAppGroup. PERFORM 8120-Get-EltVerRel. PERFORM 8140-Get-SourceIn. MOVE NameSourceIn TO NameCompilerInput. IF (OptReleaseGen > 0) OR (OptNoListings = 0) MOVE 'C' TO Acob-Opt-Copy MOVE 'S' TO Acob-Opt-Source MOVE ',LISTCOPY' TO Ucob-Opt-Copy MOVE ',SOURCE' TO Ucob-Opt-Source IF (OptReleaseGen + OptLongListings > 0) MOVE 'R' TO Acob-Opt-XRef MOVE ',XREF' TO Ucob-Opt-XRef MOVE ' ' TO Dcd-Opt-Admlpd. PERFORM 3060-Dcd-AndOr-Compile. / 3060-Dcd-AndOr-Compile. IF (OptDCD > 0) PERFORM 3061-Dcd ELSE PERFORM 3062-Compile. 3061-Dcd. MOVE SPACES TO AddRec. STRING '@AASA*UTIL.DCD,WAS' Dcd-Opt-Admlpd ' ' DELIMITED BY SIZE NameCompilerInput DELIMITED BY ' ' INTO AddRec. WRITE AddRec. IF (OptProd + OptReleaseGen + OptTest > 0) MOVE SPACES TO Acob-Opts Ucob-Opts PERFORM 3062-Compile. / 3062-Compile. MOVE SPACES TO NameCompilerOutput. STRING 'Tmp.' DELIMITED BY SIZE NameEltVerRel DELIMITED BY ' ' INTO NameCompilerOutput. IF (0 < OptErrorDetection OR FlagCallsPads) MOVE 'K' TO Acob-Opt-Debug. IF (OptErrorDetection > 0) MOVE 'X' TO Acob-Opt-Table. IF (OptFloatingPointCompute > 0) MOVE 'T' TO Acob-Opt-Float. IF (OptSyntaxOnly > 0) MOVE '5' TO Acob-Opt-Syntax MOVE ',NO-CODE' TO Ucob-Opt-Syntax. IF (FlagThisIsSubr > 0) OR (OptSubprogram > 0) MOVE 'V' TO Acob-Opt-Subr MOVE ',SUBPROGRAM' TO Ucob-Opt-Subr. IF (OptMonitor > 0) MOVE ',MONITOR' TO Ucob-Opt-Moni ELSE ForNow* MOVE 'M' TO Acob-Opt-NoMoni. ForNow* (That would force monitor off in the case of ACOB.) ForNow* (For now, let's not do that.) MOVE ' ' TO Acob-Opt-NoMoni. IF (0 < OptErrorDetection OR FlagCallsPads) IF (OptLongListings > 0) MOVE ',FULL-DEBUG' TO Ucob-Opt-Debug ELSE MOVE ',DEBUG' TO Ucob-Opt-Debug. IF (0 < OptErrorDetection OR FlagCallsPads OR OptMonitor) MOVE ',NO-OPTIM' TO Ucob-Opt-Optim. IF (OptAcob > 0) OR (FlagCompiler NOT = Gen-Con-Cmp-Ucob) PERFORM 3063-Compile-Using-Acob. IF (OptUcob > 0) OR (FlagCompiler = Gen-Con-Cmp-Ucob) PERFORM 3064-Compile-Using-Ucob. IF (OptSyntaxOnly = 0) PERFORM 3070-GenDir. / 3063-Compile-Using-Acob. MOVE SPACES TO AddRec. MOVE 1 TO StringPtr. STRING '@ACOB,' DELIMITED BY SIZE Acob-Opt-Copy DELIMITED BY ' ' 'E' DELIMITED BY SIZE Acob-Opt-NoMoni Acob-Opt-XRef Acob-Opt-Source Acob-Opt-Subr DELIMITED BY ' ' ' ' DELIMITED BY SIZE INTO AddRec WITH POINTER StringPtr. MOVE StringPtr TO PrevStringPtr. STRING NameCompilerInput DELIMITED BY ' ' ',;' DELIMITED BY SIZE INTO AddRec WITH POINTER StringPtr. WRITE AddRec. MOVE SPACES TO AddRec. MOVE PrevStringPtr TO StringPtr. STRING NameCompilerOutput DELIMITED BY ' ' INTO AddRec WITH POINTER StringPtr. IF (Acob-Extra-Opts NOT = SPACES) STRING ',,' DELIMITED BY SIZE Alpha Acob-Opt-Syntax in gen Acob-Opt-Debug -eratd Acob-Opt-Float ECL. Acob-Opt-Table DELIMITED BY ' ' INTO AddRec WITH POINTER StringPtr. WRITE AddRec. / 3064-Compile-Using-Ucob. MOVE SPACES TO AddRec. STRING '@UCOB ' DELIMITED BY SIZE NameCompilerInput DELIMITED BY ' ' ',;' DELIMITED BY SIZE INTO AddRec. WRITE AddRec. MOVE SPACES TO AddRec. STRING ' ' DELIMITED BY SIZE NameCompilerOutput DELIMITED BY ' ' ',,;' DELIMITED BY SIZE INTO AddRec. WRITE AddRec. MOVE SPACES TO AddRec. STRING ' ' DELIMITED BY SIZE NameQualFileEcl DELIMITED BY ' ' '.UcobOpts,;' DELIMITED BY SIZE INTO AddRec. WRITE AddRec. IF (FlagEmbeddedSQL > 0) MOVE SPACES TO AddRec STRING ' APPLICATION/' DELIMITED BY SIZE NameAppGroupSql DELIMITED BY ' ' ',; (for embedded SQL)' DELIMITED BY SIZE INTO AddRec WRITE AddRec. IF (UserUcobKeywords NOT = LOW-VALUES) MOVE UserUcobKeywords TO AddRec WRITE AddRec. IF (OptErrorDetection > 0) MOVE ' PARMCHECK,RUNCHECK,;' TO AddRec WRITE AddRec. MOVE SPACES TO AddRec. STRING ' WIDE' DELIMITED BY SIZE * Alphabetical order in the generated ECL. Remote possibility * of overflowing AddRec, but trailing spaces compress out. D or F Ucob-Opt-Debug LIST.. Ucob-Opt-Copy MONI.. Ucob-Opt-Moni NO-C.. Ucob-Opt-Syntax NO-O.. Ucob-Opt-Optim SOUR.. Ucob-Opt-Source SUBP.. Ucob-Opt-Subr XREF Ucob-Opt-XRef DELIMITED BY ' ' INTO AddRec. WRITE AddRec. / 3070-GenDir. IF (OptAcob > 0) OR (FlagCompiler NOT = Gen-Con-Cmp-Ucob) PERFORM 3071-GenDir-Begin MOVE 'A' TO AddRec (StringPtr:1) PERFORM 3072-GenDir-End . IF (OptUcob > 0) OR (FlagCompiler = Gen-Con-Cmp-Ucob) IF (UserDirCtr > 0) MOVE '@ELT,LIQ Tmp.GenULD$' TO AddRec WRITE AddRec PERFORM VARYING UserDirIdx FROM 1 BY 1 UNTIL UserDirIdx > UserDirCtr MOVE UserDir (UserDirIdx) TO AddRec WRITE AddRec END-PERFORM MOVE '@EOF' TO AddRec WRITE AddRec END-IF PERFORM 3071-GenDir-Begin MOVE 'U' TO AddRec (StringPtr:1) PERFORM 3072-GenDir-End . 3071-GenDir-Begin. MOVE '@' TO AddRec. MOVE 2 TO StringPtr. IF (NameQualFileSelfOnly NOT = NameQualFileSelfProd) STRING NameQualFileSelf DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltGenDirUC DELIMITED BY ' ' * More than one GENDIR can reside in non-prod file: '/' DELIMITED BY SIZE GenDir-xRx DELIMITED BY ' ' ',' DELIMITED BY SIZE INTO AddRec WITH POINTER StringPtr ELSE STRING NameEltGenDirUC DELIMITED BY ' ' ',' DELIMITED BY SIZE INTO AddRec WITH POINTER StringPtr. / 3072-GenDir-End. ADD 1 TO StringPtr. STRING Gen-Opts DELIMITED BY ' ' INTO AddRec WITH POINTER StringPtr. IF (FlagThisIsSubr > 0) AND (OptSubprogram = 0) STRING 'V' DELIMITED BY SIZE INTO AddRec WITH POINTER StringPtr. ADD 1 TO StringPtr. MOVE StringPtr TO PrevStringPtr. STRING NameCompilerOutput DELIMITED BY ' ' ',;' DELIMITED BY SIZE INTO AddRec WITH POINTER StringPtr. WRITE AddRec. MOVE SPACES TO AddRec. STRING NameQualFileOut DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltVerOut DELIMITED BY ' ' INTO AddRec WITH POINTER PrevStringPtr. WRITE AddRec. / 3080-Frees. * It doesn't matter whether a ProdLibUse was seen. It could * have been referenced in a map directive. So do this always: PERFORM VARYING ProdLibIdx FROM 1 BY 1 UNTIL ProdLibIdx > ProdLibMax Magic IF (ProdLibFile (ProdLibIdx) NOT = LOW-VALUES) MOVE SPACES TO AddRec STRING '@FREE,R ' DELIMITED BY SIZE ProdLibFile (ProdLibIdx) DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO AddRec WRITE AddRec END-IF END-PERFORM. / 3090-AutoEdit. IF (FlagMassCompile > 0) PERFORM 3091-AutoEdit-Deferred ELSE MOVE SPACES TO AddRec STRING '@USE Lst.,' DELIMITED BY SIZE NameBrkpt DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO AddRec WRITE AddRec MOVE '@ASG,A Lst.' TO AddRec WRITE AddRec IF (OptFullScreenEditor > 0) PERFORM 3092-AutoEdit-With-FullScreen ELSE PERFORM 3093-AutoEdit-With-Editor. 3091-AutoEdit-Deferred. MOVE SPACES TO EditsRec. STRING NameEditorUnisys DELIMITED BY SIZE NameBrkpt DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO EditsRec. WRITE EditsRec. IF (OptUcob > 0) OR (FlagCompiler = Gen-Con-Cmp-Ucob) IF (FlagUsesSOff > 0) MOVE '@ADD,P Ecl$.AddElt/S-Off--SList' TO EditsRec WRITE EditsRec END-IF MOVE 'FC *ERROR' TO EditsRec WRITE EditsRec . MOVE '@ADD Ecl$.AddElt/AutoEdit' TO EditsRec. WRITE EditsRec. / 3092-AutoEdit-With-FullScreen. MOVE NameEditorFullScreen TO AddRec (1:10). MOVE 'Lst.' TO AddRec (11:). WRITE AddRec. IF (OptUcob > 0) OR (FlagCompiler = Gen-Con-Cmp-Ucob) MOVE 'FC *ERROR' TO AddRec WRITE AddRec. Find ENDs MOVE 'FEnds' TO AddRec. macro. WRITE AddRec. 3093-AutoEdit-With-Editor. MOVE NameEditorUnisys TO AddRec (1:10). MOVE 'Lst.' TO AddRec (11:). WRITE AddRec. IF (OptUcob > 0) OR (FlagCompiler = Gen-Con-Cmp-Ucob) IF (FlagUsesSOff > 0) MOVE '@ADD,P Ecl$.AddElt/S-Off--SList' TO AddRec WRITE AddRec END-IF MOVE 'FC *ERROR' TO AddRec WRITE AddRec . MOVE '@ADD Ecl$.AddElt/AutoEdit' TO AddRec. WRITE AddRec. IF (FlagMassCompile = 0) AND (R-Opt > 0) MOVE 'REM!***** Release Gen Verifier: @ADD,L ECL$.AddElt/ - 'Verify' TO AddRec WRITE AddRec. / 8000-Check-Status-Sdf. IF (Sdf-Pkt-Status NOT = Sdf-Con-NoErr) DISPLAY Sdf-Pkt-Status-Text UPON Prtr-Out STOP RUN. 8010-Display-Acsf-Status. DISPLAY Acsf-Image UPON Prtr-Out. COPY Convert-Octal-Pd-Group IN UCS-PROC REPLACING P1 BY Acsf-Status. DISPLAY 'got bad status: ' Display-Octal UPON Prtr-Out. 8020-Display-Sdf-Line. COPY Convert-Octal-Pd-Num IN UCS-PROC REPLACING P1 BY Sdf-Icw. DISPLAY Indent Indent Display-Octal ': ' Sdf-Image (1:80) UPON Prtr-Out. / 8030-ErAcsf. PERFORM 8040-ErAcsf-AllowFacReject. IF (Acsf-FacReject > 0) PERFORM 8010-Display-Acsf-Status PERFORM 9010-Terminate-In-Error STOP RUN. 8040-ErAcsf-AllowFacReject. COPY ErAcsf-Pd IN UCS-PROC. 8050-ErFitem. MOVE LOW-VALUES TO Fitem-Pkt (9:). COPY ErFitem-Pd IN UCS-PROC. / 8060-ErIo-Init. COPY ErIo-Init IN UCS-PROC. 8070-ErIow. COPY ErIow-Pd IN UCS-PROC. IF (Io-Pkt-Status NOT = Io-Stat-NoErr) DISPLAY Indent 'IO status ' Io-Pkt-Status UPON Prtr-Out PERFORM 9010-Terminate-In-Error STOP RUN. / 8080-ErSnap. COPY Loc-Pd IN UCS-PROC REPLACING P1 BY StartOfGensDBank P2 BY SnapAddr. COPY Loc-Pd IN UCS-PROC REPLACING P1 BY EndOfGensDBank P2 BY EndOfGensDBank. SUBTRACT SnapAddr FROM EndOfGensDBank GIVING SnapLen. COPY ErSnap-Pd IN UCS-PROC. / 8090-Get-EltVerAbs. IF (NameEltVerOut = SPACES OR 'T' OR 'X') IF (NameEltOut = 'T' OR 'X') PERFORM 8092-Get-EltVerAbs-Short ELSE PERFORM 8091-Get-EltVerAbs-Default ELSE MOVE NameEltVerOut TO NameEltVerAbs. 8091-Get-EltVerAbs-Default. IF (NameEltOut = SPACES) MOVE NameEltIn TO NameEltOut. IF (NameVerInOrig = SPACES) MOVE NameAppGroup TO NameVerOut ELSE Truncd MOVE SPACES TO NameVerOut to 12 STRING NameAppGroup DELIMITED BY ' ' chars NameVerInOrig DELIMITED BY SIZE by len INTO NameVerOut. IF (NameVerOut = SPACES) MOVE NameEltOut TO NameEltVerAbs ELSE MOVE SPACES TO NameEltVerAbs STRING NameEltOut DELIMITED BY ' ' '/' DELIMITED BY SIZE NameVerOut DELIMITED BY ' ' INTO NameEltVerAbs. 8092-Get-EltVerAbs-Short. MOVE NameEltIn TO NameEltVerAbs. IF (NameAppGroup = GenAppQualTest) MOVE NameEltOut TO NameEltVerAbs (1:1). 8100-Get-EltVerIn. MOVE Toc-Rec-EltName TO NameEltIn. MOVE Toc-Rec-VerName TO NameVerIn. IF (NameEltIn = SPACES OR LOW-VALUES OR ALL '@') MOVE SPACES TO NameEltIn. IF (NameVerIn = SPACES OR LOW-VALUES OR ALL '@') MOVE NameEltIn TO NameEltVerIn MOVE SPACES TO NameVerIn ELSE MOVE SPACES TO NameEltVerIn STRING NameEltIn DELIMITED BY ' ' '/' DELIMITED BY SIZE NameVerIn DELIMITED BY ' ' INTO NameEltVerIn. / 8110-Get-EltVerOut. MOVE Ro-Toc-Record ( 1:12) TO NameEltOut. MOVE Ro-Toc-Record (21:12) TO NameVerOut. IF (NameEltOut = SPACES OR LOW-VALUES OR ALL '@') MOVE SPACES TO NameEltOut. IF (NameVerOut = SPACES OR LOW-VALUES OR ALL '@') MOVE NameEltOut TO NameEltVerOut MOVE SPACES TO NameVerOut ELSE MOVE SPACES TO NameEltVerOut STRING NameEltOut DELIMITED BY ' ' '/' DELIMITED BY SIZE NameVerOut DELIMITED BY ' ' INTO NameEltVerOut. 8120-Get-EltVerRel. IF (Toc-Rec-VerName = SPACES OR LOW-VALUES OR ALL '@') MOVE NameAppGroup TO NameVerRel ELSE Truncd MOVE SPACES TO NameVerRel to 12 STRING NameAppGroup DELIMITED BY ' ' chars Toc-Rec-VerName DELIMITED BY SIZE by len INTO NameVerRel. IF (NameVerRel = SPACES) MOVE NameEltIn TO NameEltVerRel ELSE MOVE SPACES TO NameEltVerRel STRING NameEltIn DELIMITED BY ' ' '/' DELIMITED BY SIZE NameVerRel DELIMITED BY ' ' INTO NameEltVerRel. / 8130-Get-QualFile. PERFORM 8050-ErFitem. MOVE Fitem-Ext-Qualifier TO ConvertNameFd. CALL 'FdAsc' USING 12 ConvertNameFd 12 ConvertNameAscii Dummy. MOVE ConvertNameAscii TO NameQual. MOVE Fitem-Ext-Filename TO ConvertNameFd. CALL 'FdAsc' USING 12 ConvertNameFd 12 ConvertNameAscii Dummy. MOVE ConvertNameAscii TO NameFile. IF (Fitem-Abs-FCyc < 10) MOVE Fitem-Abs-FCyc TO Pic9 MOVE Pic9 TO NameFCyc ELSE IF (Fitem-Abs-FCyc < 100) MOVE Fitem-Abs-FCyc TO Pic99 MOVE Pic99 TO NameFCyc ELSE MOVE Fitem-Abs-FCyc TO Pic999 MOVE Pic999 TO NameFCyc . MOVE SPACES TO NameQualFile. IF (Fitem-Abs-FCyc = 1) STRING NameQual DELIMITED BY ' ' '*' DELIMITED BY SIZE NameFile DELIMITED BY ' ' INTO NameQualFile ELSE STRING NameQual DELIMITED BY ' ' '*' DELIMITED BY SIZE NameFile DELIMITED BY ' ' '(' DELIMITED BY SIZE NameFCyc DELIMITED BY ' ' ')' DELIMITED BY SIZE INTO NameQualFile . / 8140-Get-SourceIn. MOVE SPACES TO NameSourceIn. IF (SCS-Nbr > 0) OR ((OptMonitor > 0) AND (FlagCompiler NOT = Gen-Con-Cmp-Ucob)) OR (FlagUsesCol7 > 0) STRING 'Tmp.' DELIMITED BY SIZE NameEltVerIn DELIMITED BY ' ' INTO NameSourceIn PERFORM 8141-Edit-Source-Into-Tmp ELSE STRING NameQualFileIn DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltVerIn DELIMITED BY ' ' INTO NameSourceIn. 8141-Edit-Source-Into-Tmp. MOVE SPACES TO AddRec. STRING NameEditorUnisysCopy DELIMITED BY SIZE NameQualFileIn DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltVerIn DELIMITED BY ' ' ',' DELIMITED BY SIZE NameSourceIn DELIMITED BY ' ' INTO AddRec. WRITE AddRec. MOVE 'CLI 7 72' TO AddRec. WRITE AddRec. IF (SCS-Nbr > 0) PERFORM 8142-Source-Code-Substitution. IF ((OptMonitor > 0) AND (FlagCompiler NOT = Gen-Con-Cmp-Ucob)) PERFORM 8144-Source-Code-Gets-Monitor. IF (FlagUsesCol7 > 0) PERFORM 8145-Source-Code-Gets-Col7. MOVE 'EXIT' TO AddRec. WRITE AddRec. / 8142-Source-Code-Substitution. PERFORM VARYING SCS-Idx FROM 1 BY 1 UNTIL SCS-Idx > SCS-Nbr IF (SCS-Name (SCS-Idx) (1:4) = 'APP-') AND (NameAppGroup = GenAppQualProd OR GenAppQualProdComp) MOVE SCS-ValQ (SCS-Idx) TO SCS-Hold-Val ELSE MOVE SCS-Val (SCS-Idx) TO SCS-Hold-Val END-IF PERFORM 8143-Source-Code-Change END-PERFORM. 8143-Source-Code-Change. @QED's MOVE SPACES TO AddRec. C,IG STRING 'C /GEN-' DELIMITED BY SIZE would SCS-Name (SCS-Idx) DELIMITED BY ' ' be '-SUB/' DELIMITED BY SIZE better SCS-Hold-Val DELIMITED BY LOW-VALUE but '/A' DELIMITED BY SIZE (7:72) INTO AddRec. fails. WRITE AddRec. / 8144-Source-Code-Gets-Monitor. * OptMonitor is used to decide whether or not to edit a MONITOR * into an ACOB program, not FlagUsesMonitor. (FlagUsesMonitor * can be set if the program already contains a MONITOR. In * that case, we obviously don't want to edit one in.) MOVE '@ADD,P ECL$.AddElt/Monitor' TO AddRec. WRITE AddRec. IF (FlagUsesMcFlag = 0) MOVE 'I @GEN,M MOVE 1 TO McFlag.' TO AddRec MOVE OptMonitor-Txt TO AddRec (8:1) WRITE AddRec. / 8145-Source-Code-Gets-Col7. * Although we've defined FlagUsesCol7AU and FlagUsesCol7PT, * it doesn't hurt not to use them here. (In fact, it's more * convenient to the user if we don't. The user needs only one * A, U, P or T in column 7 to trigger correct handling of all * (significant when the Procedure Division is not scanned).) MOVE 'CLI 7 7' TO AddRec. WRITE AddRec. IF (FlagCompiler = Gen-Con-Cmp-Ucob) MOVE 'C /a/*/A' TO AddRec WRITE AddRec MOVE 'C /A/*/A' TO AddRec WRITE AddRec MOVE 'C /u/ /A' TO AddRec WRITE AddRec MOVE 'C /U/ /A' TO AddRec WRITE AddRec ELSE MOVE 'C /a/ /A' TO AddRec WRITE AddRec MOVE 'C /A/ /A' TO AddRec WRITE AddRec MOVE 'C /u/*/A' TO AddRec WRITE AddRec MOVE 'C /U/*/A' TO AddRec WRITE AddRec . IF (NameAppGroup = GenAppQualProd OR GenAppQualProdComp) MOVE 'C /p/ /A' TO AddRec WRITE AddRec MOVE 'C /P/ /A' TO AddRec WRITE AddRec MOVE 'C /t/*/A' TO AddRec WRITE AddRec MOVE 'C /T/*/A' TO AddRec WRITE AddRec ELSE MOVE 'C /p/*/A' TO AddRec WRITE AddRec MOVE 'C /P/*/A' TO AddRec WRITE AddRec MOVE 'C /t/ /A' TO AddRec WRITE AddRec MOVE 'C /T/ /A' TO AddRec WRITE AddRec . / 8160-Verify-CmpTables. PERFORM 8161-Verify-ProdLibTbl. PERFORM 8162-Verify-TokenTbl. 8161-Verify-ProdLibTbl. MOVE SPACES TO VerifyPrev. MOVE Gen-Con-True TO TableIsAscending. PERFORM VARYING VerifyIdx FROM 1 BY 1 UNTIL VerifyIdx > ProdLibMax IF (VerifyPrev NOT < ProdLibUse (VerifyIdx)) DISPLAY Indent ProdLibUse (VerifyIdx) ' at ' VerifyIdx ' is out of seq' UPON Prtr-Out MOVE 0 TO TableIsAscending END-IF MOVE ProdLibUse (VerifyIdx) TO VerifyPrev END-PERFORM. IF (TableIsAscending = Gen-Con-True) DISPLAY Indent 'ProdLibs are ascending' UPON Prtr-Out. 8162-Verify-TokenTbl. MOVE SPACES TO VerifyPrev. MOVE Gen-Con-True TO TableIsAscending. PERFORM VARYING VerifyIdx FROM 1 BY 1 UNTIL VerifyIdx > TokenMax IF (VerifyPrev NOT < TokenName (VerifyIdx)) DISPLAY Indent TokenName (VerifyIdx) ' at ' VerifyIdx ' is out of seq' UPON Prtr-Out MOVE 0 TO TableIsAscending END-IF MOVE TokenName (VerifyIdx) TO VerifyPrev END-PERFORM. IF (TableIsAscending = Gen-Con-True) DISPLAY Indent 'Tokens are ascending' UPON Prtr-Out. / * Everywhere the following 2 paragraphs are PERFORMed, they * are followed by STOP RUN. Of course, we don't need to do * STOP RUNs in both places. It's just "belt and suspenders" * programming. 9000-Terminate. DISPLAY 'END ' NameEltSelf UPON Prtr-Out. STOP RUN. 9010-Terminate-In-Error. MOVE SPACES TO Disp-Image. STRING 'END ' DELIMITED BY SIZE NameEltSelf DELIMITED BY ' ' ' in error.' DELIMITED BY SIZE INTO Disp-Image. DISPLAY Disp-Image UPON Prtr-Out. STOP RUN. S-OFF COPY GenApp-Pd IN UCS-PROC. GenApp-ErAcsf. PERFORM 8030-ErAcsf. GenApp-Terminate-In-Error. PERFORM 9010-Terminate-In-Error. COPY Sdf-Record-Access IN UCS-PROC. COPY Toc-Record-Access IN UCS-PROC. SLIST @EOF @ELT,IQ UUSIG*1100-001-001.GENDIR/1R4,,,,COB COPY ProgId IN UCS-PROC REPLACING P1 BY GenDir. / ***************************************************************** * GenDir Program Description * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * GenDir is a UCOB program that reads COBOL object code (both * * relocatables and object modules) and decides how to @MAP or * * @LINK them. Along the way, it enforces SBA programming * * standards about where subprogram object code ought to come * * from, minimum DBank addresses, what database to map in, * * how detailed the listing print file should be, etc, etc. * * * * Gen executes as a ZOOM system processor. It used to be the * * @GEN,M option, but there's no need to have map tables at * * compile time, so I split them apart for memory efficiency. * * It also makes both Gen and GenDir quicker to load into text * * editors, and it makes them both quicker to compile/link. * * * * The original paragraph numbering (4000-, 5000- and 6000- * * series) has been largely preserved. That's because it's * * too confusing working on Gen and GenDir at the same time if * * the paragraph numbers are too similar. * * * * Steve Seaquist * * 06/22/1994 * * * ***************************************************************** / ***************************************************************** * REVISION HISTORY * ***************************************************************** * * * ------------------------F O R M A T-------------------------- * * CHANGE CHANGE CHANGED RMIS * * NUMBER DATE BY NUMBER DESCRIPTION OF CHANGE * * ------ ------ ------------- ------ ------------------------- * * CH-NNN MMDDYY FMLLLLLLLLLLL NNNNNN XXXXXXXXXXXXXXXXXXXXXXXXX * * ------------------------------------------------------------- * * 062294 SRSeaquist 940021 Initial Implementation * ***************************************************************** ***************************************************************** * GenDir's Compile/Map ECL: * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * @GEN,RL File.GenDir * * * * Since Gen and/or GenDir often have to be regenned in sync * * their subprograms, a special add element called GEN/GEN * * to gen them in sync: * * * * @SETC ## * * @ADD,L S.Gen/Gen * * * * where ## is an octal number identifying which modules to gen. * * Read Gen/Gen to see which bits currently gen which programs. * * * ***************************************************************** / INPUT-OUTPUT SECTION. FILE-CONTROL. SELECT CardFile ASSIGN TO DISC 'SI$$.GenULD$'. COPY GenApp-Select IN UCS-PROC. SELECT MapFile ASSIGN TO DISC 'Map$.Add$'. SELECT TblFile ASSIGN TO DISC 'ECL$.TBL$1R3'. I-O-CONTROL. APPLY EXREF ON GenProdLibs. / DATA DIVISION. FILE SECTION. FD CardFile BLOCK CONTAINS 1792 CHARACTERS LABEL RECORDS ARE STANDARD. 01 CardRec PIC X(80). COPY GenApp-Fd IN UCS-PROC. FD MapFile BLOCK CONTAINS 1792 CHARACTERS LABEL RECORDS ARE STANDARD. 01 MapRec PIC X(80). FD TblFile BLOCK CONTAINS 1792 CHARACTERS LABEL RECORDS ARE STANDARD. 01 TblRec. 05 TblName PIC X(12). 05 TblContents PIC X(68). / WORKING-STORAGE SECTION. * System COPY Procs are S-OFF'd: S-OFF COPY UcsGeneral-Ws IN UCS-PROC. 01 StartOfGensDBank PIC 1(36) BINARY-1. 01 StartOfTableDBank PIC 1(36) BINARY-1. COPY Convert-Octal-Ws IN UCS-PROC. COPY ErAcsf-Ws IN UCS-PROC. COPY ErFitem-Ws IN UCS-PROC. COPY ErIo-Ws IN UCS-PROC REPLACING Io-Buf-Words BY 1792. COPY ErPf-Ws IN UCS-PROC. COPY ErSnap-Ws IN UCS-PROC. COPY Loc-Ws IN UCS-PROC. COPY PrePro-Ws IN UCS-PROC REPLACING EltName BY EltNamePrePro Max BY 4. COPY Sdf-Constants-Ws IN UCS-PROC. COPY Sdf-Packet-Ws IN UCS-PROC. COPY Sdf-Record-Ws IN UCS-PROC. COPY Toc-Constants-Ws IN UCS-PROC. COPY Toc-Packet-Ws IN UCS-PROC. COPY Toc-Record-Ws IN UCS-PROC. COPY UcsInitReg-Ws IN UCS-PROC. SLIST / 01 ConvertNameAscii PIC X(12). 01 ConvertNameFd PIC X(08). 01 Counters-Etc. 05 EltRelatedInfo. * In GEN, these were called "Flags", but in GENDIR, it would * be much too confusing to continue calling them that. 10 EltHolds. 15 HoldEltType PIC X(16). 15 HoldIBankNo PIC 9(02) VALUE 0. 15 REDEFINES HoldIBankNo. 20 PIC 9(01). 20 HoldIBankNo9 PIC 9(01). 15 HoldClearing PIC 1(06) BINARY-1 VALUE 0. 15 HoldUsesCommon PIC 1(06) BINARY-1 VALUE 0. 15 PIC 1(06) BINARY-1 VALUE 0. 10 ExrefTableInfo. 15 ExrefOffset PIC 1(18) BINARY-1 VALUE 0. 15 ExrefTotalInElt PIC 1(18) BINARY-1 VALUE 0. 10 InfoTableInfo. 15 InfoOffset PIC 1(18) BINARY-1 VALUE 0. 15 InfoTotal PIC 1(18) BINARY-1 VALUE 0. 10 NameTableSectOffset PIC 1(18) BINARY-1 VALUE 0. 10 NameTableWordLen PIC 1(18) BINARY-1 VALUE 0. 10 NameTableWordOffset PIC 1(18) BINARY-1 VALUE 0. 10 NameXRefCharLen PIC 1(18) BINARY-1 VALUE 0. 10 REDEFINES NameXRefCharLen. 15 NameXRefWordLen PIC 1(16) BINARY-1. 15 PIC 1(02) BINARY-1. 10 PrevStringPtr PIC 1(09) BINARY-1 VALUE 0. 10 PrevUnstringPtr PIC 1(09) BINARY-1 VALUE 0. 10 FILLER PIC 1(18) BINARY-1 VALUE 0. /Counters-Etc, continued: 05 FileRelatedInfo. 10 EltInCtr PIC 1(18) BINARY-1 VALUE 0. 10 ExrefTotal PIC 1(36) BINARY-1 VALUE 0. 10 FileHolds. 15 HoldCardsExist PIC 1(06) BINARY-1 VALUE 0. 15 HoldEof PIC 1(06) BINARY-1 VALUE 0. 15 HoldMassCompile PIC 1(06) BINARY-1 VALUE 0. 15 HoldSelfIsCatd PIC 1(06) BINARY-1 VALUE 0. 15 PIC 1(12) BINARY-1 VALUE 0. 05 Loop-Control. 10 i PIC 1(18) BINARY-1. 10 j PIC 1(18) BINARY-1. 10 k PIC 1(18) BINARY-1. 10 l PIC 1(18) BINARY-1. 05 Tally PIC 1(18) BINARY-1. 05 String-Control. 10 StringDelim PIC X(01). 10 StringPtr PIC 1(09) BINARY-1. 01 Dummy PIC S1(36) VALUE +0. / 01 Gen-Constants. * Note: This is one of many places where we say "Gen" rather * than "GenDir". One reason is the fact that Gen and * GenDir are 2 parts of the same whole. Another is * that GenDir is too much to type in a dataname. 05 Gen-Con-Tbl-Sizes. 10 Gen-Con-XRefMaxFlags PIC 1(09) VALUE 4. 05 Gen-Con-True PIC 1(18) BINARY-1 VALUE 4060. 05 GenDir-Version PIC X(03) VALUE '1.4'. 05 PIC X(01) VALUE ' '. 05 Indent PIC X(04) VALUE SPACES. COPY GenApp-Ws IN UCS-PROC. / 01 Hold-Names. * Whenever any of these names disturb word-alignment, they * occur in adjacent pairs that restore word-alignment. 05 Disp-Image PIC X(80) VALUE SPACES. 05 NameAppGroup PIC X(12) VALUE SPACES. 05 NameAppGroupIn PIC X(12) VALUE SPACES. 05 NameAppGroupRS PIC X(12) VALUE SPACES. 05 NameBrkpt PIC X(12) VALUE SPACES. 05 NameCompilerInput PIC X(60) VALUE SPACES. 05 NameCompilerOutput PIC X(60) VALUE SPACES. 05 NameCopyProc PIC X(32) VALUE SPACES. 05 NameDBankMin PIC X(08) VALUE SPACES. 05 NameDmrmt PIC X(12) VALUE SPACES. 05 NameEltIn PIC X(12) VALUE SPACES. 05 NameEltOut PIC X(12) VALUE SPACES. pair 05 NameEltSelf PIC X(06) VALUE 'GenDir'. pair 05 NameEltSelfUC PIC X(06) VALUE 'GENDIR'. 05 NameEltSubr PIC X(12) VALUE SPACES. 05 NameEltSysdta PIC X(12) VALUE SPACES. 05 NameEltVerAbs PIC X(28) VALUE SPACES. 05 NameEltVerIn PIC X(28) VALUE SPACES. 05 NameEltVerInSysdta PIC X(28) VALUE SPACES. 05 NameEltVerOut PIC X(28) VALUE SPACES. 05 NameEltVerRel PIC X(28) VALUE SPACES. 05 NameEntry PIC X(12) VALUE SPACES. 05 NameEntryCB PIC X(12) VALUE SPACES. 05 NameFCyc PIC X(04) VALUE SPACES. 05 NameFile PIC X(12) VALUE SPACES. 05 NameFileIn PIC X(12) VALUE SPACES. 05 NameGenSignon PIC X(80) VALUE SPACES. 05 NameOverflowed PIC X(12) VALUE SPACES. 05 NameProgId PIC X(32) VALUE SPACES. 05 NameQual PIC X(12) VALUE SPACES. 05 NameQualFile PIC X(28) VALUE SPACES. 05 NameQualFileEcl PIC X(28) VALUE SPACES. 05 NameQualFileGenApp PIC X(28) VALUE SPACES. 05 NameQualFileIn PIC X(28) VALUE SPACES. 05 NameQualFileOut PIC X(28) VALUE SPACES. 05 NameQualFileSelf PIC X(28) VALUE SPACES. 05 NameQualIn PIC X(12) VALUE SPACES. 05 NameSchemaFile PIC X(12) VALUE SPACES. 05 NameSourceIn PIC X(60) VALUE SPACES. 05 NameSrcOrObj PIC X(16) VALUE SPACES. 05 NameSubschema PIC X(12) VALUE SPACES. 05 NameVerIn PIC X(12) VALUE SPACES. 05 NameVerInOrig PIC X(12) VALUE SPACES. 05 NameVerOut PIC X(12) VALUE SPACES. 05 NameVerRel PIC X(12) VALUE SPACES. 05 NameXRef PIC X(12) VALUE SPACES. / 01 Hold-Opts. 05 Gen-Opts PIC X(28) VALUE SPACES. 05 Gen-Opts-All PIC X(28) VALUE SPACES. 05 Processor-Opts. 10 Link-Opts. 15 Link-Opt-List PIC X(01). 10 Map-Opts. 15 Map-Opt-List PIC X(01). / 01 Opt-Txts. 05 A-Txt PIC X(01) VALUE 'A'. 05 B-Txt PIC X(01) VALUE 'B'. 05 C-Txt PIC X(01) VALUE 'C'. 05 D-Txt PIC X(01) VALUE 'D'. 05 E-Txt PIC X(01) VALUE 'E'. 05 F-Txt PIC X(01) VALUE 'F'. 05 G-Txt PIC X(01) VALUE 'G'. 05 H-Txt PIC X(01) VALUE 'H'. 05 I-Txt PIC X(01) VALUE 'I'. 05 J-Txt PIC X(01) VALUE 'J'. 05 K-Txt PIC X(01) VALUE 'K'. 05 L-Txt PIC X(01) VALUE 'L'. 05 M-Txt PIC X(01) VALUE 'M'. 05 N-Txt PIC X(01) VALUE 'N'. 05 O-Txt PIC X(01) VALUE 'O'. 05 P-Txt PIC X(01) VALUE 'P'. 05 Q-Txt PIC X(01) VALUE 'Q'. 05 R-Txt PIC X(01) VALUE 'R'. 05 S-Txt PIC X(01) VALUE 'S'. 05 T-Txt PIC X(01) VALUE 'T'. 05 U-Txt PIC X(01) VALUE 'U'. 05 V-Txt PIC X(01) VALUE 'V'. 05 W-Txt PIC X(01) VALUE 'W'. 05 X-Txt PIC X(01) VALUE 'X'. 05 Y-Txt PIC X(01) VALUE 'Y'. 05 Z-Txt PIC X(01) VALUE 'Z'. 01 REDEFINES Opt-Txts. 05 Opt-Txt OCCURS 26 PIC X(01). / 01 Pics. 05 Pic9 PIC 9. 05 Pic99 PIC 99. 05 Pic999 PIC 999. 05 Pic9999 PIC 9999. 05 Pic99999 PIC 99999. 05 Pic999999 PIC 999999. 05 PicPara PIC X(05). 05 PIC X(01). 05 PicX06 PIC X(06). 05 PicX12 PIC X(12). 05 PicZ9 PIC Z9. 05 PicZz9 PIC ZZ9. 05 PicZzz9 PIC ZZZ9. 05 PicZzzz9 PIC ZZZZ9. 05 PicZzzzz9 PIC ZZZZZ9. 05 PicZCzz9 PIC Z,ZZ9. 05 PicZzCzz9 PIC ZZ,ZZ9. 05 PicZzzCzz9 PIC ZZZ,ZZ9. 05 PicZCzzzCzz9 PIC Z,ZZZ,ZZ9. 05 PicZzCzzzCzz9 PIC ZZ,ZZZ,ZZ9. 05 PicZzzCzzzCzz9 PIC ZZZ,ZZZ,ZZ9. 05 PicZCzzzCzzzCzz9 PIC Z,ZZZ,ZZZ,ZZ9. 01 PicDateDisplay. 05 PicDate. 10 PicMM PIC 9(02). 10 PIC X(01) VALUE '/'. 10 PicDD PIC 9(02). 10 PIC X(01) VALUE '/'. 10 PicYY PIC 9(02). 10 PIC X(01) VALUE ' '. 05 PicTime. 10 PicHH PIC 9(02). 10 PIC X(01) VALUE ':'. 10 PicMins PIC 9(02). 10 PIC X(01) VALUE ':'. 10 PicSS PIC 9(02). 01 PicDateGenUsed PIC X(17) VALUE SPACES. 01 PicDateGenVersion PIC X(17) VALUE SPACES. 01 PicDateSystem. 05 PicCC PIC 9(02). 05 PicDate. 10 PicYY PIC 9(02). 10 PicMM PIC 9(02). 10 PicDD PIC 9(02). 05 PicTime. 10 PicHH PIC 9(02). 10 PicMins PIC 9(02). 10 PicSS PIC 9(02). / 01 TimeVars. 05 TimeBeg. 10 BegHH PIC 9(02). 10 BegMM PIC 9(02). 10 BegSS PIC 9(02). 10 BegHuns PIC 9(02). 05 TimeBegComp PIC 1(36) BINARY-1. 05 TimeDur. 10 DurHH PIC 9(02). 10 PIC X(01) VALUE ':'. 10 DurMM PIC 9(02). 10 PIC X(01) VALUE ':'. 10 DurSS PIC 9(02). 10 PIC X(01) VALUE '.'. 10 DurHuns PIC 9(02). 10 PIC X(01) VALUE ' '. 05 TimeDurComp PIC 1(36) BINARY-1. 05 TimeEnd. 10 EndHH PIC 9(02). 10 EndMM PIC 9(02). 10 EndSS PIC 9(02). 10 EndHuns PIC 9(02). 05 TimeEndComp PIC 1(36) BINARY-1. 01 VerifyTables. 05 TableIsAscending PIC 1(18) BINARY-1. 05 VerifyElt PIC X(12). 05 VerifyIdx PIC 1(18) BINARY-1. 05 VerifyPrev PIC X(32). 01 EndOfNonTableDBank PIC 1(36) BINARY-1. / 01 StartOfTableDBank PIC 1(36) BINARY-1. 01 DBankDirs. 05 DBankDirMax PIC 1(18) BINARY-1 VALUE 9. 05 DBankDirTot PIC 1(18) BINARY-1 VALUE 0. 05 DBankDirTbl OCCURS 0 TO 9 TIMES DEPENDING ON DBankDirTot INDEXED BY DBankDirIdx. 10 DBankDirFlag PIC X(06). 10 PIC X(01). 10 DBankDir PIC X(53). 01 DBankMins. 05 DBankMinMax PIC 1(18) BINARY-1 VALUE 5. 05 DBankMinTot PIC 1(18) BINARY-1 VALUE 0. 05 DBankMinTbl OCCURS 0 TO 5 TIMES DEPENDING ON DBankMinTot INDEXED BY DBankMinIdx. 10 DBankMinFlag PIC X(06). 10 PIC X(01). 10 DBankMin PIC 9(07). 10 PIC X(02). 01 GlobalDirs. 05 GlobalDirMax PIC 1(18) BINARY-1 VALUE 9. 05 GlobalDirTot PIC 1(18) BINARY-1 VALUE 0. 05 GlobalDirTbl OCCURS 0 TO 9 TIMES DEPENDING ON GlobalDirTot INDEXED BY GlobalDirIdx. 10 GlobalDirFlag PIC X(06). 10 PIC X(01). 10 GlobalDir PIC X(53). 01 GlobalLibs. 05 GlobalLibMax PIC 1(18) BINARY-1 VALUE 9. 05 GlobalLibTot PIC 1(18) BINARY-1 VALUE 0. 05 GlobalLibTbl OCCURS 0 TO 9 TIMES DEPENDING ON GlobalLibTot INDEXED BY GlobalLibIdx. 10 GlobalLibFlag PIC X(06). 10 PIC X(01). 10 GlobalLib PIC X(25). 01 IBankDirs. 05 IBankDirMax PIC 1(18) BINARY-1 VALUE 5. 05 IBankDirTot PIC 1(18) BINARY-1 VALUE 0. 05 IBankDirTbl OCCURS 0 TO 5 TIMES DEPENDING ON IBankDirTot INDEXED BY IBankDirIdx. 10 IBankDirFlag PIC X(06). 10 PIC X(01). 10 IBankDir PIC X(53). / 01 BegLinks. 05 BegLinkMax PIC 1(18) BINARY-1 VALUE 5. 05 BegLinkTot PIC 1(18) BINARY-1 VALUE 0. 05 BegLinkTbl OCCURS 0 TO 5 TIMES DEPENDING ON BegLinkTot INDEXED BY BegLinkIdx. 10 BegLinkFlag PIC X(06). 10 PIC X(01). 10 BegLinkDir PIC X(53). 01 MidLinks. 05 MidLinkMax PIC 1(18) BINARY-1 VALUE 5. 05 MidLinkTot PIC 1(18) BINARY-1 VALUE 0. 05 MidLinkTbl OCCURS 0 TO 5 TIMES DEPENDING ON MidLinkTot INDEXED BY MidLinkIdx. 10 MidLinkFlag PIC X(06). 10 PIC X(01). 10 MidLinkDir PIC X(53). 01 Usings. 05 UsingMax PIC 1(18) BINARY-1 VALUE 15. 05 UsingTot PIC 1(18) BINARY-1 VALUE 0. 05 UsingTbl OCCURS 0 TO 15 TIMES DEPENDING ON UsingTot INDEXED BY UsingIdx. 10 UsingFlag PIC X(06). 10 PIC X(01). 10 UsingDir PIC X(21). 01 MCores. 05 MCoreSizeX. 10 MCoreSize PIC 9(06) VALUE 0. 05 PIC X(02) VALUE ' '. 05 MCoreMax PIC 1(18) BINARY-1 VALUE 15. 05 MCoreTot PIC 1(18) BINARY-1 VALUE 0. 05 MCoreTbl OCCURS 0 TO 15 TIMES DEPENDING ON MCoreTot INDEXED BY MCoreIdx. 10 MCoreFlag PIC X(06). 10 PIC X(01). 10 MCoreAmt PIC 9(06). 10 PIC X(03). 01 EndLinks. 05 EndLinkMax PIC 1(18) BINARY-1 VALUE 15. 05 EndLinkTot PIC 1(18) BINARY-1 VALUE 0. 05 EndLinkTbl OCCURS 0 TO 15 TIMES DEPENDING ON EndLinkTot INDEXED BY EndLinkIdx. 10 EndLinkFlag PIC X(06). 10 PIC X(01). 10 EndLinkDir PIC X(53). / * This is not an OCCURS ... DEPENDING ON table because of the * the REDEFINES. "Flags" requires an exact match with TBL$ * as to the number and positions of flags, but not spellings. 01 Flags. 05 FlagMax PIC 1(18) BINARY-1 VALUE 19. 05 FlagTot PIC 1(18) BINARY-1 VALUE 0. 05 FlagTbl OCCURS 19 TIMES ASCENDING KEY IS FlagName INDEXED BY FlagIdx. 10 FlagName PIC X(06). 10 FlagSet PIC 1(18) BINARY-1. 10 FlagToBeCleared PIC 1(18) BINARY-1. 10 PIC X(02). / 01 REDEFINES Flags. 05 PIC X(04). 05 PIC X(06). 05 FlagAbsMap PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagAlways PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagDDef PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagDatabase PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagDps PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagMasm PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagMultibanked PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagNewMMS PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagNoPads PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagPads PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagPidTbl PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagPrtLnk PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagRDMS PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagRelMap PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagScreen PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagTip PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagTipLnk PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagTipLibRel PIC 1(18) BINARY-1. 05 PIC X(10). 05 FlagVersioned PIC 1(18) BINARY-1. 05 PIC X(04). / 01 Elts. 05 EltMax PIC 1(18) BINARY-1 VALUE 99. 05 EltTot PIC 1(18) BINARY-1 VALUE 0. 05 EltTbl OCCURS 1 TO 99 TIMES DEPENDING ON EltTot ASCENDING KEY IS EltName INDEXED BY EltIdx. 10 EltName PIC X(12). 10 EltFlag PIC 1(18) BINARY-1. True 88 EltWasReferenced VALUE 4060. 10 PIC X(01). 88 EltIsValid1 VALUES 'A' 'C' 'M' 'U'. 88 EltIsAcob VALUE 'A' 'C'. 88 EltIsAcobOnly VALUE 'A'. 88 EltIsCobol VALUE 'A' 'C' 'U'. 88 EltIsMasm VALUE 'M'. 88 EltIsUcob VALUE 'C' 'U'. 88 EltIsUcobOnly VALUE 'U'. 10 PIC X(01). 88 EltIsValid2 VALUES '1' 'D' 'S'. 88 EltIsSinglebanked VALUE '1'. 88 EltIsMultibanked VALUE 'D' 'S'. 88 EltIsMultibankedDyn VALUE 'D'. 88 EltIsMultibankedStat VALUE 'S'. 10 PIC X(01). 88 EltIsValid3 VALUES ' ' 'V'. 88 EltIsVersioned VALUE 'V'. 10 PIC X(01). 88 EltIsValid4 VALUES ' ' 'L'. 88 EltIsLast VALUE 'L'. 10 PIC X(02). 01 EltCalls. 05 EltCallsTarget. 10 EltCallsTargetElt PIC X(12). 10 EltCallsTarget01 PIC X(04). 05 EltCallsMax PIC 1(18) BINARY-1 VALUE 60. 05 EltCallsTot PIC 1(18) BINARY-1 VALUE 0. 05 EltCallsTbl OCCURS 1 TO 60 TIMES DEPENDING ON EltCallsTot ASCENDING KEY IS EltCallsKey INDEXED BY EltCallsIdx, EltCallsIdx2. 10 EltCallsKey. 15 EltCallsKeyElt PIC X(12). 15 PIC X(04). 10 EltCallsElt PIC X(12). / 01 Subrs. 05 SubrMax PIC 1(18) BINARY-1 VALUE 250. 05 SubrTot PIC 1(18) BINARY-1 VALUE 0. 05 SubrTbl OCCURS 1 TO 250 TIMES DEPENDING ON SubrTot ASCENDING KEY IS SubrName INDEXED BY SubrIdx. 10 SubrName PIC X(30). 10 PIC X(01). 10 SubrElt PIC X(12). 10 PIC X(01). 01 XRefs. 05 XRefMax PIC 1(18) BINARY-1 VALUE 200. 05 XRefTot PIC 1(18) BINARY-1 VALUE 0. 05 XRefTbl OCCURS 1 TO 200 TIMES DEPENDING ON XRefTot ASCENDING KEY IS XRefName INDEXED BY XRefIdx. 10 XRefName PIC X(30). 10 PIC X(01). 10 OCCURS 4. 15 XRefFlag PIC X(06). 15 XRefDelim PIC X(01). 10 PIC X(01). 01 EndOfTableDBank PIC 1(36) BINARY-1. 01 EndOfGensDBank PIC 1(36) BINARY-1. / * The following is not really in our DBank. It resides in a * separate compilation-unit GenCmpTables. It's defined here * so that we can use it. No VALUE clauses are allowed here. * It's sorta like LINKAGE, except that it's identified by * APPLY EXREF in the ENVIRONMENT DIVISION and defined in * WORKING-STORAGE, rather than being identified by PROCEDURE * DIVISION ... USING and defined in LINKAGE. * * Steve Seaquist * 07/13/1994 01 GenProdLibs. 05 ProdLibAsc PIC 1(06) BINARY-1. 05 ProdLibAts PIC 1(06) BINARY-1. 05 ProdLibCpf PIC 1(06) BINARY-1. 05 ProdLibDuo PIC 1(06) BINARY-1. 05 ProdLibMax PIC 1(06) BINARY-1. 05 ProdLibUcs PIC 1(06) BINARY-1. 05 ProdLibTbl OCCURS 1 TO 999 TIMES DEPENDING ON ProdLibMax ASCENDING KEY IS ProdLibUse INDEXED BY ProdLibIdx. 10 ProdLibUse PIC X(12). 10 ProdLibFile PIC X(24). 10 ProdLibOverride PIC 1(18) BINARY-1. 10 ProdLibRel PIC 1(18) BINARY-1. 10 ProdLibSeen PIC 1(18) BINARY-1. 10 ProdLibWeAsgdIt PIC 1(18) BINARY-1. / PROCEDURE DIVISION. 0000-Main-Section SECTION. 0000-Main. COPY UcsInitReg-Pd IN UCS-PROC. COPY PrePrm-Pd IN UCS-PROC. IF (NbrETs > 0) MOVE EltSlashVer (1) TO NameEltSelfUC. PERFORM 0010-Blank-Out-Unused-Opts. PERFORM 0020-Build-Gen-Opts. MOVE Gen-Opts TO Gen-Opts-All. MOVE ' ' TO A-Txt, U-Txt, Gen-Opts. PERFORM 0020-Build-Gen-Opts. MOVE FUNCTION WHEN-COMPILED TO PicDateSystem. MOVE CORRESPONDING PicDateSystem TO PicDateDisplay. MOVE PicDateDisplay TO PicDateGenVersion. ACCEPT PicDate OF PicDateSystem FROM DATE. ACCEPT PicTime OF PicDateSystem FROM TIME. MOVE CORRESPONDING PicDateSystem TO PicDateDisplay. MOVE PicDateDisplay TO PicDateGenUsed. MOVE SPACES TO NameGenSignon. STRING NameEltSelfUC DELIMITED BY ' ' ' (Gen Directives ' GenDir-Version ', created ' PicDateGenVersion ', used ' PicDateGenUsed ')' DELIMITED BY SIZE INTO NameGenSignon. DISPLAY NameGenSignon UPON Prtr-Out. (temp) DISPLAY 'GENDIR 1.4 fixes interpretted SQL subprograms calle' (temp) 'd by non-DB main progs, and ' UPON Prtr-Out. (temp) DISPLAY ' non-versioned UCOB main programs calling' (temp) ' versioned subprograms. ' UPON Prtr-Out. /0000-Main, continued: MOVE '@USE Ecl$.,My*Ecl$. . ' TO Acsf-Image. PERFORM 8030-ErAcsf. CALL 'AscFd' USING 4 'Ecl$' 12 Fitem-Pkt Dummy. PERFORM 8050-ErFitem. (asgd) IF (Fitem-Equip-Code > 0) (temp) AND (Fitem-Temporary > 0) PERFORM 8130-Get-QualFile ELSE MOVE '@USE Ecl$.,GenUtil*Ecl$. . ' TO Acsf-Image PERFORM 8030-ErAcsf MOVE '@ASG,A Ecl$. . ' TO Acsf-Image PERFORM 8030-ErAcsf PERFORM 8130-Get-QualFile . MOVE NameQualFile TO NameQualFileEcl. IF (H-Opt > 0) PERFORM 0030-Help-Mode ELSE PERFORM 0040-Process-Spec-Fields. COPY PostPr-Pd IN UCS-PROC. PERFORM 9000-Terminate. STOP RUN. / 0010-Blank-Out-Unused-Opts. PERFORM VARYING i FROM 1 BY 1 UNTIL i > 26 IF (Partbl-Opt (i) = 0) MOVE ' ' TO Opt-Txt (i) END-IF END-PERFORM. 0020-Build-Gen-Opts. MOVE 0 TO j. PERFORM VARYING i FROM 1 BY 1 UNTIL i > 26 IF (Opt-Txt (i) NOT = ' ') ADD 1 TO j MOVE Opt-Txt (i) TO Gen-Opts (j:1) END-IF END-PERFORM. / 0030-Help-Mode. DISPLAY 'Help Mode.' UPON Prtr-Out. DISPLAY 'A - ACOB, generate @MAP' UPON Prtr-Out. DISPLAY 'H - Help (display options)' UPON Prtr-Out. DISPLAY 'L - Long listings' UPON Prtr-Out. DISPLAY 'M - More longer listings' UPON Prtr-Out. DISPLAY 'N - No listings' UPON Prtr-Out. DISPLAY 'P - If non-DB main calls DB subprogram(s), ' 'gen to QUERY, else ignored' UPON Prtr-Out. DISPLAY 'R - If non-DB main calls DB subprogram(s), ' 'gen to both, else ignored' UPON Prtr-Out. DISPLAY 'T - If non-DB main calls DB subprogram(s), ' 'gen to TEST, else ignored' UPON Prtr-Out. DISPLAY 'U - UCOB, generate @LINK' UPON Prtr-Out. DISPLAY 'X - Don''t @ADD Map$.Add$' UPON Prtr-Out. DISPLAY 'Y - Non-reentrant map (TIP only)' UPON Prtr-Out. DISPLAY ' ' UPON Prtr-Out. DISPLAY 'TEST/QUERY/non-DB status of rel/OM is inferred ' 'from start of version name' UPON Prtr-Out. DISPLAY ' ' UPON Prtr-Out. / 0040-Process-Spec-Fields. CALL 'AscFd' USING 7 'CsInt$$' 12 Fitem-Pkt Dummy. PERFORM 8130-Get-QualFile. MOVE NameQualFile TO NameQualFileSelf. IF (Fitem-Temporary = 0) MOVE 1 TO HoldSelfIsCatd. CALL 'AscFd' USING 4 'SI$$' 12 Fitem-Pkt Dummy. PERFORM 8130-Get-QualFile. MOVE NameQualFile TO NameQualFileIn. MOVE NameQual TO NameQualIn. MOVE NameFile TO NameFileIn. MOVE 'SI$$' TO Toc-Pkt-Int-Filename. MOVE Si-Toc-Record TO Toc-Record. MOVE 'GENULD$' TO Toc-Rec-EltName. MOVE SPACES TO Toc-Rec-VerName. MOVE 1 TO Toc-Rec-Type. PERFORM Toc-Acc-Fetch-By-Name. IF (Toc-Pkt-Status = Toc-Con-Found) MOVE 1 TO HoldCardsExist. * GenApp-Pd must be PERFORM'd after establishing * NameQualFileEcl and NameQualFileIn: PERFORM GenApp-Pd. CALL 'AscFd' USING 4 'RO$$' 12 Fitem-Pkt Dummy. PERFORM 8130-Get-QualFile. MOVE NameQualFile TO NameQualFileOut. PERFORM 8110-Get-EltVerOut. Gen IF (Fitem-Needs-Write-Key > 0) keepa OR (Fitem-Write-Inhibited > 0) rollin PERFORM 0041-Warn-Output-To-Temp. PERFORM 4000-Map-Or-Link. 0041-Warn-Output-To-Temp. Gen DISPLAY NameQualFileOut 'is write-inhibited' UPON Prtr-Out. keepa DISPLAY 'Absolutes will go to the temporary file "Out.".' rollin UPON Prtr-Out. all night MOVE '@ASG,T Out.,F///9999' TO Acsf-Image. long. PERFORM 8030-ErAcsf. MOVE 'Out(0)' TO NameQualFileOut. / 4000-Map-Or-Link. MOVE '@ASG,T Map$.,F///262143' TO Acsf-Image. PERFORM 8030-ErAcsf. OPEN OUTPUT MapFile. IF (HoldSelfIsCatd > 0) AND (NameQualFileSelf (1:12) NOT = 'SYS$LIB$*SBA') MOVE '@FREE,AR CsInt$$.' TO MapRec WRITE MapRec. PERFORM 4001-Asg-ProdLibs. MOVE Si-Int-Filename TO Toc-Pkt-Int-Filename. MOVE Si-Toc-Record TO Toc-Record. IF (Toc-Rec-EltName = SPACES OR LOW-VALUES OR ALL '@') AND (Toc-Rec-VerName = SPACES OR LOW-VALUES OR ALL '@') MOVE 1 TO HoldMassCompile PERFORM 4003-Get-TimeBeg PERFORM 4005-Init-Tables PERFORM 4010-Mass-MapOrLink PERFORM 4004-Get-TimeEnd MOVE EltInCtr TO PicZzzCzz9 DISPLAY Indent 'in ' PicZzzCzz9 ' elt(s)' UPON Prtr-Out ELSE IF (NameEltIn (1:6) = 'D$WORK') MOVE SPACES TO MapRec STRING '@MSG,N ' DELIMITED BY SIZE NameEltSelfUC DELIMITED BY ' ' ' doesn''t process D$WORK''s directly.' DELIMITED BY SIZE INTO MapRec WRITE MapRec ELSE PERFORM 4003-Get-TimeBeg PERFORM 4005-Init-Tables PERFORM 4020-Single-MapOrLink PERFORM 4004-Get-TimeEnd . PERFORM 4002-Free-ProdLibs. CLOSE MapFile. IF (X-Opt > 0) DISPLAY 'No dynamic @ADD cuz of X-Opt.' UPON Prtr-Out DISPLAY 'Map ECL is in Map$.Add$' UPON Prtr-Out ELSE MOVE '@ADD,L Map$.Add$' TO Acsf-Image PERFORM 8030-ErAcsf. / 4001-Asg-ProdLibs. PERFORM VARYING ProdLibIdx FROM 1 BY 1 UNTIL ProdLibIdx > ProdLibMax MOVE 0 TO ProdLibWeAsgdIt (ProdLibIdx) IF (ProdLibRel (ProdLibIdx) = Gen-Con-True) MOVE ProdLibUse (ProdLibIdx) TO ConvertNameAscii CALL 'AscFd' USING 12 ConvertNameAscii 12 Fitem-Pkt Dummy PERFORM 8050-ErFitem IF (Fitem-Ext-Qualifier = LOW-VALUES) MOVE SPACES TO MapRec STRING '@USE ' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '.,' DELIMITED BY SIZE ProdLibFile (ProdLibIdx) DELIMITED BY ' ' '. . ' NameEltSelf ' doesn''t set up ' 'overrides libraries' DELIMITED BY SIZE INTO MapRec WRITE MapRec MOVE ProdLibFile (ProdLibIdx) TO NameQualFile ELSE Throw IF (Fitem-Equip-Code = 0) away MOVE 1 TO Fitem-Abs-FCyc FCyc. END-IF PERFORM 8131-Get-QualFile-NoFitem END-IF MOVE SPACES TO MapRec (asgd) IF (Fitem-Equip-Code > 0) STRING '@MSG,N ' ProdLibUse (ProdLibIdx) ' already assigned as ' DELIMITED BY SIZE NameQualFile DELIMITED BY ' ' INTO MapRec ELSE MOVE 1 TO StringPtr STRING '@ASG,A ' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr MOVE 42 TO StringPtr STRING '. ' NameQualFile DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr MOVE Gen-Con-True TO ProdLibWeAsgdIt (ProdLibIdx) END-IF WRITE MapRec END-IF END-PERFORM. / 4002-Free-ProdLibs. PERFORM VARYING ProdLibIdx FROM 1 BY 1 UNTIL ProdLibIdx > ProdLibMax IF (ProdLibWeAsgdIt (ProdLibIdx) = Gen-Con-True) MOVE SPACES TO MapRec STRING '@FREE,R ' DELIMITED BY SIZE ProdLibUse (ProdLibIdx) DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO MapRec WRITE MapRec END-IF END-PERFORM. / 4003-Get-TimeBeg. ACCEPT TimeBeg FROM TIME. COMPUTE TimeBegComp = (BegHH * 360000) + (BegMM * 6000) + (BegSS * 100) + BegHuns. 4004-Get-TimeEnd. ACCEPT TimeEnd FROM TIME. COMPUTE TimeEndComp = (EndHH * 360000) + (EndMM * 6000) + (EndSS * 100) + EndHuns. Crossd IF (TimeEndComp < TimeBegComp) midnit ADD 86400000 TO TimeEndComp. COMPUTE TimeDurComp = TimeEndComp - TimeBegComp. DIVIDE TimeDurComp BY 360000 GIVING DurHH REMAINDER TimeDurComp. DIVIDE TimeDurComp BY 6000 GIVING DurMM REMAINDER TimeDurComp. DIVIDE TimeDurComp BY 100 GIVING DurSS REMAINDER DurHuns. MOVE ExrefTotal TO PicZzzCzzzCzz9. MOVE SPACES TO Disp-Image. STRING NameEltSelf DELIMITED BY ' ' ' took ' TimeDur 'to analyze ' PicZzzCzzzCzz9 ' references.' DELIMITED BY SIZE INTO Disp-Image. DISPLAY Disp-Image UPON Prtr-Out. / * By empirical timing tests, I have determined that it takes * approximately 0.18 extra seconds to read our tables in from * an element, as compared to compiling them into the program. * In the long run, the ability to change map directives on the * fly will be far more useful than those missing 0.18 seconds. * * Steve Seaquist * 06/22/1994 4005-Init-Tables. MOVE ' 01 ' TO EltCallsTarget01. IF (1 = X-Opt AND L-Opt AND M-Opt) DISPLAY 'ECL$.TBL$1R3' UPON Prtr-Out. OPEN INPUT TblFile. MOVE 0 TO DBankDirTot, DBankMinTot, FlagTot, GlobalDirTot, GlobalLibTot, IBankDirTot, EltTot, EltCallsTot, SubrTot, XRefTot, HoldEof. MOVE SPACES TO NameOverflowed. PERFORM UNTIL (HoldEof > 0) READ TblFile AT END MOVE 1 TO HoldEof NOT AT END IF (1 = X-Opt AND L-Opt AND M-Opt) DISPLAY Indent TblRec UPON Prtr-Out END-IF IF (TblName (1:1) NOT = '.') PERFORM 4006-Init-Tbl-Line END-IF END-READ END-PERFORM. CLOSE TblFile. IF (NameOverflowed NOT = SPACES) DISPLAY Indent NameOverflowed ' overflow' UPON Prtr-Out PERFORM 9010-Terminate-In-Error STOP RUN. IF (0 < L-Opt AND X-Opt) PERFORM 8170-Verify-MapTables. / 4006-Init-Tbl-Line. EVALUATE FUNCTION UPPER-CASE (TblName) WHEN 'DBANKDIRS' IF (DBankDirTot < DBankDirMax) ADD 1 TO DBankDirTot MOVE TblContents TO DBankDirTbl (DBankDirTot) ELSE MOVE 'DBankDirs' TO NameOverflowed END-IF WHEN 'DBANKMINS' IF (DBankMinTot < DBankMinMax) ADD 1 TO DBankMinTot MOVE TblContents TO DBankMinTbl (DBankMinTot) ELSE MOVE 'DBankMins' TO NameOverflowed END-IF WHEN 'GLOBALDIRS' IF (GlobalDirTot < GlobalDirMax) ADD 1 TO GlobalDirTot MOVE TblContents TO GlobalDirTbl (GlobalDirTot) ELSE MOVE 'GlobalDirs' TO NameOverflowed END-IF WHEN 'GLOBALLIBS' IF (GlobalLibTot < GlobalLibMax) ADD 1 TO GlobalLibTot MOVE TblContents TO GlobalLibTbl (GlobalLibTot) ELSE MOVE 'GlobalLibs' TO NameOverflowed END-IF WHEN 'IBANKDIRS' IF (IBankDirTot < IBankDirMax) ADD 1 TO IBankDirTot MOVE TblContents TO IBankDirTbl (IBankDirTot) ELSE MOVE 'IBankDirs' TO NameOverflowed END-IF /4006-Init-Tbl-Line, continued: WHEN 'BEGLINKS' IF (BegLinkTot < BegLinkMax) ADD 1 TO BegLinkTot MOVE TblContents TO BegLinkTbl (BegLinkTot) ELSE MOVE 'BegLinks' TO NameOverflowed END-IF WHEN 'MIDLINKS' IF (MidLinkTot < MidLinkMax) ADD 1 TO MidLinkTot MOVE TblContents TO MidLinkTbl (MidLinkTot) ELSE MOVE 'MidLinks' TO NameOverflowed END-IF WHEN 'USINGS' IF (UsingTot < UsingMax) ADD 1 TO UsingTot MOVE TblContents TO UsingTbl (UsingTot) ELSE MOVE 'Usings' TO NameOverflowed END-IF WHEN 'MCORES' IF (MCoreTot < MCoreMax) ADD 1 TO MCoreTot MOVE TblContents TO MCoreTbl (MCoreTot) ELSE MOVE 'MoreCore' TO NameOverflowed END-IF WHEN 'ENDLINKS' IF (EndLinkTot < EndLinkMax) ADD 1 TO EndLinkTot MOVE TblContents TO EndLinkTbl (EndLinkTot) ELSE MOVE 'EndLinks' TO NameOverflowed END-IF /4006-Init-Tbl-Line, continued: WHEN 'FLAGS' IF (FlagTot < FlagMax) ADD 1 TO FlagTot MOVE TblContents TO FlagTbl (FlagTot) ELSE MOVE 'Flags' TO NameOverflowed END-IF WHEN 'ELTS' IF (EltTot < EltMax) ADD 1 TO EltTot MOVE TblContents TO EltTbl (EltTot) ELSE MOVE 'Elts' TO NameOverflowed END-IF WHEN 'ELTCALLS' IF (EltCallsTot < EltCallsMax) ADD 1 TO EltCallsTot MOVE TblContents TO EltCallsTbl (EltCallsTot) ELSE MOVE 'EltCalls' TO NameOverflowed END-IF WHEN 'SUBRS' IF (SubrTot < SubrMax) ADD 1 TO SubrTot MOVE TblContents TO SubrTbl (SubrTot) ELSE MOVE 'Subrs' TO NameOverflowed END-IF WHEN 'XREFS' IF (XRefTot < XRefMax) ADD 1 TO XRefTot MOVE TblContents TO XRefTbl (XRefTot) ELSE MOVE 'XRefs' TO NameOverflowed END-IF WHEN OTHER DISPLAY 'Unknown TBL$ entry: ' TblRec UPON Prtr-Out PERFORM 9010-Terminate-In-Error STOP RUN END-EVALUATE. / 4010-Mass-MapOrLink. DISPLAY 'No SI element name, assuming mass map/link mode:' UPON Prtr-Out. IF (NOT (NameEltVerOut = SPACES OR 'T' OR 'X')) DISPLAY 'RO element name ("' NameEltVerOut '") ignored in mass map/links.' UPON Prtr-Out MOVE SPACES TO NameEltVerOut. PERFORM Toc-Acc-Open-Retr. IF (Toc-Pkt-Status = Toc-Con-NoErr) PERFORM Toc-Acc-Fetch-Frst PERFORM 4012-Mass-MapOrLink-Loop UNTIL (Toc-Pkt-Status NOT = Toc-Con-Found) IF (Toc-Pkt-Status = Toc-Con-AtEnd) PERFORM Toc-Acc-Close IF (Toc-Pkt-Status = Toc-Con-NoErr) NEXT SENTENCE ELSE DISPLAY Toc-Pkt-Status-Text UPON Prtr-Out ELSE DISPLAY Toc-Pkt-Status-Text UPON Prtr-Out ELSE DISPLAY Toc-Pkt-Status-Text UPON Prtr-Out . 4012-Mass-MapOrLink-Loop. IF (Toc-Rec-DeleteFlag = 0) IF (Toc-Rec-Is-Rel) AND (Toc-Rec-EltName (1:6) NOT = 'D$WORK') AND (Toc-Rec-EltName (7:6) NOT = 'SYSDTA') MOVE 'Relocatable' TO HoldEltType (1:12) PERFORM 4014-Mass-MapOrLink-DoIt ELSE IF (Toc-Rec-Is-Abs AND Toc-Rec-Is-OM) MOVE 'Object Module' TO HoldEltType (1:14) PERFORM 4014-Mass-MapOrLink-DoIt. PERFORM Toc-Acc-Fetch-Next. 4014-Mass-MapOrLink-DoIt. PERFORM 8100-Get-EltVerIn. ADD 1 TO EltInCtr. PERFORM 4050-Process-Elt. / 4020-Single-MapOrLink. IF (U-Opt > 0) (abs) MOVE 6 TO Toc-Rec-Type MOVE 'Object Module' TO HoldEltType (1:14) ELSE (rel) MOVE 5 TO Toc-Rec-Type MOVE 'Relocatable' TO HoldEltType (1:12) . PERFORM 8100-Get-EltVerIn. PERFORM Toc-Acc-Fetch-By-Name. IF (Toc-Pkt-Status = Toc-Con-Found) PERFORM 4050-Process-Elt ELSE IF (Toc-Pkt-Status = Toc-Con-NotFound) PERFORM 4021-Couldnt-Find-Elt ELSE DISPLAY Toc-Pkt-Status-Text UPON Prtr-Out PERFORM 9010-Terminate-In-Error STOP RUN. 4021-Couldnt-Find-Elt. MOVE SPACES TO Disp-Image. STRING HoldEltType DELIMITED BY LOW-VALUE NameEltVerIn DELIMITED BY ' ' ' could not be found in file ' DELIMITED BY SIZE NameQualFileIn DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO Disp-Image. DISPLAY Disp-Image UPON Prtr-Out. PERFORM 9010-Terminate-In-Error. STOP RUN. / 4050-Process-Elt. MOVE SPACES TO Disp-Image. STRING 'Scanning ' DELIMITED BY SIZE HoldEltType DELIMITED BY LOW-VALUE NameEltVerIn DELIMITED BY ' ' INTO Disp-Image. DISPLAY Disp-Image UPON Prtr-Out. MOVE LOW-VALUES TO EltRelatedInfo. PERFORM 8190-Zero-Out-Flags. IF (Toc-Rec-Is-Rel) PERFORM 5000-Process-Rel ELSE IF (Toc-Rec-Is-Abs AND Toc-Rec-Is-OM) PERFORM 6000-Process-Obj ELSE DISPLAY Indent 'Elt not typed as Rel or un-linked OM' UPON Prtr-Out. / 5000-Process-Rel. Does SEARCH ALL EltTbl not WHEN EltName (EltIdx) = NameEltIn apply IF EltIsMultibanked (EltIdx) to MOVE Gen-Con-True TO FlagRelMap UCOB. END-IF. IF (V-Opt > 0) AND (FlagRelMap NOT = Gen-Con-True) PERFORM 5001-Copy-Singlebanked-Rels ELSE PERFORM 5005-Map-Everybody-Else. ADD ExrefTotalInElt TO ExrefTotal. 5001-Copy-Singlebanked-Rels. IF (NameQualFileIn NOT = NameQualFileOut) PERFORM 5002-Copy-Necessary. MOVE '@MSG,N GEN doesn''t @MAP,R this pgm' TO MapRec. WRITE MapRec. / 5002-Copy-Necessary. MOVE NameEltIn TO NameEltSysdta. INSPECT NameEltSysdta CONVERTING ' ' TO '$'. MOVE 'SYSDTA' TO NameEltSysdta (7:6). IF (NameVerIn = SPACES) MOVE NameEltSysdta TO NameEltVerInSysdta ELSE MOVE SPACES TO NameEltVerInSysdta STRING NameEltSysdta DELIMITED BY ' ' '/' DELIMITED BY SIZE NameVerIn DELIMITED BY ' ' INTO NameEltVerInSysdta. MOVE SPACES TO MapRec. MOVE 1 TO StringPtr. STRING '@COPY,R ' DELIMITED BY SIZE NameQualFileIn DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr. MOVE StringPtr TO PrevStringPtr. STRING NameEltVerIn DELIMITED BY ' ' ',' DELIMITED BY SIZE NameQualFileOut DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr. WRITE MapRec. STRING NameEltVerInSysdta DELIMITED BY ' ' ',' DELIMITED BY SIZE NameQualFileOut DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO MapRec WITH POINTER PrevStringPtr. WRITE MapRec. / 5005-Map-Everybody-Else. IF (Toc-Rec-RelPreLen > Io-Buf-Size) DISPLAY Indent 'GEN can''t process > 890 entry pts' UPON Prtr-Out PERFORM 9010-Terminate-In-Error STOP RUN. PERFORM 8060-ErIo-Init. CALL 'AscFd' USING 4 'SI$$' 12 Io-Pkt Dummy. R$ MOVE Io-Func-R TO Io-Pkt-Function. MOVE Toc-Rec-RelPreAddr TO Io-Pkt-Sector-Addr. COMPUTE Io-Pkt-Buf-Len = Toc-Rec-RelPreLen * 28. PERFORM 8070-ErIow. MOVE Io-Buf-Word (2) TO ExrefTableInfo. COMPUTE j = ExrefOffset + 1. IF (X-Opt > 0) DISPLAY 'External References:' UPON Prtr-Out. PERFORM 5010-Process-XRef VARYING i FROM 1 BY 1 UNTIL i > ExrefTotalInElt. PERFORM VARYING i FROM 1 BY 1 UNTIL i > FlagTot IF (FlagToBeCleared (i) = Gen-Con-True) MOVE 0 TO FlagSet (i) END-IF END-PERFORM. * Don't multibank TIP programs, so that they will load faster. * Also, my ACOB 6R2 PRM says that PADS is not supported for * ACOB TIP. (P.S.: It **is** supported for UCOB TIP.) IF (FlagTip = Gen-Con-True) MOVE 0 TO FlagMultibanked, FlagPads. MOVE Gen-Con-True TO FlagAlways. /5005-Map-Everyone-Else, continued: IF (X-Opt > 0) DISPLAY 'Flags:' UPON Prtr-Out PERFORM VARYING i FROM 1 BY 1 UNTIL i > FlagTot IF (FlagSet (i) = Gen-Con-True) DISPLAY Indent FlagName (i) UPON Prtr-Out END-IF END-PERFORM DISPLAY 'Rels:' UPON Prtr-Out PERFORM VARYING i FROM 1 BY 1 UNTIL i > EltTot IF (EltWasReferenced (i)) DISPLAY Indent EltName (i) UPON Prtr-Out END-IF END-PERFORM DISPLAY 'Info Table:' UPON Prtr-Out. PERFORM 5040-Process-InfoTable. IF (FlagDatabase = Gen-Con-True) PERFORM 5050-Get-NameSubschema. IF (Gen-Con-True = FlagAbsMap OR FlagRelMap) PERFORM 5500-Generate-Map ELSE PERFORM 5001-Copy-Singlebanked-Rels. / 5010-Process-XRef. MOVE Io-Buf-Word (j) TO ConvertNameFd (1:4). ADD 1 TO j. MOVE Io-Buf-Word (j) TO ConvertNameFd (5:4). ADD 1 TO j. CALL 'FdAsc' USING 12 ConvertNameFd 12 ConvertNameAscii Dummy. MOVE ConvertNameAscii TO NameXRef. IF (X-Opt > 0) DISPLAY Indent NameXRef UPON Prtr-Out. IF (NameXRef (7:6) = 'C$MENT') MOVE Gen-Con-True TO FlagAbsMap ELSE PERFORM 8140-Process-NameXRef. / 5040-Process-InfoTable. MOVE Io-Buf-Word (4) TO InfoTableInfo. COMPUTE j = InfoOffset + 1. IF (X-Opt > 0) AND (InfoTotal > 0) DISPLAY 'Control Table:' UPON Prtr-Out. PERFORM 5041-Process-InfoItem VARYING i FROM 1 BY 1 UNTIL i > InfoTotal. 5041-Process-InfoItem. MOVE Io-Buf-S1 (j + 2) TO Pic99. IF (X-Opt > 0) DISPLAY Indent 'Info group ' Pic99 UPON Prtr-Out. IF (Pic99 = 12) ADD 8 TO j ELSE ADD 4 TO j IF (Pic99 = 4) MOVE 1 TO HoldUsesCommon. / 5050-Get-NameSubschema. MOVE 'D$WORK' TO Toc-Rec-EltName. MOVE NameEltIn TO Toc-Rec-EltName (7:6). PERFORM Toc-Acc-Fetch-By-Name. IF (Toc-Pkt-Status = Toc-Con-Found) PERFORM 5051-Process-DWork ELSE IF (Toc-Pkt-Status = Toc-Con-NotFound) PERFORM 5052-Couldnt-Find-DWork ELSE DISPLAY Toc-Pkt-Status-Text UPON Prtr-Out. 5051-Process-DWork. MOVE 28 TO Io-Pkt-Buf-Len. MOVE Toc-Rec-TextAddr TO Io-Pkt-Sector-Addr. PERFORM 8070-ErIow. revers MOVE Io-Buf (45:4) TO ConvertNameFd (1:4). order MOVE Io-Buf (41:4) TO ConvertNameFd (5:4). CALL 'FdAsc' USING 12 ConvertNameFd 12 ConvertNameAscii Dummy. MOVE ConvertNameAscii TO NameSubschema. DISPLAY Indent 'S$WORK/' NameSubschema UPON Prtr-Out. 5052-Couldnt-Find-DWork. DISPLAY 'END Msg: D$WORK not found in ' NameQualFileIn UPON Prtr-Out. DISPLAY 'END Msg: (Usual cause is ProgId not = to EltName)' UPON Prtr-Out. PERFORM 9010-Terminate-In-Error. STOP RUN. / 5500-Generate-Map. IF NameVerIn (1:GenAppLenProd) = GenAppQualProd MOVE GenAppQualProd TO NameAppGroup, NameAppGroupIn MOVE GenAppQualProdRSA TO NameAppGroupRS MOVE GenAppFileProdDmrmt TO NameDmrmt MOVE NameVerIn (GenAppLenProd + 1:) TO NameVerInOrig PERFORM 5510-Do-Generate-Map ELSE IF NameVerIn (1:GenAppLenProdComp) = GenAppQualProdComp MOVE GenAppQualProd TO NameAppGroup MOVE GenAppQualProdComp TO NameAppGroupIn MOVE GenAppQualProdRSA TO NameAppGroupRS MOVE GenAppFileProdDmrmt TO NameDmrmt MOVE NameVerIn (GenAppLenProdComp + 1:) TO NameVerInOrig PERFORM 5510-Do-Generate-Map ELSE IF NameVerIn (1:GenAppLenTest) = GenAppQualTest MOVE GenAppQualTest TO NameAppGroup, NameAppGroupIn MOVE GenAppQualTestRSA TO NameAppGroupRS MOVE GenAppFileTestDmrmt TO NameDmrmt MOVE NameVerIn (GenAppLenTest + 1:) TO NameVerInOrig PERFORM 5510-Do-Generate-Map ELSE IF NameVerIn (1:GenAppLenTestComp) = GenAppQualTestComp MOVE GenAppQualTest TO NameAppGroup MOVE GenAppQualTestComp TO NameAppGroupIn MOVE GenAppQualTestRSA TO NameAppGroupRS MOVE GenAppFileTestDmrmt TO NameDmrmt MOVE NameVerIn (GenAppLenTestComp + 1:) TO NameVerInOrig PERFORM 5510-Do-Generate-Map ELSE PERFORM 5501-Generate-Map-RelHasNoApp. / 5501-Generate-Map-RelHasNoApp. MOVE NameVerIn TO NameVerInOrig. IF (FlagVersioned = Gen-Con-True) PERFORM 5502-Generate-Map-ButSubrsDo ELSE MOVE SPACES TO NameAppGroup, NameAppGroupIn PERFORM 5510-Do-Generate-Map. 5502-Generate-Map-ButSubrsDo. IF (0 < T-Opt OR R-Opt) OR (0 = P-Opt) MOVE GenAppQualTest TO NameAppGroup, NameAppGroupIn MOVE GenAppQualTestRSA TO NameAppGroupRS MOVE GenAppFileTestDmrmt TO NameDmrmt If 2 outs, IF (0 < R-Opt) OR (0 < P-Opt AND T-Opt) gener8 MOVE SPACES TO NameEltVerOut names. END-IF PERFORM 5510-Do-Generate-Map. * In GEN, if there's only one app group, we suppress a release * gen's test compile in favor of its prod compile, because the * prod compile will have the detail we expect in a release gen. * But here we suppress the prod map, because test maps and * prod maps have equal detail, and test maps are the default. * It simplifies the logic considerably to do it this way. IF (GenAppNbrTest NOT = GenAppNbrProd) AND (0 < P-Opt OR R-Opt) MOVE GenAppQualProd TO NameAppGroup, NameAppGroupIn MOVE GenAppQualProdRSA TO NameAppGroupRS MOVE GenAppFileProdDmrmt TO NameDmrmt If 2 outs, IF (0 < R-Opt) OR (0 < P-Opt AND T-Opt) gener8 MOVE SPACES TO NameEltVerOut names. END-IF PERFORM 5510-Do-Generate-Map. / 5510-Do-Generate-Map. PERFORM 8090-Get-EltVerAbs. MOVE '@DELETE,RV TPF$./************ . Prevents conflicts' TO MapRec. WRITE MapRec. MOVE '@PREP TPF$.' TO MapRec. WRITE MapRec. MOVE SPACES TO MapRec. MOVE 1 TO StringPtr. STRING '@HDG,P *** Mapping ' DELIMITED BY SIZE NameEltIn DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr. IF (NameAppGroup NOT = SPACES) STRING ' to ' DELIMITED BY SIZE NameAppGroup DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr. STRING ' ***' DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr. WRITE MapRec. /5510-Do-Generate-Map, continued: IF (FlagRelMap = Gen-Con-True) MOVE '@MAP,IR' TO MapRec MOVE 8 TO StringPtr ELSE MOVE '@MAP,I' TO MapRec MOVE 7 TO StringPtr. IF (L-Opt > 0) OR (R-Opt > 0) MOVE 'L' TO Map-Opt-List ELSE IF (N-Opt > 0) MOVE 'N' TO Map-Opt-List ELSE MOVE 'S' TO Map-Opt-List. MOVE Map-Opt-List TO MapRec (StringPtr:1). MOVE 11 TO StringPtr. STRING NameQualFileIn DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltIn DELIMITED BY ' ' '/' DELIMITED BY SIZE NameAppGroup DELIMITED BY ' ' 'MAP,;' DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr. WRITE MapRec. MOVE SPACES TO MapRec. MOVE 11 TO StringPtr. STRING NameQualFileOut DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltVerAbs DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr. WRITE MapRec. /5510-Do-Generate-Map, continued: IF (FlagRelMap = Gen-Con-True) PERFORM 5520-Global-Dirs PERFORM 5530-Global-Libs PERFORM 5540-RelMap-Dirs PERFORM 5560-Singlebanked-Rels PERFORM 5590-Subroutine-Data PERFORM 5600-Database-Dirs PERFORM 5620-RelMap-Last ELSE PERFORM 5520-Global-Dirs PERFORM 5530-Global-Libs PERFORM 5550-AbsMap-IBank PERFORM 5560-Singlebanked-Rels PERFORM 5570-Multibanked-Rels PERFORM 5580-AbsMap-DBank PERFORM 5590-Subroutine-Data PERFORM 5600-Database-Dirs PERFORM 5610-AbsMap-DBank-Dirs . MOVE 'END' TO MapRec. WRITE MapRec. * If this is a one-app-group-only system, users don't want to * be bothered with app-group-related version names on ABS's. IF (GenAppNbrTest = GenAppNbrProd) AND (FlagRelMap NOT = Gen-Con-True) AND (NameAppGroup NOT = SPACES) MOVE SPACES TO MapRec MOVE 1 TO StringPtr STRING '@CHG,A ' DELIMITED BY SIZE NameQualFileOut DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltVerAbs DELIMITED BY ' ' ',.' DELIMITED BY SIZE NameEltIn DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr IF (NameVerInOrig NOT = SPACES) STRING '/' DELIMITED BY SIZE NameVerInOrig DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr END-IF WRITE MapRec. / 5520-Global-Dirs. PERFORM VARYING GlobalDirIdx FROM 1 BY 1 UNTIL GlobalDirIdx > GlobalDirTot MOVE '5520-' TO PicPara MOVE GlobalDirFlag (GlobalDirIdx) TO PicX06 PERFORM 8150-Search-FlagTbl IF (FlagSet (Pic99) = Gen-Con-True) MOVE GlobalDir (GlobalDirIdx) TO MapRec WRITE MapRec END-IF END-PERFORM. / 5530-Global-Libs. IF (FlagRelMap NOT = Gen-Con-True) MOVE 'RLIB (I$1/$ODD,D$1/$EVEN)' TO MapRec WRITE MapRec. PERFORM VARYING GlobalLibIdx FROM 1 BY 1 UNTIL GlobalLibIdx > GlobalLibTot MOVE '5530-' TO PicPara MOVE GlobalLibFlag (GlobalLibIdx) TO PicX06 PERFORM 8150-Search-FlagTbl IF (FlagSet (Pic99) = Gen-Con-True) * From the propositional calculus, ((NOT A) OR B) defines * "A implies B". Don't worry. This correctly eliminates * the APPGROUP$ directive when FlagVersioned isn't true: AND ((GlobalLib (GlobalLibIdx) NOT = 'APPGROUP$') OR (FlagVersioned = Gen-Con-True)) MOVE 'RLIB' TO MapRec MOVE 11 TO StringPtr PERFORM 5531-Global-Libs-Format IF (FlagRelMap NOT = Gen-Con-True) STRING '()' DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr END-IF WRITE MapRec END-IF END-PERFORM. / 5531-Global-Libs-Format. IF (FlagVersioned = Gen-Con-True) EVALUATE GlobalLib (GlobalLibIdx) (1:1) WHEN '*' STRING NameAppGroup DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr PERFORM 5532-Global-Libs-UseName WHEN '%' STRING NameAppGroupIn DELIMITED BY ' ' '*' DELIMITED BY SIZE GlobalLib (GlobalLibIdx) (2:) DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr WHEN '^' STRING NameAppGroupRS DELIMITED BY ' ' '*' DELIMITED BY SIZE GlobalLib (GlobalLibIdx) (2:) DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr WHEN OTHER PERFORM 5532-Global-Libs-UseName END-EVALUATE ELSE PERFORM 5532-Global-Libs-UseName. 5532-Global-Libs-UseName. IF (GlobalLib (GlobalLibIdx) = 'APPGROUP$') STRING NameAppGroup DELIMITED BY ' ' '$' DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr ELSE STRING GlobalLib (GlobalLibIdx) DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr. / 5540-RelMap-Dirs. PERFORM VARYING SubrIdx FROM 1 BY 1 UNTIL SubrIdx > SubrTot IF (SubrElt (SubrIdx) = NameEltIn) PERFORM 5541-RelMap-DEFs END-IF END-PERFORM. MOVE NameEltIn TO NameEltSysdta. INSPECT NameEltSysdta CONVERTING ' ' TO '$'. MOVE 'SYSDTA' TO NameEltSysdta (7:6). MOVE ' IN ' TO MapRec. MOVE 11 TO StringPtr. STRING NameQualFileIn DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltVerIn DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr. IF (NameVerIn = SPACES) AND (FlagVersioned = Gen-Con-True) STRING '/,.' DELIMITED BY SIZE NameEltSysdta DELIMITED BY ' ' '/ . forced slash resolves ambiguity' DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr ELSE IF (NameVerIn = SPACES) STRING ',.' DELIMITED BY SIZE NameEltSysdta DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr ELSE STRING ',.' DELIMITED BY SIZE NameEltSysdta DELIMITED BY ' ' '/' DELIMITED BY SIZE NameVerIn DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr. WRITE MapRec. / 5541-RelMap-DEFs. MOVE SubrName (SubrIdx) TO NameEntry. MOVE 0 TO Tally. INSPECT NameEntry TALLYING Tally FOR CHARACTERS BEFORE ' '. MOVE 'C$B' TO NameEntryCB (1:3). IF (Tally < 10) MOVE NameEntry TO NameEntryCB (4:) ELSE MOVE NameEntry (1:3) TO NameEntryCB (4:3) SUBTRACT 5 FROM Tally MOVE NameEntry (Tally:) TO NameEntryCB (7:). MOVE SPACES TO MapRec. STRING ' DEF ' DELIMITED BY SIZE NameEntry DELIMITED BY ' ' ',' DELIMITED BY SIZE INTO MapRec. Pretty MOVE NameEntryCB TO MapRec (24:). WRITE MapRec. / 5550-AbsMap-IBank. MOVE 'IBANK,UX C$DML' TO MapRec. WRITE MapRec. IF (FlagTip = Gen-Con-True) AND (Y-Opt = 0) MOVE 'IBANK,MRC I$1,022000' TO MapRec ELSE MOVE 'IBANK,MR I$1,022000' TO MapRec. WRITE MapRec. MOVE 1 TO HoldIBankNo. MOVE SPACES TO MapRec. STRING ' IN ' DELIMITED BY SIZE NameQualFileIn DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltVerIn DELIMITED BY ' ' INTO MapRec. WRITE MapRec. PERFORM VARYING IBankDirIdx FROM 1 BY 1 UNTIL IBankDirIdx > IBankDirTot MOVE '5550-' TO PicPara MOVE IBankDirFlag (IBankDirIdx) TO PicX06 PERFORM 8150-Search-FlagTbl IF (FlagSet (Pic99) = Gen-Con-True) MOVE IBankDir (IBankDirIdx) TO MapRec WRITE MapRec END-IF END-PERFORM. / 5560-Singlebanked-Rels. * We can't do an Inline PERFORM here because the compound IF * cannot be END-IF'd. (END-IF isn't permitted in an IF that * contains NEXT SENTENCE, so there's no way to END-IF the * inner IF, leaving us no way to tell the compiler that the * outer IF is END-IF'd before the PERFORM.) PERFORM 5561-See-Whether-To-IN VARYING EltIdx FROM 1 BY 1 UNTIL EltIdx > EltTot. 5561-See-Whether-To-IN. IF (EltWasReferenced (EltIdx)) AND (EltIsSinglebanked (EltIdx)) RelMap gets IF (EltIsLast (EltIdx)) "Last" AND (FlagRelMap = Gen-Con-True) elt(s) last. NEXT SENTENCE See 5590-. ELSE MOVE EltName (EltIdx) TO NameEltSubr PERFORM 8180-Write-In-NameEltSubr . / 5570-Multibanked-Rels. PERFORM VARYING EltIdx FROM 1 BY 1 UNTIL EltIdx > EltTot IF (EltWasReferenced (EltIdx)) AND (EltIsMultibanked (EltIdx)) IF (FlagMultibanked = Gen-Con-True) ADD 1 TO HoldIBankNo MOVE 'IBANK,R' TO MapRec MOVE 8 TO StringPtr IF (EltIsMultibankedDyn (EltIdx)) STRING 'D' DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr END-IF MOVE 11 TO StringPtr STRING 'I$' DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr IF (HoldIBankNo < 10) STRING HoldIBankNo9 DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr ELSE STRING HoldIBankNo DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr END-IF STRING ',022000' DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr WRITE MapRec END-IF MOVE EltName (EltIdx) TO NameEltSubr PERFORM 8180-Write-In-NameEltSubr END-IF END-PERFORM. / 5580-AbsMap-DBank. MOVE SPACES TO NameDBankMin. PERFORM VARYING DBankMinIdx FROM 1 BY 1 UNTIL DBankMinIdx > DBankMinTot MOVE '5580-' TO PicPara MOVE DBankMinFlag (DBankMinIdx) TO PicX06 PERFORM 8150-Search-FlagTbl IF (FlagSet (Pic99) = Gen-Con-True) AND (DBankMin (DBankMinIdx) > NameDBankMin) MOVE DBankMin (DBankMinIdx) TO NameDBankMin END-IF END-PERFORM. IF (FlagTip = Gen-Con-True) AND (Y-Opt = 0) MOVE 'DBANK,MU D$1' TO MapRec ELSE MOVE 'DBANK,MUC D$1' TO MapRec. IF (NameDBankMin NOT = SPACES) MOVE 14 TO StringPtr STRING ',(' DELIMITED BY SIZE NameDBankMin DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr PERFORM 5581-AbsMap-DBank-AddrList VARYING i FROM 1 BY 1 UNTIL i > HoldIBankNo MOVE ')' TO MapRec (StringPtr:1) . WRITE MapRec. IF (FlagTip = Gen-Con-True) AND (Y-Opt = 0) MOVE SPACES TO MapRec STRING ' IN ' DELIMITED BY SIZE NameQualFileIn DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltVerIn DELIMITED BY ' ' INTO MapRec WRITE MapRec MOVE ' IN MEM$ERR' TO MapRec WRITE MapRec. IF (HoldUsesCommon > 0) MOVE ' IN BLANK$COMMON' TO MapRec WRITE MapRec. / 5581-AbsMap-DBank-AddrList. MOVE ',' TO MapRec (StringPtr:1). ADD 1 TO StringPtr. IF (StringPtr > 70) MOVE ';' TO MapRec (StringPtr:1) WRITE MapRec MOVE SPACES TO MapRec MOVE 16 TO StringPtr. IF (i < 10) MOVE i TO Pic9 STRING 'I$' Pic9 DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr ELSE MOVE i TO Pic99 STRING 'I$' Pic99 DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr . / 5590-Subroutine-Data. * We can't do an Inline PERFORM here because the compound IF * cannot be END-IF'd. (END-IF isn't permitted in an IF that * contains NEXT SENTENCE, so there's no way to END-IF the * middle IF, leaving us no way to tell the compiler that the * outer IF is END-IF'd before the PERFORM.) PERFORM 5591-See-Whether-To-IN VARYING EltIdx FROM 1 BY 1 UNTIL EltIdx > EltTot. 5591-See-Whether-To-IN. IF (EltWasReferenced (EltIdx)) MB's IF (FlagRelMap = Gen-Con-True) IN'd AND ( EltIsMultibanked (EltIdx) in abs OR EltIsMasm (EltIdx)) map, not NEXT SENTENCE in rel map. ELSE MOVE EltName (EltIdx) TO NameEltSubr IF (EltIsSinglebanked (EltIdx)) AND (EltIsAcob (EltIdx)) INSPECT NameEltSubr CONVERTING ' ' TO '$' MOVE 'SYSDTA' TO NameEltSubr (7:) END-IF PERFORM 8180-Write-In-NameEltSubr . / 5600-Database-Dirs. IF (FlagDatabase = Gen-Con-True) PERFORM 5601-Database-Dirs. 5601-Database-Dirs. MOVE SPACES TO MapRec. STRING ' IN ' DELIMITED BY SIZE NameQualFileIn DELIMITED BY ' ' '.D$WORK' DELIMITED BY SIZE NameEltIn (1:6) DELIMITED BY ' ' '/' DELIMITED BY SIZE NameVerIn DELIMITED BY ' ' INTO MapRec. WRITE MapRec. MOVE SPACES TO MapRec. STRING ' IN ' DELIMITED BY SIZE NameAppGroup DELIMITED BY ' ' '*' DELIMITED BY SIZE NameDmrmt DELIMITED BY ' ' '.CBEP$$DMS,.CLSEG$' DELIMITED BY SIZE INTO MapRec. WRITE MapRec. IF (GenSchTot = 1) MOVE GenSchFile (1) TO NameSchemaFile ELSE PERFORM 5602-Search-GenSchTbl. MOVE SPACES TO MapRec. STRING ' IN ' DELIMITED BY SIZE NameAppGroupIn DELIMITED BY ' ' '*' DELIMITED BY SIZE NameSchemaFile DELIMITED BY ' ' '.S$WORK/' DELIMITED BY SIZE NameSubschema DELIMITED BY ' ' INTO MapRec. WRITE MapRec. / * The following code searches the schema filenames in GENAPP$ * to see if a rel named S$WORK/<> is there. * * We use ER PFS$, not Toc-Acc-Fetch-By-Name, because we could * be in the middle of a mass map/link. Also, why bother going * thru the overhead of TocSub when PFS$ is so easy? 5602-Search-GenSchTbl. MOVE LOW-VALUES TO Pf-Packet. CALL 'AscFd' USING 6 'TmpUse' 12 ConvertNameFd Dummy. MOVE ConvertNameFd TO Pf-Pkt-Int-Filename. CALL 'AscFd' USING 6 'S$Work' 12 ConvertNameFd Dummy. MOVE ConvertNameFd TO Pf-Pkt-EltName. MOVE NameSubschema TO ConvertNameAscii. CALL 'AscFd' USING 12 ConvertNameAscii 12 ConvertNameFd Dummy. MOVE ConvertNameFd TO Pf-Pkt-VerName. (rel) MOVE 5 TO Pf-Pkt-Type. MOVE 'UnknownFile' TO NameSchemaFile. PERFORM 5603-Look-For-SDollarWork UNTIL (GenSchIdx > GenSchTot) OR (NameSchemaFile NOT = 'UnknownFile'). / 5603-Look-For-SDollarWork. MOVE SPACES TO Acsf-Image. STRING '@USE TmpUse.,' DELIMITED BY SIZE NameAppGroup DELIMITED BY ' ' '*' DELIMITED BY SIZE GenSchFile (GenSchIdx) DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO Acsf-Image. PERFORM 8030-ErAcsf. COPY ErPfs-Pd IN UCS-PROC. SeqNum IF (PostA1 > 0) =Found MOVE GenSchFile (GenSchIdx) TO NameSchemaFile. / * This is the last set of map directives that will be * generated in the map of an absolute. This is how we assure * that the "IN TIP$*TIPLIBREL.C$SMC50" will be the last thing * in the DBank. (Of course, we also have to make sure that it * is always the last thing in the external table GlobalDirs.) 5610-AbsMap-DBank-Dirs. PERFORM VARYING DBankDirIdx FROM 1 BY 1 UNTIL DBankDirIdx > DBankDirTot MOVE '5610-' TO PicPara MOVE DBankDirFlag (DBankDirIdx) TO PicX06 PERFORM 8150-Search-FlagTbl IF (FlagSet (Pic99) = Gen-Con-True) MOVE DBankDir (DBankDirIdx) TO MapRec WRITE MapRec END-IF END-PERFORM. / 5620-RelMap-Last. PERFORM VARYING EltIdx FROM 1 BY 1 UNTIL EltIdx > EltTot IF (EltWasReferenced (EltIdx)) AND (EltIsSinglebanked (EltIdx)) AND (EltIsLast (EltIdx)) MOVE EltName (EltIdx) TO NameEltSubr PERFORM 8180-Write-In-NameEltSubr END-IF END-PERFORM. / 6000-Process-Obj. IF (V-Opt > 0) PERFORM 6001-Copy-Obj ELSE PERFORM 6005-Link-Everybody-Else. ADD ExrefTotalInElt TO ExrefTotal. 6001-Copy-Obj. IF (NameQualFileIn NOT = NameQualFileOut) PERFORM 6002-Copy-Necessary. MOVE SPACES TO MapRec. STRING '@MSG,N @' DELIMITED BY SIZE NameEltSelfUC DELIMITED BY ' ' ',UV doesn''t link subprograms' DELIMITED BY SIZE INTO MapRec. WRITE MapRec. 6002-Copy-Necessary. MOVE SPACES TO MapRec. STRING '@COPY,A ' DELIMITED BY SIZE NameQualFileIn DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltVerIn DELIMITED BY ' ' ',' DELIMITED BY SIZE NameQualFileOut DELIMITED BY ' ' '.' DELIMITED BY SIZE INTO MapRec. WRITE MapRec. / 6005-Link-Everybody-Else. * The following code assumes that the Object Module format * version is 5. It has correctly found the Name Table in * every unbound Object Module we've encountered so far at SBA, * though Unisys reserves the right to change, and has changed, * the format of Object Modules from time to time. PERFORM 8060-ErIo-Init. CALL 'AscFd' USING 4 'SI$$' 12 Io-Pkt Dummy. R$ MOVE Io-Func-R TO Io-Pkt-Function. ADD Toc-Rec-TextAddr, Toc-Rec-OmPreamble GIVING Io-Pkt-Sector-Addr. MOVE 28 TO Io-Pkt-Buf-Len. PERFORM 8070-ErIow. IF (Io-Buf-Word (1) = '*OM*') PERFORM 6010-Found-OM-Preamble ELSE DISPLAY 'Unable to find OM preamble' UPON Prtr-Out PERFORM 9010-Terminate-In-Error STOP RUN. / 6010-Found-OM-Preamble. DIVIDE Io-Buf-Num (16) BY 28 GIVING NameTableSectOffset REMAINDER NameTableWordOffset. MOVE Io-Buf-Num (15) TO NameTableWordLen. ADD Toc-Rec-TextAddr, NameTableSectOffset GIVING Io-Pkt-Sector-Addr. ADD NameTableWordOffset, NameTableWordLen GIVING Io-Pkt-Buf-Len. PERFORM 8070-ErIow. IF (X-Opt > 0) DISPLAY 'Name Table Contents:' UPON Prtr-Out. COBOL ADD 1 TO NameTableWordOffset, index. Io-Pkt-Buf-Len. PERFORM 6020-Process-XRefUcob VARYING i FROM NameTableWordOffset BY 1 UNTIL i > Io-Pkt-Buf-Len. PERFORM VARYING i FROM 1 BY 1 UNTIL i > FlagTot IF (FlagToBeCleared (i) = Gen-Con-True) MOVE 0 TO FlagSet (i) END-IF END-PERFORM. IF (FlagPads NOT = Gen-Con-True) MOVE Gen-Con-True TO FlagNoPads. MOVE Gen-Con-True TO FlagAlways. /6010-Found-OM-Preamble, continued: IF (X-Opt > 0) DISPLAY 'Flags:' UPON Prtr-Out PERFORM VARYING i FROM 1 BY 1 UNTIL i > FlagTot IF (FlagSet (i) = Gen-Con-True) DISPLAY Indent FlagName (i) UPON Prtr-Out END-IF END-PERFORM DISPLAY 'OMs:' UPON Prtr-Out PERFORM VARYING i FROM 1 BY 1 UNTIL i > EltTot IF (EltWasReferenced (i)) DISPLAY Indent EltName (i) UPON Prtr-Out END-IF END-PERFORM. IF (FlagAbsMap = Gen-Con-True) PERFORM 6500-Generate-Link ELSE PERFORM 6001-Copy-Obj. / 6020-Process-XRefUcob. * Because we scan the NameTable directly, without going thru * OM$XREFINFO, we don't know whether the Name represents an * EXDEF, an EXREF or some other kind of Name. On the other * hand, our tables are set up such that we don't really care * (at least, not yet). * * Steve Seaquist * 07/13/1994 IF (Io-Buf-S6 (i) > 0) PERFORM 6021-Process-NonNullString. * When processing relocatables, ExrefTotalInElt is set by * reading the preamble. But when processing Object Modules, * we have to accumulate it. We don't have to specifically * zero it out between elts in mass-map/link mode, because it's * in EltRelatedInfo, which is cleared with LOW-VALUES before * the elt is processed. ADD 1 TO ExrefTotalInElt. 6021-Process-NonNullString. MOVE Io-Buf-S6 (i) TO NameXRefCharLen. MOVE Io-Buf-Word (i + 1) (1:NameXRefCharLen) TO NameXRef. IF (X-Opt > 0) DISPLAY Indent NameXRef UPON Prtr-Out. PERFORM 8140-Process-NameXRef. * The following is a trick to compute the "covered quotient" * (in this case, the number of words necessary to hold that * many characters). The formula is Words = (Chars + 3) / 4. * Also, by redefining NameXRefWordLen as we have (see Working- * Storage), we avoid a division. The compiler will generate * a right-shift instruction instead. ADD 3 TO NameXRefCharLen. ADD NameXRefWordLen TO i. / 6500-Generate-Link. IF NameVerIn (1:GenAppLenProd) = GenAppQualProd MOVE GenAppQualProd TO NameAppGroup, NameAppGroupIn MOVE GenAppQualProdRSA TO NameAppGroupRS MOVE GenAppFileProdDmrmt TO NameDmrmt MOVE NameVerIn (GenAppLenProd + 1:) TO NameVerInOrig PERFORM 6510-Do-Generate-Link ELSE IF NameVerIn (1:GenAppLenProdComp) = GenAppQualProdComp MOVE GenAppQualProd TO NameAppGroup MOVE GenAppQualProdComp TO NameAppGroupIn MOVE GenAppQualProdRSA TO NameAppGroupRS MOVE GenAppFileProdDmrmt TO NameDmrmt MOVE NameVerIn (GenAppLenProdComp + 1:) TO NameVerInOrig PERFORM 6510-Do-Generate-Link ELSE IF NameVerIn (1:GenAppLenTest) = GenAppQualTest MOVE GenAppQualTest TO NameAppGroup, NameAppGroupIn MOVE GenAppQualTestRSA TO NameAppGroupRS MOVE GenAppFileTestDmrmt TO NameDmrmt MOVE NameVerIn (GenAppLenTest + 1:) TO NameVerInOrig PERFORM 6510-Do-Generate-Link ELSE IF NameVerIn (1:GenAppLenTestComp) = GenAppQualTestComp MOVE GenAppQualTest TO NameAppGroup MOVE GenAppQualTestComp TO NameAppGroupIn MOVE GenAppQualTestRSA TO NameAppGroupRS MOVE GenAppFileTestDmrmt TO NameDmrmt MOVE NameVerIn (GenAppLenTestComp + 1:) TO NameVerInOrig PERFORM 6510-Do-Generate-Link ELSE PERFORM 6501-Generate-Link-OmHasNoApp. / 6501-Generate-Link-OmHasNoApp. MOVE NameVerIn TO NameVerInOrig. IF (FlagVersioned = Gen-Con-True) PERFORM 6502-Generate-Link-ButSubrsDo ELSE MOVE SPACES TO NameAppGroup, NameAppGroupIn PERFORM 6510-Do-Generate-Link. 6502-Generate-Link-ButSubrsDo. IF (0 < T-Opt OR R-Opt) OR (0 = P-Opt) MOVE GenAppQualTest TO NameAppGroup, NameAppGroupIn MOVE GenAppQualTestRSA TO NameAppGroupRS MOVE GenAppFileTestDmrmt TO NameDmrmt If 2 outs, IF (0 < R-Opt) OR (0 < P-Opt AND T-Opt) gener8 MOVE SPACES TO NameEltVerOut names. END-IF PERFORM 6510-Do-Generate-Link. * In GEN, if there's only one app group, we suppress a release * gen's test compile in favor of its prod compile, because the * prod compile will have the detail we expect in a release gen. * But here we suppress the prod link, because test links and * prod links have equal detail, and test links are the default. * It simplifies the logic considerably to do it this way. IF (GenAppNbrTest NOT = GenAppNbrProd) AND (0 < P-Opt OR R-Opt) MOVE GenAppQualProd TO NameAppGroup, NameAppGroupIn MOVE GenAppQualProdRSA TO NameAppGroupRS MOVE GenAppFileProdDmrmt TO NameDmrmt If 2 outs, IF (0 < R-Opt) OR (0 < P-Opt AND T-Opt) gener8 MOVE SPACES TO NameEltVerOut names. END-IF PERFORM 6510-Do-Generate-Link. / 6510-Do-Generate-Link. PERFORM 8090-Get-EltVerAbs. PERFORM 6520-BegECL. PERFORM 6530-BegLinks. PERFORM 6540-Include. PERFORM 6550-MidLinks. PERFORM 6560-Usings. PERFORM 6570-MCores. PERFORM 6580-EndLinks. PERFORM 6590-EndECL. * If this is a one-app-group-only system, users don't want to * be bothered with app-group-related version names on ZOOMs. IF (GenAppNbrTest = GenAppNbrProd) AND (NameAppGroup NOT = SPACES) MOVE SPACES TO MapRec MOVE 1 TO StringPtr STRING '@CHG,A ' DELIMITED BY SIZE NameQualFileOut DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltVerAbs DELIMITED BY ' ' ',.' DELIMITED BY SIZE NameEltIn DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr IF (NameVerInOrig NOT = SPACES) STRING '/' DELIMITED BY SIZE NameVerInOrig DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr END-IF WRITE MapRec. / 6520-BegECL. MOVE SPACES TO MapRec. MOVE 1 TO StringPtr. STRING '@HDG,P *** Linking ' DELIMITED BY SIZE NameEltIn DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr. IF (NameAppGroup NOT = SPACES) STRING ' to ' DELIMITED BY SIZE NameAppGroup DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr. STRING ' ***' DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr. WRITE MapRec. MOVE '@USE Link$Pf.,Sys$Lib$*App$?.' TO MapRec. IF (NameAppGroup = GenAppQualTest) MOVE GenAppNbrTest TO MapRec (33:1) ELSE IF (NameAppGroup = GenAppQualProd) MOVE GenAppNbrProd TO MapRec (33:1) ELSE MOVE GenAppNbrDefault TO MapRec (33:1). WRITE MapRec. IF (L-Opt + R-Opt > 0) MOVE 'L' TO Link-Opt-List ELSE IF (N-Opt > 0) MOVE 'E' TO Link-Opt-List ELSE MOVE 'S' TO Link-Opt-List. MOVE SPACES TO MapRec. STRING '@LINK,I' Link-Opt-List ' ' DELIMITED BY SIZE NameQualFileIn DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltIn DELIMITED BY ' ' '/LinkElt,;' DELIMITED BY SIZE INTO MapRec. WRITE MapRec. MOVE SPACES TO MapRec. STRING ' ' DELIMITED BY SIZE NameQualFileOut DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltVerAbs DELIMITED BY ' ' INTO MapRec. WRITE MapRec. / 6530-BegLinks. PERFORM VARYING BegLinkIdx FROM 1 BY 1 UNTIL BegLinkIdx > BegLinkTot MOVE '6530-' TO PicPara MOVE BegLinkFlag (BegLinkIdx) TO PicX06 PERFORM 8150-Search-FlagTbl IF (FlagSet (Pic99) = Gen-Con-True) MOVE BegLinkDir (BegLinkIdx) TO MapRec WRITE MapRec END-IF END-PERFORM. 6540-Include. MOVE SPACES TO MapRec. MOVE 1 TO StringPtr. STRING 'INCLUDE ' DELIMITED BY SIZE NameQualFileIn DELIMITED BY ' ' '.' DELIMITED BY SIZE NameEltVerIn DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr. WRITE MapRec. / 6550-MidLinks. PERFORM VARYING MidLinkIdx FROM 1 BY 1 UNTIL MidLinkIdx > MidLinkTot MOVE '6550-' TO PicPara MOVE MidLinkFlag (MidLinkIdx) TO PicX06 PERFORM 8150-Search-FlagTbl IF (FlagSet (Pic99) = Gen-Con-True) MOVE MidLinkDir (MidLinkIdx) TO MapRec WRITE MapRec END-IF END-PERFORM. IF (HoldCardsExist > 0) OPEN INPUT CardFile MOVE 0 TO HoldEof PERFORM UNTIL (HoldEof > 0) READ CardFile AT END MOVE 1 TO HoldEof NOT AT END WRITE MapRec FROM CardRec END-READ END-PERFORM CLOSE CardFile. / 6560-Usings. MOVE 'RESOLVE ALL REFERENCES USING' TO MapRec. WRITE MapRec. PERFORM VARYING UsingIdx FROM 1 BY 1 UNTIL UsingIdx > UsingTot MOVE '6560-' TO PicPara MOVE UsingFlag (UsingIdx) TO PicX06 PERFORM 8150-Search-FlagTbl IF (FlagSet (Pic99) = Gen-Con-True) * From the propositional calculus, ((NOT A) OR B) defines * "A implies B". Don't worry. This correctly eliminates * the APPGROUP$ directive when FlagVersioned isn't true: AND ((UsingDir (UsingIdx) NOT = 'APPGROUP$') OR (FlagVersioned = Gen-Con-True)) MOVE SPACES TO MapRec MOVE 27 TO StringPtr PERFORM 6561-Usings-Format IF (UsingIdx < UsingTot) STRING '.,' DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr END-IF WRITE MapRec END-IF END-PERFORM. / 6561-Usings-Format. IF (FlagVersioned = Gen-Con-True) EVALUATE UsingDir (UsingIdx) (1:1) WHEN '*' STRING NameAppGroup DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr PERFORM 6562-Usings-UseName WHEN '%' STRING NameAppGroupIn DELIMITED BY ' ' '*' DELIMITED BY SIZE UsingDir (UsingIdx) (2:) DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr WHEN '^' STRING NameAppGroupRS DELIMITED BY ' ' '*' DELIMITED BY SIZE UsingDir (UsingIdx) (2:) DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr WHEN OTHER PERFORM 6562-Usings-UseName END-EVALUATE ELSE PERFORM 6562-Usings-UseName. 6562-Usings-UseName. IF (UsingDir (UsingIdx) = 'APPGROUP$') STRING NameAppGroup DELIMITED BY ' ' '$' DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr ELSE STRING UsingDir (UsingIdx) DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr. / 6570-MCores. MOVE 0 TO MCoreSize. PERFORM VARYING MCoreIdx FROM 1 BY 1 UNTIL MCoreIdx > MCoreTot MOVE '6570-' TO PicPara MOVE MCoreFlag (MCoreIdx) TO PicX06 PERFORM 8150-Search-FlagTbl IF (FlagSet (Pic99) = Gen-Con-True) ADD MCoreAmt (MCoreIdx) TO MCoreSize END-IF END-PERFORM. IF (MCoreSize > 0) PERFORM 6571-MCore-Necessary. 6571-MCore-Necessary. INSPECT MCoreSizeX REPLACING LEADING '0' BY ' '. MOVE SPACES TO MapRec. STRING 'SET Size = Size + ' MCoreSizeX ' FOR URTS$TABLES' DELIMITED BY SIZE INTO MapRec. WRITE MapRec. / 6580-EndLinks. PERFORM VARYING EndLinkIdx FROM 1 BY 1 UNTIL EndLinkIdx > EndLinkTot MOVE '6580-' TO PicPara MOVE EndLinkFlag (EndLinkIdx) TO PicX06 PERFORM 8150-Search-FlagTbl IF (FlagSet (Pic99) = Gen-Con-True) MOVE EndLinkDir (EndLinkIdx) TO MapRec WRITE MapRec END-IF END-PERFORM. 6590-EndECL. MOVE '@FREE Link$Pf.' TO MapRec. WRITE MapRec. / 8010-Display-Acsf-Status. DISPLAY Acsf-Image UPON Prtr-Out. COPY Convert-Octal-Pd-Group IN UCS-PROC REPLACING P1 BY Acsf-Status. DISPLAY 'got bad status: ' Display-Octal UPON Prtr-Out. 8030-ErAcsf. PERFORM 8040-ErAcsf-AllowFacReject. IF (Acsf-FacReject > 0) PERFORM 8010-Display-Acsf-Status PERFORM 9010-Terminate-In-Error STOP RUN. 8040-ErAcsf-AllowFacReject. COPY ErAcsf-Pd IN UCS-PROC. / 8050-ErFitem. MOVE LOW-VALUES TO Fitem-Pkt (9:). COPY ErFitem-Pd IN UCS-PROC. / 8060-ErIo-Init. COPY ErIo-Init IN UCS-PROC. 8070-ErIow. COPY ErIow-Pd IN UCS-PROC. IF (Io-Pkt-Status NOT = Io-Stat-NoErr) DISPLAY Indent 'IO status ' Io-Pkt-Status UPON Prtr-Out PERFORM 9010-Terminate-In-Error STOP RUN. / 8080-ErSnap. COPY Loc-Pd IN UCS-PROC REPLACING P1 BY StartOfGensDBank P2 BY SnapAddr. COPY Loc-Pd IN UCS-PROC REPLACING P1 BY EndOfGensDBank P2 BY EndOfGensDBank. SUBTRACT SnapAddr FROM EndOfGensDBank GIVING SnapLen. COPY ErSnap-Pd IN UCS-PROC. / 8090-Get-EltVerAbs. IF (NameEltVerOut = SPACES OR 'T' OR 'X') IF (NameEltOut = 'T' OR 'X') PERFORM 8092-Get-EltVerAbs-Short ELSE PERFORM 8091-Get-EltVerAbs-Default ELSE MOVE NameEltVerOut TO NameEltVerAbs. 8091-Get-EltVerAbs-Default. IF (NameEltOut = SPACES) MOVE NameEltIn TO NameEltOut. IF (NameVerInOrig = SPACES) MOVE NameAppGroup TO NameVerOut ELSE Truncd MOVE SPACES TO NameVerOut to 12 STRING NameAppGroup DELIMITED BY ' ' chars NameVerInOrig DELIMITED BY SIZE by len INTO NameVerOut. IF (NameVerOut = SPACES) MOVE NameEltOut TO NameEltVerAbs ELSE MOVE SPACES TO NameEltVerAbs STRING NameEltOut DELIMITED BY ' ' '/' DELIMITED BY SIZE NameVerOut DELIMITED BY ' ' INTO NameEltVerAbs. 8092-Get-EltVerAbs-Short. MOVE NameEltIn TO NameEltVerAbs. IF (NameAppGroup = GenAppQualTest) MOVE NameEltOut TO NameEltVerAbs (1:1). 8100-Get-EltVerIn. MOVE Toc-Rec-EltName TO NameEltIn. MOVE Toc-Rec-VerName TO NameVerIn. IF (NameEltIn = SPACES OR LOW-VALUES OR ALL '@') MOVE SPACES TO NameEltIn. IF (NameVerIn = SPACES OR LOW-VALUES OR ALL '@') MOVE NameEltIn TO NameEltVerIn MOVE SPACES TO NameVerIn ELSE MOVE SPACES TO NameEltVerIn STRING NameEltIn DELIMITED BY ' ' '/' DELIMITED BY SIZE NameVerIn DELIMITED BY ' ' INTO NameEltVerIn. / 8110-Get-EltVerOut. MOVE Ro-Toc-Record ( 1:12) TO NameEltOut. MOVE Ro-Toc-Record (21:12) TO NameVerOut. IF (NameEltOut = SPACES OR LOW-VALUES OR ALL '@') MOVE SPACES TO NameEltOut. IF (NameVerOut = SPACES OR LOW-VALUES OR ALL '@') MOVE NameEltOut TO NameEltVerOut MOVE SPACES TO NameVerOut ELSE MOVE SPACES TO NameEltVerOut STRING NameEltOut DELIMITED BY ' ' '/' DELIMITED BY SIZE NameVerOut DELIMITED BY ' ' INTO NameEltVerOut. 8120-Get-EltVerRel. IF (Toc-Rec-VerName = SPACES OR LOW-VALUES OR ALL '@') MOVE NameAppGroup TO NameVerRel ELSE Truncd MOVE SPACES TO NameVerRel to 12 STRING NameAppGroup DELIMITED BY ' ' chars Toc-Rec-VerName DELIMITED BY SIZE by len INTO NameVerRel. IF (NameVerRel = SPACES) MOVE NameEltIn TO NameEltVerRel ELSE MOVE SPACES TO NameEltVerRel STRING NameEltIn DELIMITED BY ' ' '/' DELIMITED BY SIZE NameVerRel DELIMITED BY ' ' INTO NameEltVerRel. / 8130-Get-QualFile. PERFORM 8050-ErFitem. PERFORM 8131-Get-QualFile-NoFitem. 8131-Get-QualFile-NoFitem. MOVE Fitem-Ext-Qualifier TO ConvertNameFd. CALL 'FdAsc' USING 12 ConvertNameFd 12 ConvertNameAscii Dummy. MOVE ConvertNameAscii TO NameQual. MOVE Fitem-Ext-Filename TO ConvertNameFd. CALL 'FdAsc' USING 12 ConvertNameFd 12 ConvertNameAscii Dummy. MOVE ConvertNameAscii TO NameFile. IF (Fitem-Abs-FCyc < 10) MOVE Fitem-Abs-FCyc TO Pic9 MOVE Pic9 TO NameFCyc ELSE IF (Fitem-Abs-FCyc < 100) MOVE Fitem-Abs-FCyc TO Pic99 MOVE Pic99 TO NameFCyc ELSE MOVE Fitem-Abs-FCyc TO Pic999 MOVE Pic999 TO NameFCyc . MOVE SPACES TO NameQualFile. IF (Fitem-Abs-FCyc = 1) STRING NameQual DELIMITED BY ' ' '*' DELIMITED BY SIZE NameFile DELIMITED BY ' ' INTO NameQualFile ELSE STRING NameQual DELIMITED BY ' ' '*' DELIMITED BY SIZE NameFile DELIMITED BY ' ' '(' DELIMITED BY SIZE NameFCyc DELIMITED BY ' ' ')' DELIMITED BY SIZE INTO NameQualFile . / 8140-Process-NameXRef. PERFORM 8141-Search-XRefTbl. PERFORM 8143-Search-SubrTbl. 8141-Search-XRefTbl. SEARCH ALL XRefTbl * AT END * Ignore WHEN XRefName (XRefIdx) = NameXRef MOVE 0 TO HoldClearing SET k TO XRefIdx PERFORM 8142-Process-XRef VARYING l FROM 1 BY 1 UNTIL (l > Gen-Con-XRefMaxFlags) OR (XRefFlag (k, l) = SPACES). 8142-Process-XRef. MOVE '8142-' TO PicPara. MOVE XRefFlag (k, l) TO PicX06. PERFORM 8150-Search-FlagTbl. IF (HoldClearing = 0) MOVE Gen-Con-True TO FlagSet (Pic99) ELSE MOVE Gen-Con-True TO FlagToBeCleared (Pic99). IF (XRefDelim (k, l) = ';') MOVE 1 TO HoldClearing. / 8143-Search-SubrTbl. SEARCH ALL SubrTbl * AT END * Ignore WHEN SubrName (SubrIdx) = NameXRef MOVE SubrElt (SubrIdx) TO PicX12 PERFORM 8145-Search-EltTbl PERFORM 8144-Search-EltCallsTbl. 8144-Search-EltCallsTbl. MOVE PicX12 TO EltCallsTargetElt. SEARCH ALL EltCallsTbl * AT END * Ignore WHEN EltCallsKey (EltCallsIdx) = EltCallsTarget PERFORM VARYING EltCallsIdx2 FROM EltCallsIdx BY 1 UNTIL (EltCallsKeyElt (EltCallsIdx2) NOT = EltCallsKeyElt (EltCallsIdx)) OR (EltCallsIdx2 > EltCallsTot) MOVE EltCallsElt (EltCallsIdx2) TO PicX12 PERFORM 8145-Search-EltTbl END-PERFORM. 8145-Search-EltTbl. SEARCH ALL EltTbl AT END DISPLAY Indent PicX12 ' rel name not found!' UPON Prtr-Out PERFORM 9010-Terminate-In-Error STOP RUN WHEN EltName (EltIdx) = PicX12 SET Pic99 TO EltIdx. PERFORM 8146-Process-Elt. 8146-Process-Elt. IF (Pic99 = 0 OR > EltTot) DISPLAY Indent 'Processing ' PicX12 ', got ' Pic99 ' index out of range!' UPON Prtr-Out PERFORM 9010-Terminate-In-Error STOP RUN. MOVE Gen-Con-True TO EltFlag (Pic99). IF EltIsMultibanked (Pic99) MOVE Gen-Con-True TO FlagMultibanked. IF EltIsVersioned (Pic99) IF (FlagRelMap = Gen-Con-True) IF EltIsSinglebanked (EltIdx) MOVE Gen-Con-True TO FlagVersioned END-IF ELSE MOVE Gen-Con-True TO FlagVersioned. / 8150-Search-FlagTbl. SEARCH ALL FlagTbl AT END DISPLAY Indent PicX06 ' flag not found! (GEN para ' PicPara ')' UPON Prtr-Out PERFORM 9010-Terminate-In-Error STOP RUN WHEN FlagName (FlagIdx) = PicX06 SET Pic99 TO FlagIdx. / 8170-Verify-MapTables. DISPLAY '@MAP Directive Tables:' UPON Prtr-Out. DISPLAY Indent DBankDirTot ' DBankDirs' UPON Prtr-Out. DISPLAY Indent DBankMinTot ' DBankMins' UPON Prtr-Out. DISPLAY Indent GlobalDirTot ' GlobalDirs' UPON Prtr-Out. DISPLAY Indent GlobalLibTot ' GlobalLibs' UPON Prtr-Out. DISPLAY Indent IBankDirTot ' IBankDirs' UPON Prtr-Out. DISPLAY '@LINK Directive Tables:' UPON Prtr-Out. DISPLAY Indent BegLinkTot ' BegLinks' UPON Prtr-Out. DISPLAY Indent MidLinkTot ' MidLinks' UPON Prtr-Out. DISPLAY Indent UsingTot ' Usings' UPON Prtr-Out. DISPLAY Indent EndLinkTot ' EndLinks' UPON Prtr-Out. DISPLAY 'Sorted Tables:' UPON Prtr-Out. PERFORM 8171-Verify-FlagTbl. PERFORM 8172-Verify-EltTbl. PERFORM 8173-Verify-EltCallsTbl. PERFORM 8174-Verify-SubrTbl. PERFORM 8176-Verify-XRefTbl. / 8171-Verify-FlagTbl. MOVE SPACES TO VerifyPrev. MOVE Gen-Con-True TO TableIsAscending. PERFORM VARYING VerifyIdx FROM 1 BY 1 UNTIL VerifyIdx > FlagTot IF (VerifyPrev NOT < FlagName (VerifyIdx)) DISPLAY Indent FlagName (VerifyIdx) ' at ' VerifyIdx ' is out of seq ' UPON Prtr-Out MOVE 0 TO TableIsAscending END-IF MOVE FlagName (VerifyIdx) TO VerifyPrev END-PERFORM. IF (TableIsAscending = Gen-Con-True) DISPLAY Indent FlagTot ' Flags are ascending' UPON Prtr-Out. 8172-Verify-EltTbl. MOVE SPACES TO VerifyPrev. MOVE Gen-Con-True TO TableIsAscending. PERFORM VARYING VerifyIdx FROM 1 BY 1 UNTIL VerifyIdx > EltTot IF (VerifyPrev NOT < EltName (VerifyIdx)) DISPLAY Indent EltName (VerifyIdx) ' at ' VerifyIdx ' is out of seq ' UPON Prtr-Out MOVE 0 TO TableIsAscending END-IF MOVE EltName (VerifyIdx) TO VerifyPrev END-PERFORM. IF (TableIsAscending = Gen-Con-True) DISPLAY Indent EltTot ' Elts are ascending' UPON Prtr-Out. / 8173-Verify-EltCallsTbl. MOVE SPACES TO VerifyPrev. MOVE Gen-Con-True TO TableIsAscending. PERFORM VARYING VerifyIdx FROM 1 BY 1 UNTIL VerifyIdx > EltCallsTot IF (VerifyPrev NOT < EltCallsKey (VerifyIdx)) DISPLAY Indent EltCallsKey (VerifyIdx) ' at ' VerifyIdx ' is out of seq ' UPON Prtr-Out MOVE 0 TO TableIsAscending END-IF MOVE EltCallsKey (VerifyIdx) TO VerifyPrev MOVE EltCallsElt (VerifyIdx) TO VerifyElt PERFORM 8175-Verify-EltAlsoExists END-PERFORM. IF (TableIsAscending = Gen-Con-True) DISPLAY Indent EltCallsTot ' EltCalls are ascending' UPON Prtr-Out. 8174-Verify-SubrTbl. MOVE SPACES TO VerifyPrev. MOVE Gen-Con-True TO TableIsAscending. PERFORM VARYING VerifyIdx FROM 1 BY 1 UNTIL VerifyIdx > SubrTot IF (VerifyPrev NOT < SubrName (VerifyIdx)) DISPLAY Indent SubrName (VerifyIdx) ' at ' VerifyIdx ' is out of seq ' UPON Prtr-Out MOVE 0 TO TableIsAscending END-IF MOVE SubrName (VerifyIdx) TO VerifyPrev MOVE SubrElt (VerifyIdx) TO VerifyElt PERFORM 8175-Verify-EltAlsoExists END-PERFORM. IF (TableIsAscending = Gen-Con-True) DISPLAY Indent SubrTot ' Subrs are ascending' UPON Prtr-Out. 8175-Verify-EltAlsoExists. SEARCH ALL EltTbl AT END DISPLAY Indent VerifyElt ' at ' VerifyIdx ' has no ' 'corresponding Elts entry' UPON Prtr-Out WHEN EltName (EltIdx) = VerifyElt NEXT SENTENCE. / 8176-Verify-XRefTbl. MOVE SPACES TO VerifyPrev. MOVE Gen-Con-True TO TableIsAscending. PERFORM VARYING VerifyIdx FROM 1 BY 1 UNTIL VerifyIdx > XRefTot IF (VerifyPrev NOT < XRefName (VerifyIdx)) DISPLAY Indent XRefName (VerifyIdx) ' at ' VerifyIdx ' is out of seq ' UPON Prtr-Out MOVE 0 TO TableIsAscending END-IF MOVE XRefName (VerifyIdx) TO VerifyPrev END-PERFORM. IF (TableIsAscending = Gen-Con-True) DISPLAY Indent XRefTot ' XRefs are ascending' UPON Prtr-Out. / 8180-Write-In-NameEltSubr. * We used to have Elt's in a variety of files, but * managing them all proved to be too great a chore. Now we * have only 1 file for all rels not specific to an app group * (OIRM$), plus 1 file for each app group (TEST$ and QUERY$). * All 3 of these are assigned by the ProdLib mechanism, * which allows MY*OIRM$, MY*TEST$ and/or MY*QUERY$ to override * the production libraries. MOVE ' IN' TO MapRec. MOVE 11 TO StringPtr. IF EltIsVersioned (EltIdx) STRING NameAppGroup DELIMITED BY ' ' '$' DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr ELSE STRING 'OIRM$' DELIMITED BY SIZE INTO MapRec WITH POINTER StringPtr. STRING '.' DELIMITED BY SIZE NameEltSubr DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr. IF EltIsVersioned (EltIdx) STRING '/' DELIMITED BY SIZE NameAppGroup DELIMITED BY ' ' INTO MapRec WITH POINTER StringPtr. WRITE MapRec. / 8190-Zero-Out-Flags. PERFORM VARYING FlagIdx FROM 1 BY 1 UNTIL FlagIdx > FlagTot MOVE 0 TO FlagSet (FlagIdx) FlagToBeCleared (FlagIdx) END-PERFORM. PERFORM VARYING EltIdx FROM 1 BY 1 UNTIL EltIdx > EltTot MOVE 0 TO EltFlag (EltIdx) END-PERFORM. / * Everywhere the following 2 paragraphs are PERFORMed, they * are followed by STOP RUN. Of course, we don't need to do * STOP RUNs in both places. It's just "belt and suspenders" * programming. 9000-Terminate. DISPLAY 'END ' NameEltSelf UPON Prtr-Out. STOP RUN. 9010-Terminate-In-Error. MOVE SPACES TO Disp-Image. STRING 'END ' DELIMITED BY SIZE NameEltSelf DELIMITED BY ' ' ' in error.' DELIMITED BY SIZE INTO Disp-Image. DISPLAY Disp-Image UPON Prtr-Out. STOP RUN. S-OFF COPY GenApp-Pd IN UCS-PROC. GenApp-ErAcsf. PERFORM 8030-ErAcsf. GenApp-Terminate-In-Error. PERFORM 9010-Terminate-In-Error. COPY Sdf-Record-Access IN UCS-PROC. COPY Toc-Record-Access IN UCS-PROC. SLIST @EOF @ELT,IQD UUSIG*1100-001-001.GENDOC/ADD,,SENT @ASG,T TPF$., F///262143 . Expand in case expansion needed @CAT,P GenDoc.,F2///999 @ASG,A GenDoc. @DOC,DEFI TPF$.DocElt,, GenDoc., FORM,0*1.53/61,50/79,1/66,0*0.0/0 The SBA COBOL Gen Utility 1OVERVIEW COLUMN 2 The SBA COBOL Gen Utility (@GEN) was written to dynamically generate COBOL precompile, compile and/or map ECL to meet the current needs of every SBA COBOL program. For example, if a program is converted to use a database, its compile ECL is automatically adjusted to precompile it with ADMLP and compile the DMLOUT element instead. In addition, its map ECL is automatically adjusted to map in the proper D$WORK and S$WORK. It knows about SBA-unique stuff such as the TEST and QUERY application groups, OCS*ASC-PROC, where the relocatables of subroutines are kept, etc. It also knows about SBA programming standards and can directly enforce many of them. But mostly it knows about COBOL and how to generate ECL for COBOL. We are very aggressive about making the Gen Utility handle everything we have to gen, with minimum programmer effort. So if you encounter any situation that it cannot handle, please let us know immediately, so that we can solve the problem immediately. (We don't want you to have to "work around" using it.) CENTER This manual corresponds to @GEN Version 4.4 (created 09/12/95) CENTER This manual corresponds to @GEN Version 4.4 (created 09/12/95) CENTER This manual corresponds to @GEN Version 4.4 (created 09/12/95) CENTER This manual corresponds to @GEN Version 4.4 (created 09/12/95) CENTER This manual corresponds to @GEN Version 4.4 (created 09/12/95) CENTER This manual corresponds to @GEN Version 4.4 (created 09/12/95) CENTER This manual corresponds to @GEN Version 4.4 (created 09/12/95) CENTER This manual corresponds to @GEN Version 4.4 (created 09/12/95) CENTER and @GENDIR Version 1.4 (created 09/12/95) CENTER and @GENDIR Version 1.4 (created 09/12/95) CENTER and @GENDIR Version 1.4 (created 09/12/95) CENTER and @GENDIR Version 1.4 (created 09/12/95) CENTER and @GENDIR Version 1.4 (created 09/12/95) CENTER and @GENDIR Version 1.4 (created 09/12/95) CENTER and @GENDIR Version 1.4 (created 09/12/95) CENTER and @GENDIR Version 1.4 (created 09/12/95) 1HOW TO USE @GEN 2What Typing @GEN Will Do COLUMN 2 CENTER ************************************************************* CENTER * * CENTER * IN GENERAL, ALL YOU HAVE TO TYPE IS: * CENTER * * CENTER * @GEN . * CENTER * * CENTER ************************************************************* CENTER * * CENTER * AFTER YOU TRANSMIT THE @GEN COMMAND, EVERYTHING ELSE IS * CENTER * AUTOMATIC. YOU DO NOT HAVE TO RESPOND TO ANY QUESTIONS. * CENTER * * CENTER ************************************************************* CENTER * * CENTER * IN RESPONSE TO THE @GEN LINE, THE GEN UTILITY WILL: * CENTER * * CENTER * 1. Create a breakpoint file called LST. * CENTER * For example, @GEN Bow.Wow will breakpoint to * CENTER * to a catalogued file called LSTWOW. * CENTER * * CENTER * 2. Breakpoint printout to that file. * CENTER * * CENTER * 3. Compile and map the program. * CENTER * * CENTER * 4. Close the breakpoint file and give it the @USE * CENTER * name of LST (for easy reference). * CENTER * * CENTER * 5. Edit the breakpoint file, executing a series of * CENTER * Editor commands to show you any compile and/or * CENTER * map errors that may have occurred during the gen. * CENTER * * CENTER * 6. Return control to you. * CENTER * * CENTER ************************************************************* EJECT 2Some Simple Examples COLUMN 2 Although the Gen Utility was set up to be extremely easy to use, it has many options that you may not be familiar with. For those who aren't familiar with @GEN and its option letters, this section gives you plenty of examples, so that you won't have to plow thru the reference material and figure it out the hard way. Each example does something a little different from the previous one. That way you can become acquainted with the Gen Utility one idea at a time. After this section there will be reference material that explains the various options in detail. REMAIN 15 3 Example 1: A Simple Gen COLUMN 2 CENTER ********************** CENTER * * CENTER * @GEN A*B.C * CENTER * * CENTER ********************** The input COBOL source element name is "A*B.C". The output absolute element name will also be "A*B.C". REMAIN 22 3 Example 2: Read-Only Input File (The Easy Way) COLUMN 2 CENTER ************************************* CENTER * * CENTER * @GEN AASC*ASC-PROD.PMIW60 * CENTER * * CENTER ************************************* The input COBOL source element name is "AASC*ASC-PROD.PMIW60". Because AASC*ASC-PROD is read-only and read-keyed, the output absolute cannot possibly go to that file. At this point, GEN could've just complained and bombed, but as a convenience feature (to keep you from having to edit and resend the @GEN line), GEN automatically assigns a temporary file called "OUT." to hold the output absolute. The output absolute element name will be "OUT.PMIW60". REMAIN 16 COLUMN 2 3 Example 3: Read-Only Input File (Another Way) CENTER ******************************************* CENTER * * CENTER * @GEN AASC*ASC-PROD.PMIW60,TPF$. * CENTER * * CENTER ******************************************* The input COBOL source element name is "AASC*ASC-PROD.PMIW60". In this case, an output file is specified, so "OUT." is not needed. The output absolute element name will be "TPF$.PMIW60". REMAIN 15 3 Example 4: Changing the Output Element Name COLUMN 2 CENTER ********************************************** CENTER * * CENTER * @GEN AASC*ASC-PROD.PMIW60,TPF$.X/Y * CENTER * * CENTER ********************************************** Note the addition of the output element name ("X/Y"). The output absolute element name will be "TPF$.X/Y". REMAIN 31 3 Example 5: Database Program (TEST) COLUMN 2 CENTER ************************************* CENTER * * CENTER * @GEN AASC*ASC-PROD.LAUD18 * CENTER * * CENTER ************************************* Notice that this @GEN statement is in the exact same format as all of the previous examples. You don't have to tell GEN that the program is database. But now that we're talking about database, it's worthwhile mentioning that the T option means TEST. Two related options (P and R) will be described soon. If neither the P or R option is present, the T option is assumed. Genning a database program to TEST is the default because that's what programmers do most often. The input COBOL source element name is "AASC*ASC-PROD.LAUD18". While reading that element, GEN sees the INVOKE clause and realizes that LAUD18 is a database program. Consequently, both TEST and QUERY versions are possible. No options are present, so GEN defaults to TEST. The output absolute element name will be OUT.LAUD18/TEST REMAIN 24 3 Example 6: Database Program (TCOMP) COLUMN 2 CENTER ************************************* CENTER * * CENTER * @GEN,C AASC*ASC-PROD.LAUD18 * CENTER * * CENTER ************************************* The C option specifies "use TCOMP for TEST and QCOMP for QUERY". As in the previous example, GEN defaults to TEST. Because of the C option, TEST gets changed to TCOMP. The compilation will be to TCOMP, but the map will be to TEST. (That's standard operating procedure for "COMP" database gens.) Therefore, like the previous example, the output absolute element name would also be "OUT.LAUD18/TEST". The difference is that this absolute would contain the S$PROC record descriptions, D$WORK and S$WORK of a new subschema that hasn't been put into production yet. REMAIN 20 3 Example 7: Database Program (QUERY) COLUMN 2 CENTER ************************************* CENTER * * CENTER * @GEN,P AASC*ASC-PROD.LAUD18 * CENTER * * CENTER ************************************* This time the P option is present. The P option specifies Production (QUERY). Because the P option is present, the T option (TEST) is not assumed. The Q option wasn't used to mean QUERY because it was already being used to mean "edit the breakpoint file with Q/EDitor". The output absolute element name will be "OUT.LAUD18/QUERY". REMAIN 24 3 Example 8: Database Program (QCOMP) COLUMN 2 CENTER ************************************* CENTER * * CENTER * @GEN,PC AASC*ASC-PROD.LAUD18 * CENTER * * CENTER ************************************* Again, the C option means "use TCOMP for TEST and QCOMP for QUERY". As in the previous example, the P option tells GEN to gen to QUERY. Because of the C option, QUERY gets changed to QCOMP. The compilation will be to QCOMP, but the map will be to QUERY. (That's standard operating procedure for "COMP" database gens.) Therefore, like the previous example, the output absolute element name would also be "OUT.LAUD18/QUERY". The difference is that this absolute would contain the S$PROC record descriptions, D$WORK and S$WORK of a new subschema that hasn't been put into production yet. REMAIN 17 EJECT 3 Example 9: Database Program (TEST and QUERY) COLUMN 2 CENTER ************************************* CENTER * * CENTER * @GEN,TP AASC*ASC-PROD.LAUD18 * CENTER * * CENTER ************************************* This time both the T and P options are present. The T option specifies Test (TEST). The P option specifies Production (QUERY). There will be 2 output absolute elements. Their names will be "OUT.LAUD18/TEST" and "OUT.LAUD18/QUERY". REMAIN 30 3Example 10: Database Program (TCOMP and QCOMP) COLUMN 2 CENTER ************************************* CENTER * * CENTER * @GEN,TPC AASC*ASC-PROD.LAUD18 * CENTER * * CENTER ************************************* As in the previous example, the T and P options tell GEN to gen to both TEST and QUERY. The C option changes them to TCOMP and QCOMP. The sequence will be: compile to TCOMP, map to TEST, compile to QCOMP, map to QUERY. (That's standard operating procedure for "COMP" database gens.) Therefore, like the previous example, the output absolute element names would also be "OUT.LAUD18/TEST" and "OUT.LAUD18/QUERY". The difference is that these absolutes would contain the S$PROC record descriptions, D$WORK and S$WORK of a new subschema that hasn't been put into production yet. (P.S.: It's typical for the database group to put out a TCOMP subschema many days or even weeks before the QCOMP subschema. If you attempt to do both when only the test side exists, the ADMLP to QCOMP will fail, of course.) EJECT 3Example 11: Release Gen COLUMN 2 CENTER ************************************* CENTER * * CENTER * @GEN,R AASC*ASC-PROD.LAUD18 * CENTER * * CENTER ************************************* This time the R option is used instead of the T and P options. The R option specifies a "release gen". If the program is database, the R option is similar to specifying both the T and P options, because a release gen will also gen to both Test and Production. If the program is not database, it's similar to a simple gen. The major difference is that release gens are generated in a format suitable for release procedures: COLUMN 10 An @DOWN is done, maybe (*) The @ACOB to TEST does not show source code. The @ACOB to QUERY shows source and cross reference. Both @MAPs are long listings to verify that they mapped to the proper database (SCHEMAFILE, DMRMT, etc). COLUMN 6 (*) We want to also do an @DOWN compared to the last released version of the same program, but the way to do that for all branches has yet to be decided. @GEN version 3.2 is capable of @DOWNing most PMS Branch programs. This is not because of PMSB chauvinism or anything like that. It's just that PMSB programs are relatively easy to identify, and all of their production source resides in only one file. COLUMN 2 Also, during release gens, the Gen Utility scans the entire program looking for violations of SBA programming standards: ALTER verb Non-standard libraries PROGRAM-ID not equal to element name etc. More standards enforcements are planned for the future, but for now, the main way you might offend GEN is with non-standard libraries. (Better read the first 2 sections of the LIBRARIES chapter.) REMAIN 21 3Example 12: Mass Compile COLUMN 2 CENTER ******************************* CENTER * * CENTER * @GEN AASC*ASC-PROD. * CENTER * * CENTER ******************************* Note that no element name is specified. This how to tell GEN to do a "mass compile" of every COBOL element in a file. There will be dozens of output absolute elements, one for each COB element in AASC*ASC-PROD. Their names will all be of the form "OUT./TEST". For more information, there's a whole section on mass compiles below. EJECT 2The @GEN Statement, Quick Reference COLUMN 2 OPTION MEANING COMMENTS ------ ------- -------- A ACOB (Used to resolve ambiguity only) B "Before" line #'s (Always @ADMLP,S to see curr line #'s) C "COMP" databases (During compiles) D DCD listing (Inline source cross-reference) E Error handling (PADS, subscript range checking, etc) F Floating-point (@ACOB ,,,,T) G H Help (Options list, or create users manual) I Installation elts (Future option for TIP programs) J K L Long listings (Depends on other option(s)) M MONITOR (Forces a MONITOR at the ECL level) N No listings (Depends on other option(s)) O P Production (QUERY) Q Q/EDitor (To view breakpoint file) R Release gen (QUERY & TEST in special format) S Syntax-only (@ACOB ,,,,5 / @UCOB ,,,,,NO-CODE) T Test (TEST) U UCOB (Used to resolve ambiguity only) V Subprogram (Note similarity to @ACOB,V) W X Don't gen (Genstream in ADD$.ADD$ not @ADD'd) Y Don't map re-ent (Suppress reentrant maps for TIP) Z EJECT 2The @GEN Statement, Detailed Reference COLUMN 2 The Gen Utility was designed to be simple and easy to use. In general, all you have to do is type the following: CENTER @GEN,<> InFile.InElt,OutFile.OutElt COLUMN 29 "Dropout Rules": ---------------- If InFile is omitted, TPF$ is assumed. If InElt is omitted, a "mass compile" of every COB element in InFile is assumed. * If OutFile is omitted, and InFile is write-enabled, InFile is assumed to be the ouput file. If OutFile is omitted, and InFile is write-inhibited, a temporary file called "Out" will be assigned and used to save outputs. If OutElt is omitted, the output element name will be generated from InElt as follows: FXFORM TEST database - add /TEST QUERY database - add /QUERY If not database - no change END If OutElt is T or X, the output element name will be generated from InElt as follows: FXFORM TEST database - substitute T or X as first letter Anything else - no change END If OutElt is anything other than the above, the output element name will be OutElt. COLUMN 4 * (Use the @ED and @QED Editors' TYPE command to identify an element as being of type COB.) EJECT 2Major Option Letters COLUMN 2 There are 4 major options that control what application group(s) get compiled and/or mapped, as follows: COLUMN 27 C - "Comp" databases (Use TCOMP for TEST, QCOMP for QUERY; this affects compiles only, not maps) T - Test (the default) P - Production (= QUERY, *** Q means Q/EDitor ***) R - Release (= TEST and QUERY in release format) COLUMN 2 A release gen reads the entire program. The reason is that it has to assure SBA Standards compliance before giving the green-light to the program's being released to production. A test and/or production gen reads only up to PROCEDURE DIVISION. The main reason is to save time. By the time it reaches the PROCEDURE DIVISION, GEN already knows whether or not the program is a main program or a subprogram, and it knows whether or not the program is database, so it can proceed quickly to generating the compile/map ECL. EJECT 2Minor Option Letters COLUMN 2 In addition, there are several minor options that control other aspects of the gen, as follows: COLUMN 27 * A - ACOB (Use @ACOB to compile, @MAP to map) D - DCD listing (Inline source cross-reference utility) F - Floating-point (Uses COMP-2 internally in COMPUTEs) H - Help (Option list, add L-Option for manuals) L - Long listings (If release gen, @DOWN,LV If not release gen, @ACOB,R & @MAP,L) M - Monitor (GEN inserts a MONITOR statement into ACOB programs just after the Procedure Division header. If you have referenced MCFLAG in the Procedure Division, it will initially set MCFLAG to 0. If you have not, it will initiially set it to 1. This allows you to turn MONITOR on or off at the ECL level. In the case of UCOB, GEN puts the MONITOR keyword into the @UCOB statement.) N - No listings (If release gen, no @DOWN If not release gen, @ACOB,N & @MAP,N) Q - Q/EDitor (Use @QED to view compile/map listing) S - Syntax-only (Use this if you only want diagnostics) * U - UCOB (Use @UCOB to compile, @LINK to link) V - Subroutine (Only necessary if no LINKAGE SECTION) X - Don't do the gen (No @ADD of generated compile stream) Y - Don't map re-ent (If TIP, suppress reentrant TIP maps, because this program relies on VALUE clauses (= not "self-initializing").) COLUMN 2 * See the following section that discusses A and U options. EJECT 2When You Have to Specify the A and/or U Options COLUMN 2 It's possible to write a program that is syntax-compatible with both ACOB and UCOB. If you write such a program, GEN will assume that it's ACOB. If that's what you want, no problem. But if you want it to be processed by UCOB, you have to tell GEN so by coding the U option on the @GEN call. You can get rid of this problem by putting UCOB-unique syntax in the DATA DIVISION (that is, by making the program no longer syntax-compatible with ACOB). It's also possible to write a program that contains syntax for both ACOB and UCOB. An example is a program that's being converted from ACOB to UCOB. If that happens, GEN will not know which compiler(s) to use. It will refuse to gen that program. In this situation, you would have to code the A and/or U option. Also, if you want a program to be compiled by both compilers, you would have to code both the A and U options. Other than these 3 situations, you don't have to code either the A or U option. GEN will figure it out for you. 1LIBRARIES 2SBA Standards COLUMN 2 SBA's programming standards specify that all copy procs (and soon, all subprogram relocatables and object modules) must come from a short list of library files. Alphabetically by usename, these files are as follows: Usename Production Filename Usage ======= =================== ===== ASC-PROC OCS*ASC-PROC (General procs for ACOB) ATSPROCFILE DATSR-A*ATSPROCFILE (DPS Screens) DPS SYS$LIB$*DPS (DPS) LABD15LIB AASA*LABD15LIB (Special procs for LABD15) OIRM$ OIRM*RLIB$ (Rels & Object Modules) PROC OCS*ASC-PROC (General procs for ACOB) or OIRM*UCS-PROC (General procs for UCOB) QUERY$ QUERY*RLIB$ (Rels & OMs for QUERY) TEST$ TEST*RLIB$ (Rels & OMs for TEST) TIP TIP$*TIPLIBREL (TIP) UCS-PROC OIRM*UCS-PROC (General procs for UCOB) Notes: COLUMN 6 (1) It's unclear whether LABD15LIB is a standard or an exception. (2) OIRM$ and UCS-PROC are for-sure not yet SBA-standard. They were incorporated into the GEN utility so that it could handle UCOB programs. (3) PROC will be equated to ASC-PROC in the case of ACOB and UCS-PROC in the case of UCOB. It does not yet work when genning to both compilers in the same gen (@GEN,AU), however. (4) GEN doesn't set the standards. It simply enforces them. COLUMN 2 EJECT SBA Standards, continued: SPACE 0 ------------------------- COLUMN 2 STANDARDS COMPLIANCE SHOULD BE VERIFIABLE IN THE COMPILE/MAP LISTING. The problem is, that hasn't always been the case with some programmers' compile/map ECL. One of the reasons why GEN was written was to help enforce standards with a listing that can be reliably be used to verify compliance. TO AVOID RUNNING AFOUL OF GEN'S STANDARDS CHECKING, YOU MUST USE THE IN/OF CLAUSE ON ALL COPY STATEMENTS. For example, COPY <> IN <>. For release to production, the <> must be one of the usenames listed above. (Note that "OIRM$", "QUERY$" and "TEST$" cannot be used for copy procs, because the "$" would be illegal in a COPY statement's IN/OF clause. They are libraries in the @MAP sense of the term (LIBs), but not in the COBOL sense of the term.) EJECT 2The Problem with COB$PF COLUMN 2 Many programmers have been used to using the "anonymous copylib" method of pulling in procs from ASC-PROC. This is also known as the "COB$PF mechanism". The problem with using COB$PF is that it isn't verifiable. That's because copy procs without the IN/OF clause do not necessarily come from COB$PF. Anonymous copy procs can come from: the source input file (ACOB and UCOB) SYS$LIB$*PROC$ (ACOB and UCOB) SYS$*RLIB$ (ACOB) TPF$ (UCOB) and/or up to 49 alternate COB$PF files (UCOB) Suppose you started coding your own copy proc to do something. You use it in several programs. Then you discover that there already exists a copy proc in ASC-PROC that does the same thing, only better. You change the programs you're still using, but you forget to change one or two of the older ones that you haven't worked on in months. Later, you need to write a new program. You start by making a copy of one of your older, unchanged programs. Even though COB$PF points to ASC-PROC, and even though your proc isn't in ASC-PROC, the compile doesn't bomb, because it still exists in your file. But if you say IN ASC-PROC, only OCS*ASC-PROC gets searched. If it doesn't exist there, ADMLP aborts, or ACOB gets serious errors. GEN allows the COPY statement without the IN/OF clause, but only on non-release gens. EJECT 2Test Libraries COLUMN 2 Standards enforcement brings up a paradox similar to "Catch-22" or "what came first, the chicken or the egg?": How do you test copy procs prior to release if you can't use them until they are released?? GEN has 2 methods of allowing copy procs from non-standard files, while at the same time enforcing SBA programming standards: "non-standard libraries" and "override libraries". 3Non-Standard Libraries COLUMN 2 "Non-standard libraries" are allowed for all gens except release gens. You simply PDP a proc and keep it in whatever file you wish. Before invoking GEN, you attach a usename to the file and use the IN/OF clause on the COPY statement. For example, @USE XX.,DLAFR-A*XX-FILE. (in your run) @PDP,CNQ XX.CALC-TERMS-PD,XX. (in your run) @EOF (in your run) COPY CALCULATE-TERMS IN XX. (in the program) The reason why this is allowed is that GEN detects it and complains loudly about it in the breakpoint file, so loudly that would not escape anyone's attention during release procedures. Also, because of the possibility of picking up a proc from a non-standard file, failing to code the IN/OF clause on a COPY is also complain-of as "non-standard libraries". EJECT 3Override Libraries COLUMN 2 One problem with using non-standard libraries is that it makes the program reference a non-standard usename. In the previous example, the program said COPY CALCULATE-TERMS IN XX. The problem is that "XX" isn't on list of standard library usenames. Even after the copy proc is released to ASC-PROC, the program wouldn't be releasable until it's been (1) changed to read "IN ASC-PROC", (2) recompiled, and (3) retested. "Override libraries" are a way to release a program and its new copy procs at the same time. If there's a temporary file called MY*ASC-PROC assigned to the run, and there's **NOT** a temporary file called OVERRIDE*ASC-PROC assigned to the run, GEN will do the following: @BANNER OVERRIDE,LIBRARIES @PRT,TL MY*ASC-PROC. @ASG,T OVERRIDE*ASC-PROC.,F///99999 @COPY,P OCS*ASC-PROC.,OVERRIDE*ASC-PROC. @COPY,P MY*ASC-PROC., OVERRIDE*ASC-PROC. @PACK,P OVERRIDE*ASC-PROC. @USE ASC-PROC., OVERRIDE*ASC-PROC. What this means is that GEN will compile and map the program AS IF THE PROCS WERE ALREADY RELEASED TO OCS*ASC-PROC. It also warns that the program is not releasable unless the copy procs in MY*ASC-PROC are also released to OCS*ASC-PROC at the same time. This allows the copy procs and program to share the same compile, map and test. Override libraries are something of a nuisance to set up, but the results are at least releasable. It's anticipated that programmers will tend to use the easier "non-standard libraries" method until they get ready to release, then switch over to the "override libraries" method. EJECT 3More about Override Libraries COLUMN 2 The @COPY,P's and @PACK of OVERRIDE*ASC-PROC are pretty expensive, time-wise. Rather than slow down every gen in your run from then on, GEN checks to see whether or not it has already created OVERRIDE*ASC-PROC. If there's a temporary file called MY*ASC-PROC assigned to the run, and there **IS** a temporary file called OVERRIDE*ASC-PROC assigned to the run, GEN will do the following: @BANNER OVERRIDE,LIBRARIES @PRT,TL MY*ASC-PROC. @USE ASC-PROC., OVERRIDE*ASC-PROC. Therefore, if you change the contents of MY*ASC-PROC, you have to @FREE OVERRIDE*ASC-PROC. That's what causes GEN to rebuild it. All SBA-standard libraries can be overridden in exactly the same manner: Usename Production Filename To override, use ======= =================== ================ ASC-PROC OCS*ASC-PROC MY*ASC-PROC ATSPROCFILE DATSR-A*ATSPROCFILE MY*ATSPROCFILE DPS SYS$LIB$*DPS MY*DPS LABD15LIB AASA*LABD15LIB MY*LABD15LIB OIRM$ OIRM*RLIB$ MY*OIRM$ QUERY$ QUERY*RLIB$ MY*QUERY$ TEST$ TEST*RLIB$ MY*TEST$ TIP TIP$*TIPLIBREL MY*TIP UCS-PROC OIRM*UCS-PROC MY*UCS-PROC If you have trouble remembering the last set of names, just remember: It's **ALWAYS** "MY*Usename", regardless of what the production filename is. Note that MY*COB$PF and MY*PROC are not on the list. Use MY*ASC-PROC and/or MY*UCS-PROC instead. In all cases, you have to release all override library elements at the same time as you release any programs that use them. EJECT More about Override Libraries, continued: SPACE 0 ----------------------------------------- You cannot use a CATALOGUED file called MY*<>. The reason is that there can be only one catalogued file by that name. As of version 3.2, GEN ignores MY* files if they're catalogued. Here's a way to initialize MY*ASC-PROC by typing only one line: In FILE.SETUP/CALCPROCS: @FREE MY*ASC-PROC. @FREE OVERRIDE*ASC-PROC. @ASG,T MY*ASC-PROC.,F///9999 @COPY,S FILE.CALC-TERMS-WS,MY*ASC-PROC. @COPY,S FILE.CALC-TERMS-PD,MY*ASC-PROC. Then, when you want to start genning, here's the one line: @ADD,L FILE.SETUP/CALCPROCS 1SUBPROGRAMS COLUMN 2 As of GEN 4.0, subprogram handling has been moved to GENDIR 1.0, but that distinction is irrelevant to the following explanations. 2Relocatable Library File Structure COLUMN 2 GEN expects all subprograms' executable code to come out of the SBA standard libraries OIRM*RLIB$, QUERY*RLIB$, TEST*RLIB$, or else out of an override file for those 3 files. (See "More about Override Libraries", above.) For the sake of brevity, these will be referred to by their usenames, OIRM$, QUERY$ and TEST$. OIRM$ is for subprograms that are independent of application group. For example, a subprogram that calculates a number could be used under either application group. QUERY$ and TEST$ are for subprograms that are unique to an application group. Generally, these are database subprograms. The QUERY versions are premapped to the QUERY database, and the TEST versions are premapped to the TEST database. Similarly, subprograms that access TIP Files can have TEST and QUERY versions (to access different TIP Files). Typically, to make sure that we don't accidentally pull in the wrong elements, the application group name is the version name as well; for example: QUERY$.DAILYSUB/QUERY TEST$.DAILYSUB/TEST This is easy to do, because the Gen Utility automatically tacks on those version names as a default. 2Relocatable Element Names COLUMN 2 In addition, GEN has been programmed to know the element names and entry points of all "multibanked" SBA subprograms. (Again, these are typically database subprograms.) Multibanked subprograms must also reside in the relocatable libraries, but GEN has to know their names so that it can behave differently when it gens them or batch programs that use them. Singlebanked subprograms need only reside in the library files. GEN doesn't need to know their names or entry points. EJECT 2Multibanked Subprograms 3How GEN Handles Multibanked Subprograms COLUMN 2 When GEN gens an ACOB multibanked subprogram, it pre-maps the 2 output relocatables into only 1 relocatable using @MAP,R. It does so for several reasons: COLUMN 11 (1) The ACOB runtime system requires that each IBANK must contain its own copy of C$RET0 (the runtime that does EXIT PROGRAM). (2) It prevents the DBANK relocatable (SYSDTA) from getting out-of-sync with the IBANK relocatable. (3) In our multiple-IMPART DMS-1100 environment, a database subprogram's D$WORK and S$WORK would conflict with the D$WORK(s) and S$WORK(s) of other database subprograms, and/or of the main program. COLUMN 2 The easy way to do all 3 things at once is to pre-map all relocatables used by a subprogram into only 1 relocatable. An important implication is that ALL DATABASE SUBPROGRAMS MUST BE IDENTIFIED TO @GEN AS BEING MULTIBANKED, SO THAT GEN WILL PRE-MAP THEM TOGETHER WITH THEIR D$WORK AND S$WORK. GEN also behaves differently when genning main programs (**MAYBE**): COLUMN 11 (1) If the main program is batch, GEN will put each multibanked subprogram into its own IBANK. (2) If the main program is TIP, GEN will generate only one IBANK so that the transaction will load faster. (This was an optimization suggested by Dick Thiebaud, proving that we do indeed listen to suggestions.) EJECT 3Multibanked Subprogram Restrictions COLUMN 2 If you have to modify an existing multibanked subprogram, adhere to the following restrictions if at all possible: COLUMN 11 (1) Don't change its PROGRAM-ID. (2) Don't change any of its WITH ENTRY POINTS names. COLUMN 2 If you obey these rules, @GEN will not be bothered by your changes. But if you need to create a new multibanked subprogram, or you have to change an existing multibanked subprogram's PROGRAM-ID or WITH ENTRY POINTS names, don't worry **too** much. (It requires changing GEN's tables, but that can now be done without recompiling GEN.) Contact Steve Seaquist at 202-205-6339. 2Developing and Testing Subprograms COLUMN 2 Here's how to develop and test a subprogram using GEN: COLUMN 11 (1) Use @GEN to gen the subprogram. (2) Test the subprogram as follows: COLUMN 16 (a) Copy its rel(s) or object module(s) into MY*OIRM$, MY*QUERY$ or MY*TEST$ (as seems appropriate). (b) If, during development, you copy a newer version into the "MY*" file, free the override file. GEN will then recreate the override lib with the newer version. (If you don't free the override file, GEN will continue to use the previous version!) (c) Use GEN to gen a main program that calls on the subprogram. (d) Test the main program. COLUMN 11 (3) When you have the subprogram the way you want it, release it to OIRM*RLIB$, QUERY*RLIB$ and/or TEST*RLIB$. 1SPECIAL TOPICS 2Capturing the Compile/Map ECL COLUMN 2 Normally, you don't have to do this. If you have a program xxxxxx that gens correctly using @GEN, it is acceptable to specify simply CENTER @GEN,R File.xxxxxx as its compile/map ECL. For example, if you genned the program FRIBBLE.FRACK and were told to include the compile/map ECL in its REMARKS paragraph, you could simply code: FXFORM *************************************************************** * Compile/Map ECL for FRACK * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * @GEN,R File.FRACK * * * *************************************************************** END (Of course, the purpose of using "File.", rather than FRIBBLE, is simply to avoid having to keep editing that text every time it happens to reside in a different file. Current filename is, after all, irrelevant.) Likewise, if you have to release a FRIBBLE.FRACK/MAP element, it could also consist of only the one line "@GEN,R File.FRACK". This is why you don't usually have to capture @GEN's compile/map ECL. Essentially, once @GEN can handle it, compile/map ECL for that program is no longer your responsibility. It's @GEN's responsibility. EJECT Capturing the Compile/Map ECL, continued: SPACE 0 ----------------------------------------- There may be times, however, where the Gen Utility doesn't generate the ECL you need in an emergency. For example, if you need a test program that maps to the production MMS (to investigate a missing reports problem, say), the Gen Utility won't generate it for you. Per SBA programming standards, @GEN always maps test to TEST and production to QUERY. It was designed to **FORBID** mapping test to QUERY. In such a case, where the Gen Utility should not be modified to accommodate your problem, you may have to capture the generated ECL and modify it to deal with your special problem. But first, 2 pieces of extra information: COLUMN 6 (1) @GEN generates only the precompile and/or compile steps, and its output is to the element "ADD$.ADD$". (2) @GENDIR generates the @MAP and map directives (or @LINK and link directives), and its output is to the element "MAP$.ADD$". COLUMN 2 With that in mind, here's how to capture the full compile/map ECL if you ever have to do something different: @GEN File.xxxxxx <> @COPY,S ADD$.ADD$,File.xxxxxx/MAP @ED,U File.xxxxxx/MAP F @GENDIR D ADD+ MAP$.ADD$ If the program is database, and you want both maps, you will have to use @TOCED to undelete the previous MAP$.ADD$, of course. EJECT 2Changing GEN and GENDIR's Behavior COLUMN 2 If you don't want to go to the trouble of capturing the compile/map ECL and editing it, there are ways to change the behavior of the gen: 3Changing ECL$ COLUMN 2 GEN and GENDIR use a utility file called ECL$ to determine what to do. The production ECL$ is GENUTIL*ECL$. The following elements are critical: GEN: ECL$.GENAPP$ - controls application group behavior GENDIR: ECL$.GENAPP$ - controls application group behavior ECL$.TBL$ - controls map and link directives (1.0) ECL$.TBL$1R1 - controls map and link directives (1.1 and 1.2) ECL$.TBL$1R3 - controls map and link directives (1.3+) Whenever there's a major TBL$ format change between versions of GENDIR, we change its name as shown above, by tacking on the version of GENDIR when it becomes effective. This allows us to have multiple versions of GENDIR on the system at the same time without any problems. Because they are in source elements, not compiled code, CHANGING GENAPP$ AND TBL$ CAN BE DONE AT ANY TIME, WITHOUT HAVING TO RELEASE A NEW VERSION OF GEN OR GENDIR. The process of adding a new subprogram or directive typically takes only about 5 minutes to do, so don't be shy about requesting a change. But it is necessary to REQUEST a change, rather than doing it yourself. Because GENAPP$ and TBL$ affect the productivity of every COBOL programmer at a site, changing them must be done very carefully. Only the programmers responsible for maintaining GEN and GENDIR should code new entries into the production GENAPP$ and TBL$. At the Small Business Administration, programmers should contact Steve Seaquist, (202) 205-6339, or Dick Thiebaud, (202) 205-6358. At other U-1100/2200 sites that install the Gen Utility, programmers should contact their own site's people. GENAPP$ and TBL$ are very specific to each site's environment, so it would be useless for non-SBA programmers to contact Steve or Dick. EJECT Changing GEN and GENDIR's Behavior, continued: SPACE 0 ---------------------------------------------- 3"@UCOB *" and "LINK: *" Comments COLUMN 2 As a temporary workaround measure, GEN and GENDIR support limited control of the @UCOB keywords and link directives in UCOB source code. One line of @UCOB keywords and up to 5 lines of link directives are allowed. To keep you from forgetting about them, and to make sure that they'll get seen in development gens, it's good to put them in at the very top of the program, like so: @UCOB * MONITOR/LABEL,MAXERRORS/15,; LINK: *INCLUDE MYFILE.MYSUBPROG LINK: *CHANGE REFERENCE (SUBPROG) TO MYSUBPROG IDENTIFICATION DIVISION. ... If the first 7 characters of a UCOB source code line are "@UCOB *" or "LINK: *" (all uppercase), there will be an asterisk in column 7, and UCOB will treat the line as a comment. But GEN will not. GEN will save columns 8-72 of those lines and output them later to the generated ECL. In the case of the "@UCOB *" line, GEN will put the remainder of the line into the @UCOB call, between UcobOpts and the generated keywords. Start your keywords in column 18 if you want them to line up with the keywords generated by GEN. DON'T FORGET TO CODE COMMAS BETWEEN YOUR KEYWORDS AND DON'T FORGET TO CODE A SEMICOLON AT THE END! Without the final semicolon, the generated options will not be seen by UCOB, and the gen will almost certainly fail. In the case of the "LINK: *" lines, GEN will pass the lines to GENDIR, and GENDIR will output the lines after the "MidLinks" directives (in TBL$, after the INCLUDE and before the RESOLVE ALL REFERENCES). To "comment out" this technique, convert columns 1-7 to lowercase ("@ucob *" or "link: *"), so that GEN will no longer treat them as a special case. EJECT 2Common Code for TEST and QUERY COLUMN 2 There are 2 ways to use @GEN to generate both TEST and QUERY in the same gen: @GEN,R ... or @GEN,TP... Whenever you do this, the same source code will be used for both. Many programs, however, need to behave differently depending on whether they're executing in the test or production environment. For example, production transactions pass off to production transactions, and test transactions pass off to test transactions. Since test transaction names are different (beginning with "T" or "X"), how can the same source code be used??? There are 2 easy ways to do this: (1) Look at the first character of your own transaction name. (2) Use DBMODE. If the first character of your own transaction name is "T" or "X", you are a test transaction and you should only pass off to other test transactions. A simple way to do this, since groups of transactions tend to have the same first letter, is to plug the first character of your own transaction name into the first character of the transaction name you're passing off to. To use DBMODE, define an I-O-CONTROL paragraph (if you haven't already), like so: ENVIRONMENT DIVISION. INPUT-OUTPUT SECTION. I-O-CONTROL. APPLY EXREF ON DBMODE. DATA DIVISION. WORKING-STORAGE SECTION. COPY DBMODE-WS IN ASC-PROC. EJECT Common Code for TEST and QUERY, continued: SPACE 0 ------------------------------------------ You will then be able to say something like the following in your PROCEDURE DIVISION code: IF TESTMODE MOVE 'X' TO PASSOFF-NAME-1ST-CHAR ELSE IF QUERYMODE MOVE 'L' TO PASSOFF-NAME-1ST-CHAR ELSE <>. Note that the terms TEST and QUERY now apply to all TIP programs, plus any program that uses TIP File Control, database subroutines or MMS, ... not just to database programs. One last caution: CENTER ********************************************************** CENTER ** IF YOU DON'T CODE THE "APPLY EXREF", BUT YOU DO CODE ** CENTER ** EVERYTHING ELSE, YOUR PROGRAM WILL BE SYNTACTICALLY ** CENTER ** CORRECT, BUT IT WILL BEHAVE LIKE TESTMODE (ALWAYS) ** CENTER ** AT EXECUTION TIME. YOU *MUST* APPLY EXREF ON DBMODE ** CENTER ********************************************************** EJECT 2Debugging COLUMN 2 GEN contains many built-in tools to make debugging easier: 1) @GEN,D - produce a DCD II inline cross reference 2) @GEN,E - turn on compiler error checking, gen SDD 3) @GEN,M - turn on MONITOR 4) CALL 'PADS$' - gen SDD, map/link PADS (see warning, below) @GEN,D: Sometimes it's easier to debug a program if you can see exactly what it's doing. The DCD II inline cross reference is very useful in helping you figure out ACOB and AMDLP programs. To cross reference database records, DMCA, etc, use the L-Option too (@GEN,DL). DCD II may also do a passable job on some UCOB programs, but none of the new UCOB verbs or syntaxes are supported. SBA still has a site license for DCD II, but not DCD III, which supports UCOB. @GEN,E turns on number-of-CALL-parameters checking (UCOB only), subscript range checking and creating the Symbolic Debugging Dictionery (SDD) used by PADS. @GEN,M is simply the fastest and easiest way to insert a MONITOR into your program. It works under both ACOB and UCOB. PADS$: If the Procedure Division is being scanned, GEN detects "CALL 'PADS$'." and generates compile ECL to create the Symbolic Debugging Dictionery (SDD) used by PADS. (If you want to have PADS available, but you don't want to actually call PADS$, put the CALL statement into a paragraph that will never be performed.) GENDIR also detects the call and generates appropriate map or link directives to allow the program to use PADS at run-time. COLUMN 7 Warning about PADS$: -------------------- SPACE 0 In a development gen without the L-Option, the Procedure Division is not scanned, so the "CALL 'PADS$'." will not be seen. Also, GEN doesn't read copy procs, so calls to PADS$ in copy procs won't be seen either. In either of these cases, you will have to @GEN,E to make sure that the SDD gets created. COLUMN 2 In addition, you can also copy in COMCONDEBUG (instead of COMCON) to specify WITH DEBUGGING MODE. This turns on debug lines ("D" in column 7) under both ACOB and UCOB, but USE FOR DEBUGGING sections in DECLARATIVES don't work under UCOB. (The compile doesn't error, but no code is generated for the section!) So it would be good to get into the habit of using debug lines and avoiding USE FOR DEBUGGING sections. EJECT 2DPS Testing (New Levels of DPS) COLUMN 2 It's easy to pick up the libraries for an upcoming level of DPS. Just use the "override libraries" technique described above in the chapter on "LIBRARIES". Since this is a common predicament, overriding DPS is described here in detail: SUPPOSE THE TEST VERSION OF DPS THAT YOU WANT TO USE IS IN THE FILE SYS$LIB$*DPSTST. (That's the filename into which EDS usually puts new versions of DPS.) Create an add element called SETUP/TESTDPS, as follows: SETUP/TESTDPS: @FREE MY*DPS. . Use test DPS @FREE OVERRIDE*DPS. . Use test DPS @ASG,T MY*DPS.,F///9999 . Use test DPS @COPY SYS$LIB$*DPSTST.,MY*DPS. . Use test DPS Keep it in a catalogued file, so that you can use it again in the future. Before you @GEN, simply "@ADD,L <>.SETUP/TESTDPS". Then EVERYTHING (copy procs, relocatables and object modules) will all point to the new DPS: COPY ... IN DPS will pick up new copy procs, @MAPs will pick up the new common banks via CBEP relocatables, and @LINKs will pick up the new common banks via object modules. You do *NOT* have to keep @ADD'ing SETUP/TESTDPS over and over again, once for each gen. GEN will continue to use the override library until you @FIN, or @FRE, or manually @FREE MY*DPS. CAUTION!: CENTER ********************************************************** CENTER ** EVEN IF THE TEST DPS SYSTEM IS THE SAME DPS LEVEL AS ** CENTER ** THE CURRENT DPS SYSTEM, ITS COMMON BANKS AND SCREEN ** CENTER ** FILES WILL PROBABLY BE DIFFERENT. ** CENTER ********************************************************** That means that you may have to transfer screens between the test and production DPS systems. FORMGEN's input/output omnibus elements can help. For example, you can save a screen defined under the test DPS system to an omnibus. Then you can read it back in from the same omnibus under the current DPS system and save it to a screen file there. EJECT 2Mass Compiles and Mass MAP/LINKs COLUMN 2 Mass compiles are now very simple to do. All you have to do is leave off the element name on the @GEN processor call statement and the entire input file will be searched for elements that have been TYPE'd as COB. You can TYPE an element as being COBOL by saying "TYPE COB" in the the @ED or @QED editors and eventually exiting in a manner that saves changes. (That is, don't exit by means of "OMIT".) You can also use @TOCED's change command, in most cases. If you don't want to gen every COBOL program in a file, just @COPY,S the elements you want into a holding file. GEN doesn't have any "version masking" capability, but @COPY,S does, so you may want to use @COPY,SV if you want to select elements on the basis of their version names. Anyway, once the elements have been copied to the holding file, just do a mass compile on the holding file. Every program will be genned separately and get its own breakpoint file. GEN has been engineered so that adjacent gens will not interfere with each other, so you don't have to worry about that. After all the individual gens have been done, you will be put into a "synopsis" breakpoint file called "LSTMASSCOMP.". It will contain, in condensed form, the results of all the other gens. Generally it's paper-saving and time-efficient to print the synopsis breakpoint file with the @ED or @QED "SITE" command, rather than @SYM'ing it. As of GEN 4.0, the generation of MAP and LINK directives was moved to a new program, called GENDIR. GENDIR 1.0 has the same file scanning feature, and it's invoked in exactly the same way: "@GENDIR,opts File." (no element name). It will map all ACOB rels (other than D$WORKs and SYSDTAs), and it will link all unbound OMs (the kind generated by @UCOB), in that file. Something to watch out for: Since GENDIR is normally invoked by GEN during a breakpoint, it does not do its own breakpointing. EJECT 2Naming Conventions COLUMN 2 Suppose that GEN was called as follows: @GEN,R InFile.InElt/InVer,OutFile. The following will be the names that will be used: Lst. Breakpoint file (usename) LstInElt. Breakpoint file (filename) OutFile.InElt/InVer Only absolute if *NOT* database OutFile.InElt/TESTInVer TEST absolute if database OutFile.InElt/QUERYInVer QUERY absolute if database Here are the reasons for these conventions: COLUMN 6 (1) GEN doesn't put a qualifier on the breakpoint filename, so that the Operating System will use your Project-Id as the qualifier. This allows more than one person to gen the same program without the breakpoint filenames' conflicting with each other. (2) By giving the breakpoint file a usename, GEN allows you to refer to it by a shorter name. You can always re-edit the most recent breakpoint file by typing CENTER @ED,QR Lst. or @QED,R Lst. (3) By including the element name in the breakpoint filename, GEN allows multiple programs to be genned in a row without losing any breakpoint files. (4) By putting the input version name onto the end of the absolute name, GEN allows you to gen different versions of the same program without deleting the absolutes. For example, if you had 2 versions of the same database program, one called PGM4/BARB and another called PGM4/MIKE, you could gen both and get 4 absolutes: PGM4/TESTBARB PGM4/QUERYBARB PGM4/TESTMIKE and PGM4/QUERYMIKE EJECT 2Restrictions Imposed by GEN's Naming Conventions COLUMN 2 GEN's naming conventions imply the following restrictions: COLUMN 6 (1) If you gen 2 versions of the same program, you will be overlaying the breakpoint file of the first gen when you do the second gen. Therefore, you will have to do one of the following: (a) Wait till the first one finishes printing (if you want to print it right away). (b) Copy the first one to another catalogued filename (if you want to print it later). (c) Not care (because you didn't want to print the first one anyway). (2) Since the breakpoint filename always begins with "Lst", which uses-up 3 characters, and the longest filename allowed under OS-1100 is 12 characters, only the first 9 characters of the input element name will be used to form the breakpoint filename. For example, the breakpoint filename associated with DBRETRIEVE would be LSTDBRETRIEV. The full input element name will still be used as the output absolute name, however. (3) If the input program is not database, but it calls on a subprogram that has TEST and QUERY versions, there will be only 1 compile, but 2 maps. The output absolutes will be named as if the input program were database. Examples of subprograms that have TEST and QUERY versions are: Database subprograms DBMODE (See "Common Code for TEST and Query", above) MMS interface relocatables EJECT 2Source Code Substitution COLUMN 2 This feature was implemented as part of Version 3.5. Previous versions of the Users Manual speculated on how it MIGHT work, but the actual implementation turned out different. Therefore, you should disregard those earlier descriptions. The following is how Source Code Substitution ACTUALLY works: COLUMN 10 (1) When scanning the COBOL program, if GEN sees a word of the form GEN-xxxxxx-SUB, it will ask you to "Enter source code to be used as xxxxxx" (2) Whatever you enter as your reply to this message will be substituted into a temporary copy of the COBOL program, completely replacing every occurrence of Gen-xxxxxx-Sub, and the edited copy of the program will be genned, not the original. (3) In a mass compile, the value does not have to be re-entered for each program. (This feature allows all programs that use the same subschema to be regenned together very efficiently.) COLUMN 2 Source Code Substitution allows us to remove keys from source code. (There isn't any policy to do so, but at least the CAPABILITY will be there if there ever is such a policy.) For example: WORKING-STORAGE SECTION. ... 01 ImpartKey PIC X(12) VALUE GEN-IMPARTKEY-SUB. ... PROCEDURE DIVISION. ... MOVE ImpartKey TO DB-IMPART-KEY. IMPART. At gen time, @GEN will ask "Enter source code to be used as IMPARTKEY". Suppose that you enter 'Arf, Arf, Arf!' (with quotes) as your reply. The generated code would be: 01 ImpartKey PIC X(12) VALUE 'Arf, Arf, Arf!'. EJECT Source Code Substitution, continued: SPACE 0 ------------------------------------ You should always substitute values into WORKING-STORAGE, as shown in this example, for 2 major reasons: COLUMN 10 1) GEN stops scanning at PROCEDURE DIVISION during test gens, so Source Code Substitutions that are only in the PROCEDURE DIVISION would not be seen. 2) If all the keys are collected together in one place, they can all be suppressed out of the gen breakpoint file with only one S-OFF. COLUMN 2 S-OFF and SLIST tell the ACOB compiler to suppress printout. They are typically used to save paper or for security reasons. Here's an example of how you can use S-OFF and SLIST to suppress production database keys for security reasons: WORKING-STORAGE SECTION. ... * S-OFF keys so they won't appear in gen printout: S-OFF 01 ChangeKey PIC X(12) VALUE GEN-CHANGEKEY-SUB. 01 DeleteKey PIC X(12) VALUE GEN-DELETEKEY-SUB. 01 ImpartKey PIC X(12) VALUE GEN-IMPARTKEY-SUB. 01 UpdateKey PIC X(12) VALUE GEN-UPDATEKEY-SUB. SLIST ... PROCEDURE DIVISION. ... MOVE ImpartKey TO DB-IMPART-KEY. IMPART. MOVE UpdateKey TO DB-UPDATE-KEY. OPEN DMLMDD123L1 USAGE-MODE UPDATE. EJECT Source Code Substitution, continued: SPACE 0 ------------------------------------ Used in combination with DBMODE (see "Common Code for TEST and QUERY", above), it's also possible to give the TEST and QUERY databases different access keys. For example: IF QUERYMODE MOVE ChangeKey TO DB-CHANGE-KEY MOVE DeleteKey TO DB-DELETE-KEY MOVE ImpartKey TO DB-IMPART-KEY MOVE UpdateKey TO DB-UPDATE-KEY ELSE MOVE 'TestChg' TO DB-CHANGE-KEY MOVE 'TestDel' TO DB-DELETE-KEY MOVE 'TestImp' TO DB-IMPART-KEY MOVE 'TestUpd' TO DB-UPDATE-KEY. (This example assumes that we don't care that the TEST database's keys appear in the source code and gen breakpoint file.) But what about KEY FOR INVOKE? It can't be controlled by an IF because it's in the DATA DIVISION! But don't worry, there's a new feature to deal with that too: If GEN sees anything of the form GEN-APP-xxxxxx-SUB, it will ask for **2** values, one for TEST and one for QUERY. (In case you're curious, "app" stands for "application group".) For example: INVOKE SUBSCHEMA YELLOW-SUB IN FILE SCHEMAFILE OF SCHEMA COLOR-SCHEMA KEY FOR INVOKE IS GEN-APP-CHROMAKEY-SUB ... In this example, GEN would ask you to: "Enter source code to be used as TEST CHROMAKEY" and "Enter source code to be used as QUERY CHROMAKEY". EJECT Source Code Substitution, continued: SPACE 0 ------------------------------------ Using the "GEN-APP-" format of Source Code Substitution, the previous examples could also have been coded as follows: * S-OFF keys so they won't appear in gen printout: S-OFF 01 ChangeKey PIC X(12) VALUE GEN-APP-CHANGEKEY-SUB. 01 DeleteKey PIC X(12) VALUE GEN-APP-DELETEKEY-SUB. 01 ImpartKey PIC X(12) VALUE GEN-APP-IMPARTKEY-SUB. 01 UpdateKey PIC X(12) VALUE GEN-APP-UPDATEKEY-SUB. SLIST ... PROCEDURE DIVISION. ... MOVE ChangeKey TO DB-CHANGE-KEY. MOVE DeleteKey TO DB-DELETE-KEY. MOVE ImpartKey TO DB-IMPART-KEY. MOVE UpdateKey TO DB-UPDATE-KEY. At this point, you may be wondering which method you should use. The answer depends on what your needs are: The current example would be the *only* way to do it if you have to remove *ALL* database access keys from the program's source code. But the previous examples would be better if you wanted the TEST keys to be the default keys, or if you don't want to respond to so many requests from GEN. Final Comments: SPACE 0 --------------- COLUMN 10 1) The maximum number of substituted names (GEN-xxxxxx-SUB) per execution of @GEN is 30. There isn't any limit on how many times a name can be used within a program, however. All substituted names must be UPPER CASE (for now). 2) If you enter a blank line in response to GEN's request for a value ("Enter source code ..."), the only effect will be that every occurrence of GEN-xxxxxx-SUB will be removed. 3) Database access keys are only the most OBVIOUS use for Source Code Substitution. Other uses will almost certainly be found. But beware of using it unnecessarily: It significantly increases the nuisance-factor of development if you have to type in substitution values every time you gen! EJECT 2SQL (RDMS-1100) COLUMN 2 You can access RDMS databases with interpretted SQL or embedded SQL. The Gen Utility supports both. 3Interpretted SQL COLUMN 2 Interpretted SQL is faster at compile time but slower at run time. To use it, code "ENTER MASM 'ACOB$RDMR' ..." as described in the RDML PRM or Quick-Reference Guide. Note, that's ACOB$RDMR, not ACOB$RDMS. Despite its name, it can be called from UCOB programs as well. 3Embedded SQL COLUMN 2 Embedded SQL is slower at compile time but faster at run time. To use it, code "EXEC SQL ... RDML command ... END-EXEC" in a UCOB program only. Embedded SQL is not supported by ACOB. The Gen Utility will generate the APPLICATION/xxx keyword on the UCOB call for you IF IT SEES THE "EXEC SQL" COMMAND! That means, you should define the RDMCA in your Working-Storage as the RDML PRM recommends: WORKING-STORAGE SECTION. EXEC SQL BEGIN DECLARE SECTION END-EXEC. 01 RDMCA. 05 ERROR-STATUS PIC 9(04). 05 AUX-INFO PIC S9(09) USAGE BINARY. EXEC SQL END DECLARE END-EXEC. If you do this, the Gen Utility will know that the program uses embedded SQL without having to read the Procedure Division. If you don't, you'll have to @GEN,L or @GEN,R to assure that the Procedure Division SQL commands get seen. EJECT 2Targeting Code Using Column 7 COLUMN 2 This is a new feature of GEN 4.0 or higher. It is now possible to target specific lines of code to a particular compiler or application group using column 7: "A" or "a" gets translated to " " for ACOB, "*" for UCOB. "U" or "u" gets translated to "*" for ACOB, " " for UCOB. "P" or "p" gets translated to " " for QUERY, "*" for TEST. "T" or "t" gets translated to "*" for QUERY, " " for TEST. To accomplish this, GEN copies your program into a temporary file, edits the copy, and plugs the copy into the compiler. Your original program remains untouched. In order for this feature to work properly, GEN has to see an A, U, P or T in column 7 before it stops scanning. That means that you should have at least one of these 4 letters before the Procedure Division header, so that development gens will behave correctly. Prior to GEN 4.4, if you used both A/U and P/T in the same program, the P/T lines didn't get converted, and the compile would get Serious (ACOB) or Major (UCOB) errors on every line with P or T in column 7. But as of version 4.4, this bug was fixed. Furthermore, GEN 4.4 needs to see only one of A, U, P or T during the scan to generate correct code for all 4 letters. We may someday allow for other letters in column 7. "M" or "m" for MicroFocus COBOL has been suggested. (It is recommended that you stick to the upper-case letters, in case we someday run out of letters and want lower-case letters to mean something different, though that's pretty unlikely.) Example 1 (different subschemas under ACOB and UCOB): A INVOKE SUBSCHEMA LA-SUB ... (ACOB only) U INVOKE SUBSCHEMA ULA-SUB ... (UCOB only) Example 2 (adding a convenience feature for TEST): IF (DELETE-FLAG = 'Y') P PERFORM 9030-SECURITY-VIOLATION. T DELETE LA-ROOT-REC RECORD. EJECT Targeting Code Using Column 7, continued: SPACE 0 ----------------------------------------- Of course, there are pros and cons to using the column 7 technique: COLUMN 7 (1) GEN expects ACOB-unique syntax on an "A" line and UCOB-unique syntax on a "U" line, so it will not scan an "A" line if the @GEN,U option is on, nor will it scan a "U" line if the @GEN,U option is off. This allows you to put DISP-1 on an "A" line and BINARY-1 on a "U" line, for example, and GEN won't complain that it saw both ACOB-unique and UCOB-unique syntax in the same program. So the same program can be written to be compilable by either compiler without source code changes. The downside of writing ACOB/UCOB compatible code is that GEN will not be able to guess which compiler to use. So if you want to compile it to UCOB, you will have to @GEN,U it. (2) The compilers require column 7 to be " ", "*", "D", "-" or "/". So if you decide to use this technique, you MUST compile your program using GEN. Final comments regarding @GEN,AU: --------------------------------- COLUMN 2 "A", "a", "U" and "u" don't work properly if you're genning to both compilers in the same gen (@GEN,AU ...). Basically, @GEN,AU was a feature that *USED* to work, but then things got too complex and now it really doesn't anymore. In order to make @GEN,AU work properly again, GEN would now have to read the source code of the program twice: once in an ACOB frame of mind, and then again in a UCOB frame of mind. So that's been put on the back burner for the time being. Very few programs require genning by both compilers. So far, all of them have been subprograms that need to be available in both environments. So until further notice, if you need to gen something with both ACOB and UCOB, @GEN,A it first, save the outputs (and print file if you want to print them both), and then @GEN,U it. EJECT 2Using Different Versions of the Gen Utility COLUMN 2 The current version of the Gen Utility is called by typing @GEN. Older and newer versions at SBA reside in CTRI*ECLFILE. For simplicity, in the following discussion, assume that that file has a usename of "EF": CENTER @USE EF.,CTRI*ECLFILE. If the version you want is less than version 4, you'll have to copy it out of that file and execute it out of that file: @ASG,T Temp.,F///9999 @COPY,A EF.GEN/3R7,Temp. @Temp.Gen/3R7,... etc. If the version you want is greater than version 4, just execute it out of CTRI*ECLFILE.: @EF.GEN/4R3,... etc. The version of gen that's currently in development (the next level) will always be out there as simply GEN (no version name): @EF.GEN,... etc. Versions of GENDIR in CTRI*ECLFILE will always have version names. 1TROUBLESHOOTING REMAIN 14 2 Absolutes will go to the temporary file "Out.". COLUMN 2 The output file is write-inhibited (read-only, write-keyed, etc), so GEN knows better than to try to put the absolutes there. Instead, it internally assigns a temporary file called "Out." and puts the absolutes there. If GEN didn't tell you that it was doing this, you would probably wonder what happened to your outputs! REMAIN 13 2 "An Error Occurred in a Control Image - ..." COLUMN 2 This is not a GEN bug. It's a SPINX bug. GEN was written in UCOB. UCOB handles DISPLAYs differently, in order to allow a new COBOL-85 syntax (DISPLAY ... WITH NO ADVANCING). To do this, it puts out an print-width-control image (W) with a value larger than SPINX was programmed to handle. SPINX complains about it using this message. Ignore it. REMAIN 13 2 @BANNER BAD-PROGID COLUMN 2 This will only appear during a release gen. In violation of SBA standards, the program you're genning has its PROGRAM-ID different from its element name. If the program is database, you'll also get a map error (D$WORK not found). If the element name is correct, change the PROGRAM-ID. If the PROGRAM-ID is correct, change the element name. If they're both wrong, change 'em both. REMAIN 20 2 @BANNER BAD-VERBS,... COLUMN 2 This will appear only during a release gen. The program being genned has used a verb disallowed by SBA standards. GEN checks only for ALTER, DATE-TIME ACCEPTs and NOTE. * ALTER is considered a bad programming practice because its current state cannot easily be determined from a dump. * ACCEPTS,DATE-TIME: ACCEPTing FROM DATE-TIME is no longer supported under UCOB. * NOTE is no longer supported under UCOB. Convert ALTER to GO TO ... DEPENDING ON (within a PERFORM'd paragraph range, of course). Convert DATE-TIME to accept DATE and TIME separately. Convert NOTE to comments ("*" in column 7). REMAIN 17 2 @BANNER CONTAINS,MONITOR,NO-MCFLAG COLUMN 2 This will appear in a release gen with a MONITOR (@GEN,MR) if there wasn't any reference to MCFLAG in the PROCEDURE DIVISION. This is a safeguard against releasing a program while it still contains a MONITOR. If this message appears, the program is not releaseable except under the following narrow conditions: It's UCOB. It defines "01 MCFLAG PIC 1(36) BINARY-1 VALUE 0." in WS. It's not self-initializing or reentrant TIP. REMAIN 15 2 @BANNER DEVELOPMENT,GEN,<> COLUMN 2 This will appear if the gen wasn't a release gen (@GEN,R). To the programmer, this message serves to identify which program is being genned, in big letters that are legible at a distance. To Quality Assurance, this message documents that the gen wasn't a release gen, and therefore GEN's standards-compliance checking wasn't done. To do a release gen, use @GEN,R. REMAIN 14 2 @BANNER NON-STANDARD,LIBRARIES COLUMN 2 This will only appear during a release gen. In violation of SBA standards, the program being genned uses COPY statements with the IN/OF clause to reference a usename other than ASC-PROC, ATSPROCFILE, DPS, DPSTST, TIP or UCS-PROC, or else it uses a COPY statement without the IN/OF clause at all ("COB$PF"). For a more complete explanation, see the chapter on LIBRARIES. REMAIN 24 2 @BANNER OVERRIDE,GENAPP$ COLUMN 2 Prior to Version 4.2, GEN was hard-coded to always use the SBA's 2 primary application groups (TEST and QUERY). But as of Version 4.2, all application group information resides in an external table called GENAPP$. This makes it easier to install GEN at other Unisys sites, but it also allows the SBA to override GEN's behavior in special circumstances. If GEN sees a source element called GENAPP$ in a program file, it will assume that every program in that file requires non-standard handling of application groups. Generally this will be needed in early development cycles, when we want to have more than one (very different) test databases. GEN uses this banner in the breakpoint file to alert Quality Assurance that a release gen overrode the official GENAPP$, which is very likely to have been an unintentional error that could cause the production version to bomb. If you didn't intend to override GENAPP$, simply rename the source element to GENAPP$/SAVE, like so: @CHG,S <>.GENAPP$,<>.GENAPP$/SAVE REMAIN 14 2 @BANNER OVERRIDE,LIBRARIES COLUMN 2 This will only appear during a release gen. The program adheres to SBA standards with regard to libraries, but it's using the "Override Libraries" technique to release copy procs and program at the same time. GEN uses this banner in the breakpoint file to alert Quality Assurance that the new copy procs must also be evaluated and released as part of the evaluation and release of the program. REMAIN 15 2@BANNER RELEASE,GEN,<> COLUMN 2 This will appear if the gen wasn't a release gen (@GEN,R). To the programmer, this message serves to identify which program is being genned, in big letters that are legible at a distance. To Quality Assurance, this message documents that the gen was a release gen, and therefore GEN's standards-compliance checking was done. That means that, in GEN's opinion, if the program testing went ok, and there aren't any other @BANNERs, the program is releasable. REMAIN 35 2"END Msg: The @ADMLP ... aborted" COLUMN 2 9 times out of 10, this is *NOT* a problem with GEN... it's a bug in your program. If the input program is database, GEN generates an @ADMLP,CEXZ to preprocess the source before compiling it with @ACOB. Unless you use @GEN,B, there isn't any S option on the @ADMLP, because most people don't want to see ADMLP's source output. (They're going to see the source code anyway in the @ACOB step.) The only time you'd ever want to see the ADMLP source output is if you had an ADMLP abort and you wanted to see the exact source line that ADMLP was objecting to. GEN detects ADMLP aborts and warns you about them with the following messages: END Msg: The @ADMLP of to aborted. END Msg: END Msg: Usual causes are: COPY proc not found, subschema END Msg: not found or incorrect KEY for INVOKE. END Msg: END Msg: To investigate what happened: LAST END Msg: -50 END Msg: <> It then generates an @ADMLP,CESXZ (if it hasn't done so already due to @GEN,B) and skips all remaining steps of the gen. If you ever get these messages, go to the end of the printout with the LAST command and go back about 100 lines or so. Then page forward thru the breakpoint file till you see the line that caused ADMLP to abort. REMAIN 18 2@FREE,AR CSINT$$. COLUMN 2 You have executed GEN out of a program file, for example: @CTRI*ECLFILE.GEN,R File.Elt CSINT$$ is a usename that GEN attaches to the file out of which it is currently executing. (In this example, CSINT$$ would be CTRI*ECLFILE.) It's occassionally necessary to run GEN out of a user file when a new "pre-release" version is available there and it does something that the production @GEN doesn't do. Unfortunately, OS-2200 locks up the file when you do this. So GEN generates this @FREE to free up the file. That won't create problems, because, by the time OS-2200 sees the @FREE, GEN is done executing. This message doesn't appear if GEN is executing out of its production file (SYS$LIB$*SBA.GEN), which is what you get when you type "@GEN". REMAIN 11 2Map Error: D$WORK NOT FOUND COLUMN 2 Again, this is not a bug in GEN... it's a bug in your program. The program violates SBA standards by having its PROGRAM-ID different from its element name. If you make them the same, this problem will go away. REMAIN 22 2Map Error: I/O TYPE 01 CODE 22 CONT 12 COLUMN 2 This is not a bug in GEN and it's also not a bug in your program. You have overflowed the file that was to contain your output absolute. Either make the file bigger, or rerun the gen with a different output file that has more space in it. Suppose the file's name is WIGGY-WOO and its size is 128 tracks. Here's how to increase its size to 256 tracks: @FREE WIGGY-WOO. (If it's assigned to your run) @PRT,F WIGGY-WOO. (This will show its current size) @ASG,A WIGGY-WOO.,F2///256 @FREE WIGGY-WOO. @PRT,F WIGGY-WOO. (This will show its new size) A change of size doesn't take place until the file is @FREE'd. REMAIN 14 2Map Error: OIRM$ Is Not Catalogued or Assigned COLUMN 2 This message used to come out before OIRM*RLIB$ was on the file purge exception list. It should not occur anymore, because OIRM*RLIB$, QUERY*RLIB and TEST*RLIB$ are now all on the list. If it does appear, however, there's nothing you can do to get past the situation until the file is restored. Call Ada Whitley at 202-205-7199 and ask her to restore it from FAS (SECURE) tape backup. REMAIN 13 2NON-ZERO I/O STATUS... COLUMN 2 This message sometimes appears (**VERY** rarely) immediately after the @GEN line. The problem occurs when a new version of the Gen Utility is released, and your run has recently done an @GEN with the old version. It's an operating system problem, not a GEN problem. The solution is simple: @FRE, reassign your files and try again. REMAIN 13 2Scanning: ACOB COLUMN 2 GEN believes that this program should be compiled with @ACOB, not @UCOB. FIPS has mandated that all Federal agencies must migrate to COBOL-85 (eventually, not right away, thank goodness). This message is a sign that some syntax in the program will have to be changed sooner or later. REMAIN 48 2Scanning: ACOB and UCOB syntax found... COLUMN 2 GEN has been programmed to look for ACOB-unique and UCOB-unique syntax and decide whether to call @ACOB or @UCOB to compile the program. For example, the EXAMINE and EXHIBIT verbs are allowed under ACOB, but they're no longer supported under UCOB. On the other hand, a new verb EVALUATE is now allowed under UCOB, but isn't implemented under ACOB. So if GEN sees EXAMINE or EXHIBIT, it guesses that the program must be ACOB. If it sees EVALUATE, it guesses that the program must be UCOB. But what if it sees both?? If GEN were to generate @ACOB, the presence of EVALUATE verb would cause the compilation to get serious errors (SEV. S). But if it were to generate @UCOB, the presence of EXAMINE or EXHIBIT would cause the compilation to get major errors (*ERROR(MAJOR)). Not knowing what would be the right thing to do, GEN simply aborts the gen of the confusing program. If it's a mass compile, GEN will continue on trying to gen other programs. It won't abort the mass compile... just the gen of the program that it doesn't understand. Most likely, the cause of this problem is that someone chose to use a dataname that's a reserved word in one of the 2 compilers. For example: (1) DPS screen number 431 defines a field called OTHER. (2) OTHER is a reserved word in UCOB, but not in ACOB. (3) A program that uses screen 431 (LAUD13) must use the word OTHER to reference data in that field. (4) Because GEN has already determined that LAUD13 is an ACOB program, it sees both ACOB-unique syntax and UCOB-unique syntax in the same program. The same thing can happen in the other direction if a UCOB program uses a no-longer supported ACOB reserved word as a dataname. So what do you do? Well, this is a situation in which you have to tell GEN which compiler to use. If the program you're genning is ACOB, regen with the A option on; if it's UCOB, use the U option. REMAIN 15 2Scanning: Can't guess which compiler to use... COLUMN 2 This is the opposite of "ACOB and UCOB syntax found". GEN hasn't found *anything* to let it know for-sure that the program is ACOB or UCOB. Therefore, it simply tells you that it's making an assumption and continues on. Actually, this is a very good message to get. It means that you're coding well for ACOB/UCOB compatibility. REMAIN 18 2Scanning: Continuing scan into PROCEDURE ... COLUMN 2 This message appears in only 1 situation: @GEN,M of an ACOB program without the L or R Options. (If the L and/or R Options are present, the scan continues into the Procedure Division without any message.) GEN uses Source Code Substitution to edit MONITOR and MCFLAG into ACOB programs. It has to read the Procedure Division of the program to decide whether to MOVE 1 or 0 to MCFLAG. (If you reference MCFLAG, it should MOVE 0, so that the MONITOR will not start printing until you turn it on with MCFLAG. But if you don't reference MCFLAG, it should MOVE 1, so that a full MONITOR will start printing from the very beginning of the program.) REMAIN 16 2Scanning: Database COLUMN 2 GEN believes that the program is database, based on the presence of an INVOKE clause. Future versions of the UCOB compiler will allow INVOKEs that are not related to DMS-1100. For example, it will be possible to INVOKE the record description of an RDMS-1100 relational table or a COBOL flat file defined with ADP/FDP. GEN has not yet been programmed to distinguish between newer kinds of INVOKEs and a DMS-1100 INVOKE, so don't use the newer INVOKEs yet. REMAIN 8 2Scanning: Development gen COLUMN 2 This simply provides feedback that GEN is not doing a release gen. REMAIN 14 2Scanning: Development gen with MONITOR... COLUMN 2 In a development gen with a MONITOR (@GEN,M, but not @GEN,R), GEN knows everything it needs to know (to gen the program) as soon as it sees a reference to MCFLAG in the Procedure Division. So this message means that GEN is saving you from having to wait on further scanning unnecessarily. If you WANT the full-program scan, add the L Option to the @GEN call. REMAIN 18 2Scanning: Development gen without L or M Option... COLUMN 2 Since most gens are development gens (that is, not release gens), there's no need for GEN to scan the whole program every time. GEN usually knows everything it needs to know about how to gen a program by the time it reaches the PROCEDURE DIVISION header. The Procedure Division generally contains more tokens per line than the Data Division, which causes the scan to slow down considerably. So, in general, stopping the scan at the PROCEDURE DIVISION header makes GEN's scan of the program run about 5 to 8 times faster. GEN is saving you from having to wait on unnecessary scanning. If you WANT a full-program scan, add the L-Option or M-Option to the @GEN call. REMAIN 11 2Scanning: Elt not typed as COB COLUMN 2 Because you specified an input element name, GEN went ahead and processed it, even though it was not typed as COB. This message will not appear in a mass compile, because GEN will skip symbolic elements that are not typed as COB. (For more information, see the section on Mass Compiles, above.) REMAIN 20 2Scanning: Enter source code ... COLUMN 2 The program being scanned uses the Source Code Substitution feature of the Gen Utility. GEN wants to know what to substitute. If you don't know what to substitute, read the COMPILE/MAP ECL comments at the start of the program. What to enter **OUGHT** to be documented there. If it isn't, locate all occurrences of GEN- in the source code and try to figure it out by context. Once you've figured out what to enter during the gen, document it in the COMPILE/MAP ECL comments, like so: @GEN,R File.<> ... (what to enter to 1st "Enter source code ..." message ... (what to enter to 2nd "Enter source code ..." message etc. REMAIN 12 2Scanning: EOF before IN/OF COLUMN 2 The last thing in the program was the reserved word COPY, followed by a copy proc name. But there was no period to terminate the COPY statement after the copy proc name. While looking for the IN/OF clause which should have followed, GEN encountered the end-of-file condition (EOF). This error should never occur if the program is syntactically correct. REMAIN 10 2Scanning: EOF in COPY before copy proc name COLUMN 2 The last thing in the program was the reserved word COPY. While looking for the copy proc name which should have followed it, GEN encountered the end-of-file condition (EOF). This error should never occur if the program is syntactically correct. REMAIN 10 2Scanning: EOF in INVOKE before subschema name COLUMN 2 The last thing in the program was the reserved word INVOKE. While looking for the subschema name which should have followed it, GEN encountered the end-of-file condition (EOF). This error should never occur if the program is syntactically correct. REMAIN 10 2Scanning: EOF in Program-Id para COLUMN 2 The last thing in the program was the reserved word PROGRAM-ID. While looking for the program name which should have followed it, GEN encountered the end-of-file condition (EOF). This error should never occur if the program is syntactically correct. REMAIN 10 2Scanning: EOF or bad syntax in INVOKE ... COLUMN 2 In order to allow us to change schema filenames at any time, GEN read thru the INVOKE to find the mandatory "IN FILE" clause and encountered the end-of-file condition (EOF) or bad syntax. This error should never occur if the program is syntactically correct. REMAIN 11 2Scanning: Expected IN/OF, found... COLUMN 2 In a COPY statement, if the copy proc name is not followed by a period or REPLACING, it must be followed by IN or OF. GEN encountered something else. The source line where the error occurred will also be displayed. This error should never occur if the program is syntactically correct. REMAIN 9 2Scanning: Literal evaluation failure COLUMN 2 While scanning a line containing a literal, GEN got confused. This error should never occur if the program is syntactically correct. REMAIN 21 2Scanning: Looks like a main program, but ... COLUMN 2 If a subprogram doesn't contain a LINKAGE SECTION, it looks to COBOL (and to GEN) as though it were a main program. Both the ACOB and UCOB compilers have options to deal with this situation. If a program's name is on the official SBA subprograms list, GEN knows that it should be genned as a subprogram, no matter what. But if it isn't on that list, and if it *LOOKS* like a main program, GEN also has to be told that it's actually a subprogram. Because some people may already know about @ACOB,V, the option to tell GEN that a program is actually a subprogram is the same as ACOB ("V"). When you use @GEN,V, this message appears to reassure you that GEN got the message, and will gen the program as a subprogram. REMAIN 9 2Scanning: MCFLAG in PD... COLUMN 2 An ACOB program references MCFLAG in the Procedure Division, so GEN will not generate a "MOVE 1 TO MCFLAG." after the MONITOR. UCOB programs shouldn't rely on this, because GEN doesn't edit MONITOR statements into UCOB programs. Instead, UCOB programs should explicitly define MCFLAG, which is allowed under UCOB ("01 MCFLAG PIC 1(36) BINARY-1 VALUE 0."). Also, if the UCOB program is self-initializing TIP, it should always reset MCFLAG to 0 before terminating, because self-initializing transactions cannot rely on VALUE clauses. REMAIN 9 2Scanning: MCFLAG not in PD... COLUMN 2 An ACOB program does *not* reference MCFLAG in the Procedure Division, so GEN *will* generate a "MOVE 1 TO MCFLAG." after the MONITOR. REMAIN 17 2Scanning: No Division headers! COLUMN 2 The most likely cause of this problem is that you tried to @GEN a program that wasn't COBOL (an add element or a copy proc perhaps). This can happen inadvertantly during a mass compile if a non-COBOL element is typed as COB. Have a look at the element with @ED or @QED. If it actually is a COBOL element, make sure that the IDENTIFICATION, ENVIRONMENT, DATA and/or PROCEDURE division headers begin in "area A" (columns 8-11). If it isn't COBOL, type it as ELT (or SSG or whatever you think would be appropriate) so that it won't be picked up accidentally in a mass compile, and don't try to @GEN it directly. REMAIN 16 2Scanning: Non-standard IN/OF libname(s) COLUMN 2 In a COPY statement, the program has a usename following IN or OF which does not conform to SBA programming standards, or else the IN/OF clause is omitted entirely (which also violates standards). What to do: For most procs, specify IN ASC-PROC. For DPS screens, specify IN ATSPROCFILE. For DPS system procs, specify IN DPS For TIP system procs, specify IN TIP For UCOB-unique procs, specify IN UCS-PROC. REMAIN 10 2Scanning: NOTE verb: chg to comments COLUMN 2 The NOTE verb is no longer supported in COBOL-85. Also, the logic in GEN to ignore meaningless words was already complex enough, so we chose not to support this archaic verb. Change all lines in the scope of the NOTE to comment lines ("*" in column 7). REMAIN 10 2Scanning: OBJECT-COMPUTER should be ... COLUMN 2 The SOURCE-COMPUTER and OBJECT-COMPUTER paragraphs should specify whatever value generates the most efficient code for our current environment. (Be advised that the most efficient code for signed numeric fields is to *ALWAYS* have an "overpunch" character.) REMAIN 24 2Scanning: Override Libraries COLUMN 2 See the discussion of override libraries earlier in this manual. During the scan, a COPY ... IN/OF clause was found for a usename on the official SBA library list, and a file named "MY*<>" was already assigned to the run. If the override library file ("OVERRIDE*<>") doesn't already exist, GEN will create and use it; if it DOES already exist, GEN will continue to use it. In either case, the override library file will be the production library, as overridden by the contents of the "MY*<>" file. **NOTE!!**: The reason why this message appears is to remind you that override libraries are still active. (That may not have been what you wanted. You might have had the override libraries left around from other gens that you did earlier in the same run.) The easiest way to throw away override libraries is to @FRE,R. REMAIN 9 2Scanning: Program-Id not same as elt name COLUMN 2 In violation of SBA programming standards, the program-id of the program is not the same as the element name. Decide whether to change the element name or the program-id. REMAIN 8 2Scanning: Release gen COLUMN 2 This simply provides feedback that GEN is doing a release gen. REMAIN 14 2Scanning: Releasing MONITOR, be careful COLUMN 2 This means that a release gen contains a MONITOR (@GEN,MR) in a manner that seems allowable. Because there's a reference to MCFLAG in the PROCEDURE DIVISION, GEN is assuming that you know what you're doing and not prohibiting it by generating "@BANNER CONTAINS,MONITOR,NO-MCFLAG". REMAIN 12 2Scanning: Releasing MONITOR without any MCFLAG... COLUMN 2 This means that a release gen contains a MONITOR (@GEN,MR) in a manner that seems like a blunder. Because there isn't any reference to MCFLAG in the PROCEDURE DIVISION, gen prohibits it by generating "@BANNER CONTAINS,MONITOR,NO-MCFLAG". REMAIN 13 2Scanning: SDF Label not found COLUMN 2 GEN is having trouble reading the element. The element could be trashed, or there could be a bug in GEN. To resolve which, try to edit it with @ED or @QED. If neither one of them can read it, the element is trashed. If one of them CAN read it, report it as a bug in GEN. (See below, "What To Do If Any Other Kind of Error Occurred"). REMAIN 10 2Scanning: Source date/time NOT SET COLUMN 2 On a release gen, GEN attempts to reset the input source element's date/time stamp, so that it will be fairly close to the date/time stamps of the output absolute(s). This message warns you that, for some unknown reason, this attempt failed. REMAIN 10 2Scanning: Source date/time reset COLUMN 2 On a release gen, GEN attempts to reset the input source element's date/time stamp, so that it will be fairly close to the date/time stamps of the output absolute(s). This message warns you that the date/time stamp was reset, so that you won't think that it was re-edited by someone. REMAIN 10 2Scanning: SOURCE-COMPUTER should be ... COLUMN 2 The SOURCE-COMPUTER and OBJECT-COMPUTER paragraphs should now specify "UNISYS-2200", the implementor-name that generates the most efficient code (and is the most accurate documentation) of our current environment. REMAIN 17 2Scanning: Subprogram COLUMN 2 GEN believes that this program is a subprogram and will gen it as one. If the program isn't a subprogram, this message was caused by one of the following problems, which you must correct: COLUMN 11 (1) The element name is the same as one of the official SBA subprograms. (If so, change it to something else.) (2) The program contains a LINKAGE SECTION, even though it isn't a subprogram. (If so, remove it.) (3) UCOB programs are allowed to omit the PROCEDURE DIVISION if it isn't being used. A typical example of when you may want to do that is to have a table reside external to a program and pick it up at LINK time (using APPLY EXDEF and APPLY EXREF). So if GEN doesn't see PROCEDURE DIVISION in a UCOB program, it assumes that it's a subprogram and doesn't try to LINK it into a ZOOM. Caution: If the PROCEDURE DIVISION header of a UCOB main program is in a copy proc, GEN would misbehave, because GEN doesn't read copy procs. In that case, move the PROCEDURE DIVISION header out of the copy proc and into the main program. REMAIN 15 2Scanning: UCOB COLUMN 2 GEN believes that this program should be compiled with @UCOB, not @ACOB. GEN can mistakenly believe that an ACOB program is UCOB if it defines a dataname that's a UCOB reserved word allowed in the Data Division. For example, if an ACOB program defines a dataname called "BINARY-1", GEN will think that the program is UCOB. For a more detailed explanation, see the following Scan Message. REMAIN 26 2Scanning: UCOB reserved word used in Data ... COLUMN 2 UCOB defines many new reserved words. Most ACOB programs were written before the new words were reserved. As a result, some ACOB programs use UCOB reserved words as datanames. The most common example is OTHER (which can now be used in a clause of the UCOB verb EVALUATE), because it's well-liked by programmers as a dataname. To avoid accidentally treating the program as UCOB, GEN has been programmed to know that certain UCOB reserved words are only used in the Environment and/or Procedure Divisions. GEN will ignore them if they are encountered in the Data Division, but it will also print this Scan Message to let you know that the program will have problems when it's converted to UCOB. GEN will not detect reserved words in copy procs. This is mostly a problem with DPS screen copy procs. If this message appears in a UCOB program, it means that GEN didn't realize that this reserved word was legal in a UCOB Data Divison. No harm was done, but GEN should be fixed to realize that it's *always* a UCOB reserved word. REMAIN 10 2Scanning: Uses COMPOOL primitives ... COLUMN 2 The program calls CINIT, CRTRNO, etc, which are not UCOB compatible. If you have time to clean up the program, it should be converted to use DPS's new entry point names (D$INIT, D$SEND, etc). See the following message. REMAIN 10 2Scanning: Uses old DPS names ... COLUMN 2 The program calls INITIALIZE, READ, etc, which are not UCOB compatible. If you have time to clean up the program, it should be converted to use DPS's new entry point names (D$INIT, D$SEND, etc). See the previous message. REMAIN 10 2Unable to find OM preamble COLUMN 2 This is a bug in GENDIR 1.2 that occurs when you @GEN,M a very large UCOB program. It's fixed in GENDIR 1.3 and higher. A workaround for GENDIR 1.2 would be to use MONITOR/LABEL instead. (See "SPECIAL TOPICS - Changing GEN and GENDIR's Behavior", above.) REMAIN 28 2What To Do If Any Other Kind of Error Occurs COLUMN 2 Well, first see if you can figure out what caused the error. There's no sense in reporting a bug if the problem is that you misspelled the program name, or you forget to PDP a copy proc. But if it isn't something obvious, here's what to do: COLUMN 10 (1) Catalog a file in which to pass the program. Make sure that it's public and not read-keyed. (2) Copy the program (the one that caused GEN to generate incorrect compile/map ECL) into that file. (3) If it needs any test copy procs, copy them into the same file. (4) Send an E-Mail via Higgins to Stephen R. Seaquist. Tell him the full Qual*File.Elt/Ver name of where you put program. If you want, include a description of what GEN did wrong. (5) Fall back to your previous compile/map ECL element to gen that program until the problem is resolved. COLUMN 2 EJECT SPACE 15 CENTER This page was intentionally left blank. CENTER so that the table of contents will begin CENTER on a new page, allowing you to move it CENTER to the front of the manual. ROMAN ON @EOF @CAT,P GenVerHist.,F2///999 @ASG,A GenVerHist. @DOC,DEFI TPF$.VerHistElt,,GenVerHist.,FORM,0*1.53/61,50/79,1/66,0*0.0/0 The SBA COBOL Gen Utility's Version History COLUMN 7 SETCTR 1,2 1VERSION 2 SETCTR 2,15 2Version 2.15 (SSG Prototype) (1) Support for APPLY EXREF ON DBMODE (used with the copy proc DBMODE-WS). (2) Support for MMS in non-database, non-TIP programs. (3) Simpler, more flexible handling of subroutines. (4) First version that included a list of changes. This later involved into GEN's version history. All record of changes in earlier versions has been lost. 2Version 2.16 (SSG Prototype) (1) Allowed users to @SYM the gen listing file by its usename. (2) Support for a new subroutine, SECERRLOG. 2Version 2.17 (SSG Prototype) (1) Support for LOC$ and UCSGENERAL$ under ACOB! 2Version 2.18 (SSG Prototype) (1) Q-Option now does FC END in Q/EDitor. 2Version 2.19 (SSG Prototype) (1) Less ECL scrolling across the screen. (2) Mass-compile mode avoids PCT overflow. 1VERSION 3 SETCTR 2,0 2Version 3.0 (1) Converted from SSG to a compiled UCOB program with no assembly language code whatsoever. The speed improvement is breathtaking. (2) Only one @BRKPT, which eliminated the need to concatenate several print files into one at the end of the gen. (3) Dramatically eased up the restrictions on test libraries. They no longer have to come from a file called MY*ASC-PROC or MY*ATSPROCFILE. This was accomplished by requiring COPY ... IN <> and complaining about any non-standard library usenames. The current politically-correct usename list is ASC-PROC ATSPROCFILE DPS DPS4 TIP UCS-PROC DPS points to the libraries for the current level of DPS. DPS4 points to the libraries for the upcoming level of DPS, DPS4R1F, so that early use or testing can occur. Anonymous copylibs are COPY statements without the IN/OF clause. Anonymous copylibs show up in the gripes as coming from COB$PF. COB$PF is equated to OCS*ASC-PROC, but the gripes won't go away until the programmer codes IN ASC-PROC into all anonymous COPY statements. (4) GEN now recognizes and handles COBOL-85 (UCOB) programs correctly. The only significant restriction is that all user subprograms have to reside in OIRM*RLIB$ in order to be found at @LINK time. EJECT Version 3.0, continued: ----------------------- (5) GEN can now map any program without having knowledge or access to the source code. GEN always had the ability to map non-database programs directly from the relocatable. But it couldn't handle database program rels because it had no way of deducing what the subschema name was. That meant that database programs had to be compiled as part of the gen, so that GEN could determine the subschema name from the INVOKE om the source code. Now GEN reads the D$WORK relocatable text to determine the subschema name, something that was well-nigh impossible when GEN was written in SSG. This means that it is now feasible to save relocatables for remap in situations where no source code changes are required. (6) Mass compiles are now done by simply specifying a filename and not following it by an element name. (7) The output absolutes are automatically saved to the output file. (8) ******** NO @DOWN IS DONE IN RELEASE GENS ******** SPACE 0 Because GEN is now usable by all 3 Branches of OISS, it has no way of knowing how to @DOWN programs correctly. This is a major Quality Assurance issue, so we **WILL** resolve it somehow, and soon. (9) ******** NO TIP INSTALLATION ELEMENT IS CREATED ******** SPACE 0 The SSG Prototype was only used within SB2. That meant that it was possible to deduce the name of the test version of the transaction, because it always began with X. Also, the addstream to add was always SB2MOVE. But other branches can use T as the first letter of test TIP transactions names, and they add different addstreams. For the time being, this feature will have to saved for future implementation. EJECT Version 3.0, continued: ----------------------- (10) Re-entrant TIP Transactions are now mapped correctly for the first time ever at SBA. That means they will remain in memory between executions. That means that we can no longer get away with sloppy coding. If they are trully self-initializing and re-entrant, we will see an enormous improvement in throughput on our most heavily used transactions. On the other hand, if they are actually self-destructive in how they were coded, we will see bomboffs. Testing of TIP Transactions must be thorough! (11) GEN now gives meaningful feedback to the screen. For example, as it discovers things about the program, it displays that information. This inspires the programmer/user with the warm fuzzy feeling that GEN actually knows what it's doing. At the end of all scans, it displays elapsed time, token count, line count and (if it's a mass compile) element count. This is useful statistical information that was used to speed up GEN's handling of tokens (reserved words, user-defined words, special characters, etc) by 50%. It may be used again for further optimizations. (12) GEN now detects more violations of SBA Programming Standards than it ever did before. It protests with a banner (BAD-VERBS) if the program uses ALTER or NOTE (an obsolete verb that would screw up GEN's syntax scan). It detects and complains (to the screen, not a banner) if the PROGRAM-ID is not equal to the element name. It does not yet look for RUN-UNIT-ID being equal to PROGRAM-ID, however. EJECT 2Version 3.1 (1) Improved @MAP,R's of multibankable subroutines. (2) Improved automatic editing of UCOB programs' breakpoint files. (3) Allowed saying simply "@GEN" (that is, with no input filename or element name). According to the "dropout rules", doing so would result in a mass compile of TPF$. This was mainly done to allow "@GEN,H" with no input filename or element name. 2Version 3.2 (1) Produce a banner (BAD-PROGID) if the PROGRAM-ID doesn't match the element name (during release gens only). (2) Ignore catalogued MY* files to discourage this technique. (3) Get the online documentation from a different file, so that Ron Noble won't have to re-install GEN every time the documentation changes. (4) Release gens for PMS Branch now generate @DOWNs. The decision criteria are as follows (pseudo-code): IF (first 2 chars of elt name = LE or PM) OR (first 3 chars of elt name = DML or LAU or SOI) OR (entire elt name = LABR93 or LABR94) Generate an @DOWN compared to AASC*ASC-PROD ELSE Can't gen @DOWN; need further criteria. EJECT 2Version 3.3 (1) GEN now generates @DOWNs for all programs that were in Dick Thiebaud's COMPSKEL for SB1. (2) *ALL* "canned ECL" support routines now reside in a separate file (not just the online documentation), so that we can change them without requiring Ron Noble to re-install GEN. (3) The "autoedit" of the breakpoint file now finds all @BANNERs, so that you'll know of them before you print it out. (4) A new secret technique is available to use MSB*DSPF for ASC-PROC, ATSPROCFILE and COB$PF. This was put in for Joyce Able's group, which has special permission to use this file until their programs are converted to standards. (5) A problem that caused long @MAP and @LINK lines to truncate the output absolute's version name has been fixed. (There still remain 2 small bugs in the area of version naming, however.) (6) If a singlebanked subprogram or a UCOB subprogram is genned, GEN will now copy the relocatable or object module to the destination file specified in the @GEN call. And if the input and output file names are the same, it won't. (7) In non-release gens for some programs, GEN 3.1 and 3.2 used to complain about non-standard IN/OF library names (COB$PF) when there really weren't any. It would then go on to try to list them and produce an empty list (because there weren't any). This annoyance has been banished from the breakpoint file. (8) Although it's an SBA standard that all TIP transactions must be self-initializing, it may not always be the case that they were correctly written to do this. Because GEN finally maps self-initializing and reentrant programs correctly, and because this sort of bug may have gone undetected for years, it's possible for GEN to regen an unmodified, production program and yet have that program suddenly stop working. If this happens when we have time to debug what the cause was, no problem. The responsible programmer simply has to bring the program up to standards (debug what fields are not being initialized). EJECT Version 3.3, continued: ----------------------- But if this happens in an emergency, when we don't have time to debug a program's self-destructive code, we need the ability to generate old-style maps (with the DBANK as the Control Bank). The technique to do this is not being documented at this time, because all of our TIP transactions should be self-initializing. But a secret technique HAS been added to generate old-style maps in an emergency. (9) IBANK directives are now being generated for the ABORT and DPS4 pseudo-subprograms. (10) A rare bug, when ACOB-unique and UCOB-unique syntax were detected in a program in that order (ACOB, then UCOB), has been fixed. (11) The same code which now allows SB1 programs to be @DOWN'd in release gen can be used in the future to determine which branch a program belongs to and, if it's TIP, generated appropriate add elements to install it with TIP. (It would still be the programmer's responsibility to @ADD that element, however.) (12) Previous versions of GEN left SCHEMAFILE assigned, making it harder for Mahmood Shah to do schema and subschema compiles. GEN now frees SCHEMAFILE after the ADMLPs have been done. EJECT 2Version 3.4 (1) GEN now supports genning LABD15: (a) All of its subprograms and their entry points are now recognized as multibanked subprograms. (b) AASA*LABD15LIB is now recognized as a production file for @DOWN'ing in release gens, and as a library file for the COPY statement's IN/OF clause. (2) GEN now supports genning its own external tables. (3) GEN now supports @DOWN'ing SB3 programs against MSP*DSPF. (4) GEN now knows exactly which programs are SB1 and SB2. (In 3.3, it had to guess about non-SB2 programs.) (5) GEN now supports static multibanking (required by LABD15). (6) 2 new options are now allowed on the @GEN call: FXFORM (a) @GEN,F - Floating point (@ACOB ,,,,T) (b) @GEN,S - Syntax only (@ACOB ,,,,5) (@UCOB ,,,,,NO-CODE) END (7) The override libraries technique was extended to affect @MAP and @LINK directives. As a result, the "DPS4"/"DPSTST" feature was removed when it became apparent that it was no longer necessary. (8) The entire subprogram handling process was vastly simplified by moving all official SBA subprograms into OIRM*RLIB$ and putting that filename into GEN's production library list. Now *ANY* subprogram (if it isn't database and doesn't have to be multibanked), can be mapped in, simply by using the override libraries technique: @FREE MY*OIRM$. @FREE OVERRIDE*OIRM$. @ASG,T MY*OIRM$.,F///9999 @COPY,R <>,MY*OIRM$. @GEN... EJECT Version 3.4, continued: ----------------------- (9) Taking advantage of a new feature of the SB4R4 compilers, GEN now knows whether or not the run is batch and will not generate @BRKPT separators in mass compiles (saving paper). (It still breakpoints to *files*. All it stopped doing was producing those nuisance 1-page printouts *between* the breakpoints to files.) (10) GEN now supports UCOB programs that use DMS-1100. (UCOB programs that use DBIOCs or MMS are still not directly supported. Until direct support is added, override OIRM$.) (11) 2 small bugs relating to version names have been fixed: If a program was DMS-1100, or used MMS or a DBIOC, and it was genned using the R option (or both the T and P options), GEN generated TEST and QUERY absolutes, but gave them both the same version name. The result was that the second absolute deleted the first one. In version 3.4, this has been fixed. (12) GEN now diagnoses SOURCE-COMPUTER and OBJECT-COMPUTER not equal to "UNISYS-2200", the implementor-name which results in the most efficient code (and most accurate documentation) of our current processing environment. EJECT Version 3.4, continued: SPACE 0 ----------------------- (13) Usually, GEN reads COBOL source code to generate compile ECL, and part of the compile ECL is a call to @GEN,M (before GEN 4.0) or @GENDIR (GEN 4.0 or later). For simplicity, let's just call it GENDIR, even though it didn't get that name till GEN 4.0. In the compile ECL, when GENDIR gets control, it reads the relocatable directly to generate the map directives. So usually, all the proper files are assigned before GENDIR gets control. As a result, previous versions of GENDIR relied on those files already being available. As of level 3.4, GENDIR no longer requires that the files were already set up by a compilation run of GEN. This allows GENDIR to be run more easily on relocatables and object modules directly (manually). It looks to see if the relocatable libraries for DPS, TIP and OIRM$ are assigned. If they are, it leaves them alone, so that override libraries can still be passed to it from a GEN compilation addstream. But if they aren't, it attaches the proper usenames to those 3 production library files, because the generated map directives reference those usenames. (14) GEN now passes its own SBA programming standards enforcement. EJECT 2Version 3.5 (1) The following bugs in GEN Version 3.4 were fixed: COLUMN 11 (a) Failure to pick up override libraries at map time if they weren't referenced in COPY statements at compile time. (b) Generating incorrect default absolute names for non-database main programs that called database subprograms. (c) Not ignoring columns 8-72 of lines that contained '/' in column 7. COLUMN 7 (2) MMS programs would get a map warning that the CERU$ entry point MMSCB was already defined. This didn't hurt anything, but still some people worried that it might cause a runtime error, and others objected in principle to ignoring a map warning. Per Ron Noble's assurance that CERU$ is no longer needed by our COBOL programs, CERU$ is now being NOT'd out of all maps that create an absolute. (3) In all subprograms that are "mapped to themselves", GEN now preserves WITH ENTRY POINTS names with the DEF directive. (Previous versions of GEN preserved only the Program-Id, also known as the "main entry point". GEN 3.5 preserves *ALL* entry points that it knows about.) (4) GEN now documents the date/time GEN was created in the output breakpoint file. (Previously it documented only its own version number.) EJECT Version 3.5, continued: ----------------------- (5) A very-often-requested new feature has been added, namely, genning TIP transactions to their actual transaction names. If the RO element name on the @GEN call is "T" or "X", GEN knows that that's how you want to gen. Moreover, it knows what letter to use as the first letter of the transaction name in the case of TEST. For example: "@GEN,R JohnsFile.LAUD03,.X" creates XAUD03 & LAUD03. = = "@GEN,R JoansFile.SSDD01,.T" creates TSDD01 & SSDD01. = = It doesn't do this for **ALL** 1-character output element names, incidentally, just "T" and "X". Anything else in the output element field will be used as the entire output absolute name. And yes, it DOES work in mass compiles. (6) During release gens, @DOWN would sometimes complain "TOO MANY SPECIFICATIONS" and stop processing. This is a problem with @DOWN, not @GEN, but still, it resulted in less-than-ideal release gen breakpoint files. GEN 3.5 works around the problem by using usenames. Also, all @DOWNs now use the B and Q options. This allows the programmer the freedom to line up columns for readability without forcing a change number in columns 73-78. For example: MOVE XXXX TO YYYY. MOVE AAAAAAAA TO BBBBBBBB. MOVE PP TO QQ. is hard to read; it can now be cleaned up to: MOVE XXXX TO YYYY. MOVE AAAAAAAA TO BBBBBBBB. MOVE PP TO QQ. If you're looking for places where a dataname is modified, it's much easier to find them if most of your TO's start in column 40, or wherever. GEN's previous @DOWNs discouraged readability by identifying ALL changes, not just changes that are syntactically significant. EJECT Version 3.5, continued: ----------------------- The new @DOWNs generated by GEN 3.5 will ignore differences caused solely by spaces outside of quotes. Spaces inside quotes *ARE* syntactically significant an *WILL* still be caught by the new @DOWNs. Also, the new @DOWN's will now have their own @HDG to set them off from the rest of the gen listing. (7) Source Code Substitution was implemented to help out the programmers who work on the SSDD security transactions. (The security subschema has different keys for TEST and QUERY. This makes it very hard to gen programs that use that subschema without Source Code Substitution.) The Users Manual was updated to reflect how it actually operates. Previous documentation was speculation and should be ignored. EJECT 2Version 3.6 (1) Another often-requested feature has been added to improve support of some branches' release procedures: On a release gen, each source element that gets genned will have its date/time stamp reset to the time when @GEN processed it, and the element subtype will be set to COB. As a result, on a single gen, the source and absolute(s) date/time stamps will generally be within a minute or 2 of one another, as required by some (but not all) release forms. On a mass compile, the source and absolute(s) date/time stamps may be a bit further apart. Of course, if the input file is read-only, or write-keyed and assigned without the write key, the date/time stamp cannot be altered. In those cases, GEN will warn you that the change failed. Also, if GEN refuses to gen a source element for some reason (usually because the element doesn't seem to be COBOL), or if the current gen isn't for release, GEN will leave the source element untouched. (2) A lot of people didn't like seeing the banner "DONTRELEASE" on development gens (non-release gens). Its purpose was to alert Quality Assurance that GEN's standards- compliance validation had not been done, but it SEEMED to be complaining that it found a bug or something. To make a lot of people happier, this has been changed to one of two new banners, depending on the type of gen being done: @BANNER DEVELOPMENT,GEN,<> or @BANNER RELEASE,GEN,<>. A pleasant side-effect is that all gen listings will now display the program name in big letters, visible at a distance. (3) Genning UCOB programs to TCOMP and QCOMP has been fixed. (GEN will now link in the TCOMP and/or QCOMP SCHEMAFILE, when appropriate.) EJECT Version 3.6, continued: ----------------------- (4) An obscure bug was fixed: If the program being genned used anonymous copylibs (naughty naughty! it ought to use "IN ASC-PROC" instead!), and copy procs for ASC-PROC were being tested using the "override libraries" technique, GEN would fail to pick up the new copy procs. A by-product of this fix is that the "override libraries" scan message now comes out together with all the other scan messages, before the line count. (It used to come out after the line count.) And it will only come out if the program being genned actually referenced that library during the scan. Another by-product of this fix is that GEN will now detect and use override libraries on manual @GEN,M (before 4.0) or @GENDIR. (It still won't *build* the override libraries, but at least now it will use them if they were already built by an earlier gen of source code.) Last but not least, GEN's handling of override libraries is now more efficient, especially during mass compiles. (5) Until recently, we haven't needed to use LINK$PF in UCOB gens. Now we do. GEN 3.6 generates the proper @USE statements for LINK$PF at SBA: TEST and TCOMP SYS$LIB$*APP$1. QUERY and QCOMP SYS$LIB$*APP$2. Everything else SYS$LIB$*APP$3. (6) In response to a need in the PMN subsystem, the Source Code Substitution feature has been expanded to allow up to 66 characters of substitution value across the entire syntax range of a COBOL statement (columns 7 thru 72). (Now the limiting factor is the size of the generated Editor change command, which must be no greater than 80 characters.) Also, the substitution value is now terminated by the *LAST* blank, not the first blank. This allows substituting complex phrases such as FETCH FIRST PMN-ADDR-REC ..., etc. It also allows substituting the empty string when you enter a blank line in response to "Enter source code ...". Finally, if the @GEN call itself is breakpointed, the substituted value will be echoed to the printer. EJECT Version 3.6, continued: ----------------------- (7) Some people occasionally want GEN to scan the Procedure Division, even in development gens. For example, you may be forced to put Source Code Substitution into the Procedure Division, or you may want to pre-verify that the program will pass SBA programming standards before doing a release gen. @GEN,L will force a full-program scan as of Version 3.6. As part of the same new feature, the scan message "Not a release gen..." has been changed to remind us how to get GEN to scan further: "Development gen without L Option..." (8) As requested by Dick Thiebaud, GEN 3.6 allows overriding the "ECL$" file, from which all ADDELT's and UCOBOPTS are taken. The method is the same as for override libraries ("MY*ECL$"), except that an "OVERRIDE*ECL$" file will not be built. The reason is that it would be too late for the override to take effect in the generated ECL. Therefore, you have to build it yourself, like so: @ASG,T MY*ECL$.,F///9999 @COPY GENUTIL*ECL$., MY*ECL$. @COPY,S <>,MY*ECL$. @COPY,S <>,MY*ECL$. <> @PACK MY*ECL$. @GEN ... EJECT 2Version 3.7 (Never Officially Released) (1) GEN is smarter about ACOB programs that use UCOB reserved words as datanames. If the dataname can *only* be used outside of the Data Division of UCOB programs (for example, "OTHER"), GEN will merely complain, not think that the program is UCOB. (2) Source Code Substitution allows slightly longer substitution values. (3) A small bug was fixed: Programs that call WORKADD but don't call WORKDAY will now get TIP$*TIPLIBREL mapped in. EJECT 2Version 3.8 (1) GEN now supports TEST*RLIB$ and QUERY*RLIB$. This provides a cleaner, safer way to handle subprograms that are unique to an application group. (2) The new B-Option means "before copy procs' line numbers": This feature was requested by Fred Sage. It assures that the ADMLP step will always have the S-Option, allowing you to see the line numbers before copy proc lines were added to the DMLOUT. (3) The new E-Option means "error handling": GEN will tell the compilers to do range checking on subscripts, parameter count checking (UCOB only) and generating the Symbolic Debugging Dictionary for PADS. (4) The new W-Option means "upside-down M, for MONITOR". (Note: This was changed to the M-Option in GEN 4.0. To avoid confusion, the following discussion describes the way things are now): This is a *GREAT* convenience feature. Just put your "MOVE 1 TO MCFLAG" lines wherever you want them and gen with the M-Option. In the case of ACOB, GEN will edit in a MONITOR at the top of the PROCEDURE DIVISION (with MCFLAG initially 0); to do this, GEN uses the Source Code Substitution mechanism; that is, it edits a copy of the program and then gens the copy. In the case of UCOB, GEN will use the compiler option MONITOR. Also important is that GEN will now suppress MONITORs if the M-Option is not used. This will make it much less likely for someone to *ACCIDENTALLY* release a program to production containing a MONITOR. (It will still be possible to do it ON PURPOSE, but this feature now provides a great deal of safety against accidents.) EJECT Version 3.8, continued: ----------------------- (5) GEN now supports S-OFF and SLIST for UCOB programs. @UCOB doesn't support S-OFF and SLIST yet. @GEN simulates UCOB support by @ADD-ing ECL$.ADDELT/S-OFF--SLIST at the start of the "auto-edit" of the breakpoint file. This add element contains an Editor LOOP to delete all breakpoint lines between S-OFF and SLIST. GEN will only add this add element under the following 3 conditions: The program is UCOB. The program contains S-OFF or SLIST in columns 1-5. The breakpoint is being viewed with @ED (not @QED). (6) 6 FIR programs were added to the list of programs that allows GEN to generate @DOWNs in release gens. (7) The official libraries list now resides outside the Gen Utility, so that it can be revised without fiddling with the internals of the Gen Utility. The list now contains some more fields, which allowed cleaning up the code that handles the list. (8) In many other ways, the internal code of the Gen Utility has been made simpler and easier to maintain. EJECT 2Version 3.9 (1) GEN now supports turning MONITOR on and off without having to repeatedly edit MCFLAG into and out of the source code: In any gen with MONITOR (@GEN,M), GEN will scan the Procedure Division looking for references to MCFLAG. If no reference is found, GEN assumes that the program is to begin execution with MCFLAG equal to 1. If a reference to MCFLAG *is* found, GEN assumes that the program is to begin execution with MCFLAG equal to 0. That means, if all you want to do is generate a full MONITOR, you don't have to edit "MOVE 1 TO MCFLAG." into and out of your source code (just @GEN,M). But if you want more explicit control than that, you will still have to edit in the MOVE's to control it. SPECIAL CASE: If your program is UCOB, and you code in explicit MONITOR controls with MCFLAG, and you want your program to clean-compile regardless of whether or not you use @GEN,M, you will have to code "01 MCFLAG PIC 1(36) BINARY-1 VALUE 0." into Working-Storage. (2) In response to public outcry, @GEN without the MONITOR option no longer suppresses manual MONITORs. Instead, it detects manual MONITORs in a Release Gen and decides whether to complain based on whether or not MCFLAG appears somewhere in the Procedure Division. (3) Previously, GEN used to generate a DOWN in a release gen. Now that functionality has been offloaded to a separate program called DOWNER (= "DOWN compared to Earlier Release"), and GEN simply calls DOWNER. This was done: COLUMN 10 * to lower GEN's memory requirements, * to allow you to run DOWNER outside of a gen, and * because DOWNER does a better job at generating DOWNs: COLUMN 13 * First it searches the official production source file (PROD$*GET$ if the program isn't part of LABD15). * Then, if the program wasn't found in that file, it searches whichever "unofficial" production source file is appropriate for the program being DOWNER'd. (xxxx*ASC-PROD, xxxx*PRODSRC, MSP*DSPF, etc). * It doesn't lock up the production file during the DOWN. * It can insert change numbers. * And in Demand Mode, it'll even generate a breakpoint for you if you aren't already breakpointed. COLUMN 7 EJECT Version 3.9, continued: ----------------------- (4) GEN now links UCOB DMS/MMS programs correctly. It still has problems with non-DMS UCOB programs that call PRTLNK or a DBIOC (database subprogram), however. (5) The @GEN,H online documentation has been modified to make the Users Manual and Version History print gorgeously on device F117P. After printing them on this device, move the Table of Contents page(s) from the back to the front of each printout, put your old title pages in front of the TOCs, and you're "good to go". 1VERSION 4 SETCTR 2,0 2GEN 4.0 / GENDIR 1.0 (1) GEN strips frees and assigns out of development gen listings to save paper. They still appear in release gens (@GEN,R), for Quality Assurance reasons, and in long gens (@GEN,L). If you change your mind, and want to print the frees and assigns after a development short gen, you can do the following (assuming you haven't @FIN'd, @FRE'd or @GEN'd another program): @ED,QU Lst. ADD+ FreesAndAsgs. LAST ADD+ Frees. EXIT @SYM,U Lst.,... (2) Column 7 can now be used to target lines for ACOB or UCOB: Col 7 Is translated to ----- ---------------- A or a " " if genning to ACOB, "*" otherwise. U or u " " if genning to UCOB, "*" otherwise. If you use this feature, you MUST gen your program with GEN. Compiling directly (with these codes still in column 7) will result in compiler errors. This feature is primarily for writing compiler-neutral programs, where inflexible differences between ACOB and UCOB prevent the source code from being identical. Example 1 (different subschema): A INVOKE SUBSCHEMA LA-SUB ... U INVOKE SUBSCHEMA ULA-SUB ... Example 2 (syntax difference): A TRANSFORM Dataname FROM LowerCase TO UpperCase. U INSPECT Dataname CONVERTING LowerCase TO UpperCase. EJECT GEN 4.0 / GENDIR 1.0, continued: -------------------------------- (3) Column 7 can also be used to target lines for test or production: Col 7 Is translated to ----- ---------------- P or p " " if genning to Production, "*" otherwise. T or t " " if genning to Test, "*" otherwise. If you use this feature, you MUST gen your program with GEN. Compiling directly (with these codes still in column 7) will result in compiler errors. This feature is primarily for those times when the test and production databases are significantly different, but Source Code Substitution would be too cumbersome to use. Example (VIA SET record made an OCCURS ... DEPENDING ON table): P FETCH FIRST Addr-Rec WITHIN SetName SET. P PERFORM Process-Addr-Recs UNTIL ... T PERFORM 1030-Process-Addr-Recs T VARING Addr-Idx FROM 1 BY 1 UNTIL ... 1030-Process-Addr-Recs. DISPLAY Addr-Street T (Addr-Idx) UPON PRINTER. P FETCH NEXT Addr-Rec WITHIN SetName SET. DBMODE is still available for distinguishing between test and production when there aren't any syntactical differences. (4) A new standard copy library usename "PROC" is now available. It's not a new library. It's just a new way to reference the existing libraries ASC-PROC (in ACOB gens) and UCS-PROC (in UCOB gens). Example: COPY ComCon IN PROC. is the same as coding A COPY ComCon IN ASC-PROC. U COPY ComCon IN UCS-PROC. EJECT GEN 4.0 / GENDIR 1.0, continued: -------------------------------- (5) GEN now recognizes "Embedded SQL" statements in UCOB programs that use RDMS-1100. The presence of EXEC SQL ... END-EXEC. tells GEN to generate APPLICATION/TEST or APPLICATION/QUERY (depending on the presence or absence of the P-Option, R-Option or T-Option) among the @UCOB call's keyword options. GEN's handling of "Interpretted SQL" (ENTER MASM 'ACOB$RDMR') in ACOB and UCOB programs remains unchanged. (6) GEN now supports non-DMS INVOKEs (allowed under UCOB 5R2+): INVOKE ALL ... File info INVOKE FORM ... DPS screen INVOKE RECORD ... Record description INVOKE SELECT ... File info INVOKE TABLE ... RDMS table INVOKE VIEW ... RDMS view If it sees one of these 6 words following the INVOKE, GEN will not treat the word as a subschema name. (7) There is now a temporary mechanism to allow UCOB programs to add keyword options to the @UCOB call: @UCOB * MONITOR/LABEL,; If your program contains this comment, GEN will add the UCOB keyword option "MONITOR/LABEL,;" during the generation of UCOB keywords (between UcobOpts and the keyword list). The @UCOB in columns 1-5 must be in upper case. Don't forget to code the comma and semicolon. The reason why this is regarded as a temporary mechanism is the fact that the keyword(s) you add may someday conflict with the keyword options generated by GEN. But it can be used when you need a "quick fix" in special cases, such as wanting to use "MONITOR/LABEL,;" instead of MONITOR. EJECT GEN 4.0 / GENDIR 1.0, continued: -------------------------------- (8) There is also a similar temporary mechanism for programs to do special things in the @LINK step: LINK: *INCLUDE MYFILE.MYSUBPROG LINK: *CHANGE REFERENCE (SUBPROG) TO MYSUBPROG The link directives in columns 8-72 will be added immediately after the INCLUDE directive in the @LINK. The "LINK:" in columns 1-5 must be in upper case. You may code up to 5 directives this way. You cannot use P or T in column 7 to code different directives for Production and Test (at least, not yet). NOTE: GEN 4.3 and GENDIR 1.3 dynamically resize URTS$TABLES. If you use this feature under GEN 4.0 to resize URTS$TABLES, you will have to remove it to use GEN 4.2. (9) Per request from Austin Porter, GEN and GENDIR now support subprogram LAQW07. (10) The @GEN,W option (generate a MONITOR) has been moved to a more appropriate and memorable spot in the alphabet, namely @GEN,M. This was made possible by change (11), below. EJECT (11) Last but not least, the generation of MAP and LINK directives has been offloaded to a separate program named GENDIR (pronounced "gender"). This makes sense because the code to generate directives lies around idle (unused), when GEN analyzes the program to compile, and vice-versa. By making them separate, both GEN and GENDIR take up less memory then GEN 3.9 did alone. But GENDIR 1.0 does more than simply free up memory and free up the @GEN,M option to be used to mean "MONITOR": COLUMN 11 (a) A major improvement is that it reads in its tables from an external symbolic element. This step delays GENDIR by 1/6th of a second, but it allows us to modify the tables on the fly, without recompiling GEN or GENDIR. Although this change is invisible to the user, it will allow us to change GENDIR's behavior quickly in an emergency, and it will allow us to temporarily override GENDIR's behavior in special circumstances. (b) Another major improvement is that GENDIR 1.0 has a "Mass MAP/LINK Mode", similar to GEN's "Mass Compile Mode". It's invoked exactly the same way (specifying a filename but no element name in the SI field). It scans the file for all relocatables (other than D$WORKs and SYSDTAs) and all unbound object modules, and then MAPs the RELS and LINKs the unbound OMs. (All other element types are ignored.) This could be useful if we someday start saving RELs and OMs for remapping and relinking when no source code changes are required. (When copy procs change, it's sometimes impossible to regen some older programs without extensive source code changes.) (c) A third major improvement is that you can now create new "versioned" subprograms about which GENDIR doesn't have to have any prior knowledge. This was previously only available for non-versioned subprograms. Of course, this assumes that the subprogram is singlebanked and doesn't have any special mapping needs. (d) GENDIR's assigning and freeing of library files is better than @GEN,M (before GEN 4.0), because there are no longer 2 situations that have to be dealt with (compile-time and map-time). Only map-time considerations are important to GENDIR. COLUMN 7 EJECT 2GEN 4.1 / GENDIR 1.1 (Never Officially Released) (1) The only change in GEN 4.1 itself was a new signon line heralding the new features of GENDIR 1.1. (2) GENDIR 1.1 reads object modules directly to decide how to LINK them. This is a **MAJOR** new feature. It means that the following, which were not possible before (without awkward workarounds), are now completely supported: COLUMN 12 (a) UCOB main programs that aren't "versioned" (that is, ones that don't have /TEST and /QUERY versions), can now call versioned subprograms. Examples include DAILYSUB, FUTURESUB, PRTLNK (=MMS) and SOISUB. (b) UCOB DMS programs will be automatically recognized as such. In the past, we had to assume DMS for all object modules whose version names began with TEST or QUERY, just in case they *MIGHT* be DMS. (c) UCOB programs and subprograms can now call ERACSF$, provided that they pass all 3 parameters (image, status and length). (You won't actually call the ACOB subprogram ERACSF$. A UCOB equivalent will be substituted.) (d) UCOB programs can now CALL subprograms with names that are up to 30 characters long (not just 12 anymore). COLUMN 7 We had originally planned to implement these features using a Unisys subprogram called OM$XREFINFO. It proved to be so difficult to get it working from within COBOL that we had to bypass it and read the object module directly, in much the same way as we read relocatables directly. (3) Allowing 30 character subprogram names required a major change in the format of the external tables. For this reason, there will be multiple versions of the external tables in ECL$ until GENDIR 1.0 has gone completely bye-bye. EJECT 2GEN 4.2 / GENDIR 1.2 (1) GEN 4.2 and GENDIR 1.2 now pick up application group parameters from an external table called GENAPP$. Prior to Version 4.2, GEN and GENDIR were hard-coded to compile and map/link to the SBA's 2 primary application groups (TEST and QUERY). Now we can change and temporarily override their application group behavior by altering GENAPP$. This feature was the primary reason for creating Version 4.2. It was needed by the folks who were redesigning the LA-ROOT-REC with a repayment terms set. This was such a large change, it would've affected nearly every program we had, so Jerry Szablowsky and Mahmood Shah had to put the new schema into application group 3. An added bonus is that GENAPP$ makes the Gen Utility much easier to install at other Unisys-1100/2200 sites. Another bonus is that GENAPP$ became a way for GEN to tell GENDIR what the schema filename was in the source code's INVOKE clause. That means that the SBA's SCHEMAFILE is also no longer hard-coded in GEN or GENDIR. This will allow Jerry and Mahmood the freedom and flexibility to use a different schema file, rather than a different application group, in situations where that may seem appropriate. (2) GEN 4.2 no longer totally ignores lines with A/U/P/T in column 7. Just in case there's something on the line that affects how GEN should generate the compile, it scans the line if that would be appropriate. For example, suppose a program is set up to use DMS-1100 under ACOB, and to use RDMS-1100 under UCOB, like so: A FETCH OWNERREC RECORD. A FETCH FIRST MEMBERREC WITHIN OWNER-TO-MEMBER SET U EXEC SQL DEFINE CursorName CURSOR ... etc U ... END-EXEC. If you @GEN,A this program, GEN will now see the DMS syntax and ignore the RDMS syntax. And if you @GEN,U it, it will see the RDMS syntax and ignore the DMS syntax. Prior to Version 4.2, GEN would simply ignore ALL lines with A or U in column 7. EJECT GEN 4.2 / GENDIR 1.2, continued: -------------------------------- (3) Similarly, GEN 4.2 will now respond to @GEN,P, @GEN,R and/or @GEN,T to determine whether or not to look at lines with P or T in column 7. (4) UCOB programs and subprograms can now call ERACSF$, regardless of whether they pass 2 or 3 parameters. SBA's UCOB ERACSF$ is now 100% source code compatible with the ACOB implementation provided by Unisys. (5) In development gens, @BANNER DEVELOPMENT,GEN,<> will now appear in the same breakpoint file as the compile. Also, the list of non-standard libraries and the procs that use them will now appear in the FREESANDASGS breakpoint file during development gens, in case you want to begin standardizing them before doing a release gen. (6) GENDIR no longer generates unnecessary page-ejects before SPACE 0 "@HDG,P *** Linking ... " and "@HDG,P *** Mapping ... ". (7) GEN and GENDIR now support PADS by detecting calls to PADS$. GENDIR also realizes that PADS is not supported under ACOB TIP, so if the program is ACOB TIP, it will suppress mapping in PADS, even if the program calls PADS$. (8) GENDIR now supports dynamically resizing UCOB's URTS$TABLES if the program calls DPS, D$DEF functions and/or RDMS. In GENDIR 1.2, this feature is somewhat heavy-handed and gross. Intelligent resizing is available in GENDIR 1.3. (9) GENDIR now supports interpretted SQL and subprogram LAQD83. (10) GEN no longer tries to preset the qualifier of SCHEMAFILE before compiling embedded SQL programs, unless they also use DMS-1100. (11) GEN now detects CALLs to COMPOOL and the "old DPS" entry points. All it does for now is complain about them at scan time. (12) The automatic edit of the breakpoint file now sets the @ED Multiple Command Character (MCC) to ampersand (&) and the Transparent Change Character (TCC) to percent sign (%). This is a convenience feature that allows @ED users to browse the breakpoint file more efficiently. (Q/EDitor users (@GEN,Q) are unaffected by this change.) EJECT 2GEN 4.3 / GENDIR 1.3 (1) A couple of small bugs relating to alternate application groups (DCOMP is the only current example) been fixed: COLUMN 11 (a) In a mass compile, GENDIR's handling of GENAPP$ no longer confuses GEN's handling of GENAPP$. As a result, every gen of the mass compile will go to the alternate app group, not just the first one. (b) The test and production app group can now be the same. This allows a release gen to be done to only one app group. COLUMN 7 (2) GEN now sets NO-OPTIM option whenever error handling (@GEN,E), monitor (@GEN,M) or PADS ("CALL 'PADS$'.") is being used. (The problem was that @UCOB would take forever to compile if optimization was on.) (3) If error handling or PADS is used with the L-Option (@GEN,L), GEN will now generate the FULL-DEBUG keyword (not just DEBUG) on the @UCOB call. (4) GENDIR's complaint "Unable to find OM preamble" has been fixed: If the Object Module generated by UCOB was very large, GENDIR was sometimes unable to find its preamble, which GENDIR needs to figure out how to link the program. This was a rare problem. It happened to only 2 programs. In both cases, the program was large to begin with, and it was genned with @GEN,M, which does a MONITOR. This put the preamble more than 458,752 bytes away from the start of the Object Module and GENDIR had assumed that it wouldn't be that far away. Anyway, it's been fixed. (5) Multiple versions of GEN and GENDIR can now coexist (without conflicting with each other) in CTRI*ECLFILE. This allows us to keep around older versions in case someone needs to fall back for some reason. EJECT GEN 4.3 / GENDIR 1.3, continued: -------------------------------- (6) GENDIR now sizes URTS$TABLES intelligently. The problem that GENDIR 1.2 had was that @LINK doesn't let you resize URTS$TABLES incrementally. That is, it won't let you say (a) SET Size = Size + 7500 . DPS + 7000 . D$DEF FOR URTS$TABLES and the UCS Applications Development Guide warns that you shouldn't do more than one: (b) SET Size = Size + 7500 FOR URTS$TABLES . DPS SET Size = Size + 7000 FOR URTS$TABLES . D$DEF If either of those were possible/recommended, GENDIR 1.2 could have resized URTS$TABLES according to exactly which routines a program calls. But what LINK actually wants is this: (c) SET Size = Size + 14500 FOR URTS$TABLES GENDIR 1.3 now calculates only one resizing of URTS$TABLES, as shown in (5)(c), and the amount it calculates is accurate. This means that you no longer have to code "LINK: *" link directives in your source code (see GEN 4.0, item 8, above), to accomplish this result. (7) The "TMP." file is now erased at the beginning of every gen. This is to assure that, if the compilation step fails, GENDIR will not pick up an old relocatable or object module that was left lying around in "TMP." from a previous gen. (8) @GEN,H now provides simply a quick-reference of option letters (the same way that @GENDIR, @DOWNER and @STRIP behave). To get a copy of the Users Manual and Version History, use @GEN,HL. EJECT 2GEN 4.4 / GENDIR 1.4 (1) GEN 4.4 will @SETC,N at the top of a gen so that the @BANNER heading will get printed on the front page if the listing is symmed to print queue F100P. This is largely just a convenience feature. GEN reverts to @SETC,P immediately after the banner. (2) An obscure bug in GENDIR 1.3 was fixed: If an ACOB program used interpretted SQL ("ENTER MASM 'ACOB$RDMR' USING ..."), and was genned to production (@GEN,R and/or @GEN,P), GENDIR 1.3 would RLIB UDS$$ONE*RSA. This bug didn't get detected in testing because, until recently, we didn't have any production programs that used interpretted SQL. GENDIR 1.4 will RLIB UDS$$TWO*RSA. instead, as it ought to. (3) Another obscure bug in GENDIR 1.0 thru 1.3 was fixed: If a UCOB program was totally non-database (not DMS and not RDMS), and it called a versioned subprogram, such as DBRETRIEVE, the old GENDIR would abort. Again, this bug didn't get detected until we had a program that met all the criteria. (4) P and T in column 7 now cause the program to be compiled to an application group, even if the program makes no other reference to application group syntax (such as DMS verbs or RDMS SQL). You can use this new feature to create separate production and test versions of a program that intentionally behave differently. For example, you can have a program call subprogram MMSR03 in the case of test, but PRTLNK in the case of production. EJECT GEN 4.4 / GENDIR 1.4, continued: -------------------------------- (5) A rare bug in GEN 4.0 thru 4.3 was fixed. "Targeting Code Using Column 7" was SUPPOSED to work like this: * If GEN saw either A or U in column 7 during the scan, both A and U would be converted. * If GEN saw either P or T in column 7 during the scan, both P and T would be converted. The bug was that, if a program used A or U in column 7, GEN would not convert lines with P or T in column 7, even if P or T was seen in column 7 during the scan. The resulting compile would get Serious (ACOB) or Major (UCOB) errors for every line with P or T in column 7. As of GEN 4.4, the bug was fixed and the whole process was made a lot more convenient: Now, whenever GEN sees *ANY* of these four letters in column 7 during the scan, *ALL FOUR* will be converted to " " or "*" appropriately. NOTE: This applies *ONLY* to the conversion of A, U, P and T in column 7 to " " or "*". GEN must still actually see P or T in column 7 during the scan to force genning to application groups (item (4), above). (6) Last but not least of the "Targeting Code Using Column 7" changes, GEN 4.4 will allow the rest of the line to be blank. (GEN 4.0 thru 4.3 would ignore lines that were blank in columns 8 thru 72 before it checked column 7. So if you coded a line containing only A, U, P or T in column 7, with the rest of the line blank, it would not have the effect of triggering the column 7 conversion. But GEN 4.4 now checks column 7 before the rest of the line.) (7) After a release gen, GEN 4.4 puts up a reminder about how to get a "verify listing", a paper-saving alternative to printing the entire gen listing. (8) GEN 4.4 now complains if the program ACCEPTs ... FROM DATE-TIME (a COBOL-68 extension no longer supported by UCOB.) 1FUTURE FEATURES 2GEN 4.5 / GENDIR 1.5 (0) Nothing yet. 2Planned But Not Written Yet (1) Locking up release-gens in a write keyed file that even GEN doesn't know the write key of. @COPY,S the element there with the date/time stamp of the gen. (File will be deleted if not referenced in 3 days, so no one needs to know its write key.) This would assure that the version of the program that was tested is the version of the program that gets released. (2) Creating installation elements for TIP transactions. (This is currently planned to be the "I" option.) (3) Currently there are no criteria for deciding which TIP transactions ought to use smaller C$SMCxx elements. Until some criteria are determined, all TIP transactions will be mapped with C$SMC50. (4) GEN doesn't currently scan the breakpoint file itself, but it could. It could collect together all compiler diagnostics and store them off into a file for future reference. The next time that that same program is genned, GEN could detect whether the number of diagnostics had changed. If the number had changed, GEN could even put the previous diagnostics into one element, put the current diagnostics into another element and @DOWN them. EJECT Planned But Not Written Yet, continued: --------------------------------------- (5) There are quite a few COBOL features that are no longer supported in UCOB/COBOL-85, notably: (a) COMP-4, COMPUTATIONAL-4, DISP-1 and DISPLAY-1 (b) NOTE and REMARKS (c) 770-PRINTER, CFH, FORM01, FORM02, FORM03, LION, MASS-STORAGE, SEQUENTIAL-FILE and UNISERVO files Since FIPS has mandated that all Federal agencies must migrate to COBOL-85, these constructs will eventually have to be phased out. GEN should help ease the process by warning of syntax incompatible with COBOL-85 in the "Scanning..." messages. Initially, just seeing the "ACOB" message is enough, but it would be better if GEN specified exactly which syntax is ACOB-only. A convenient tool for doing this is the "@BANNER BAD-VERBS" message, which can and should be expanded as the list of verbs that violate SBA programming standards is expanded. ROMAN ON @EOF @MSG,N If all went well, @SYM,U GenDoc.,, F117P,,Box-XX @MSG,N and/or @SYM,U GenVerHist.,, F117P,,Box-XX @END SENT @ELT,IQ UUSIG*1100-001-001.JDNCALC,,,,COB COPY ProgId IN ASC-PROC REPLACING P1 BY JdnCalc. / DATA DIVISION. WORKING-STORAGE SECTION. 01 Reply. 05 Reply8 PIC 9(08). 01 Filler7 REDEFINES Reply. 05 Reply7 PIC 9(07). 05 FILLER PIC X(01). 01 Filler6 REDEFINES Reply. 05 Reply6 PIC 9(06). 05 FILLER PIC X(02). 01 Filler1 REDEFINES Reply. 05 Reply1 PIC X(01). 05 FILLER PIC X(07). 01 Display-Both. 05 FILLER PIC X(07) VALUE 'Date = '. 05 Disp-Date PIC X(08). 05 FILLER PIC X(08) VALUE ', Day = '. 05 Disp-Day PIC X(07). * System procs are S-OFF'd: S-OFF COPY JDN-Constants-WS IN ASC-PROC. COPY JDN-Packet-WS IN ASC-PROC. COPY JDN-Record-WS IN S. SLIST PROCEDURE DIVISION. 0000-Main-Section SECTION. 0000-Main. DISPLAY 'Enter NNNNNN (6 chars = JDN)' UPON Prtr-Out. DISPLAY ' YYYYDDD (7 chars = Day)' UPON Prtr-Out. DISPLAY ' or YYYYMMDD (8 chars = Date).' UPON Prtr-Out. DISPLAY ' ' UPON Prtr-Out. DISPLAY 'Processing will continue until you enter a blank ' 'line to exit.' UPON Prtr-Out. MOVE LOW-VALUES TO Reply. PERFORM 0010-Ask UNTIL Reply = SPACES. STOP RUN. 0010-Ask. MOVE LOW-VALUES TO JDN-Record. MOVE SPACES TO Reply. DISPLAY ' ' UPON Prtr-Out. ACCEPT Reply FROM Card-In. IF (Reply6 IS NUMERIC) IF (Reply7 IS NUMERIC) IF (Reply8 IS NUMERIC) MOVE Reply8 TO JDN-Date PERFORM JDN-Acc-Int-Of-Date MOVE LOW-VALUES TO JDN-Pkt-Flags IF (JDN-Pkt-Status = JDN-Con-NoErr) MOVE JDN-Int TO Reply6 DISPLAY JDN-Date ' = day ' Reply6 UPON Prtr-Out ELSE PERFORM 0090-Complain ELSE MOVE Reply7 TO JDN-Day PERFORM JDN-Acc-Int-Of-Day MOVE LOW-VALUES TO JDN-Pkt-Flags IF (JDN-Pkt-Status = JDN-Con-NoErr) MOVE JDN-Int TO Reply6 DISPLAY JDN-Day ' = day ' Reply6 UPON Prtr-Out ELSE PERFORM 0090-Complain ELSE PERFORM 0020-Display-Both ELSE IF (Reply = SPACES) DISPLAY 'END JDNCalc' UPON Prtr-Out ELSE DISPLAY 'Numeric data, please.' UPON Prtr-Out. / 0020-Display-Both. MOVE Reply6 TO JDN-Int. PERFORM JDN-Acc-Date-Of-Int. IF (JDN-Pkt-Status = JDN-Con-NoErr) MOVE JDN-Date TO Disp-Date PERFORM JDN-Acc-Day-Of-Int MOVE LOW-VALUES TO JDN-Pkt-Flags IF (JDN-Pkt-Status = JDN-Con-NoErr) MOVE JDN-Day TO Disp-Day ELSE PERFORM 0090-Complain MOVE 0 TO Disp-Day ELSE MOVE LOW-VALUES TO JDN-Pkt-Flags PERFORM 0090-Complain MOVE 0 TO Disp-Date, Disp-Day. MOVE JDN-Int TO Reply6. DISPLAY Reply6 ' is the JDN of ' Display-Both UPON Prtr-Out. 0090-Complain. IF (JDN-Pkt-Status = JDN-Con-BadAction) DISPLAY 'JDNCalc out of sync with JDNSub' UPON Prtr-Out ELSE IF (JDN-Pkt-Status = JDN-Con-NonNumericDD) DISPLAY Reply ' DD not numeric' UPON Prtr-Out ELSE IF (JDN-Pkt-Status = JDN-Con-NonNumericDDD) DISPLAY Reply ' DDD not numeric' UPON Prtr-Out ELSE IF (JDN-Pkt-Status = JDN-Con-NonNumericMM) DISPLAY Reply ' MM not numeric' UPON Prtr-Out ELSE IF (JDN-Pkt-Status = JDN-Con-NonNumericYYYY) DISPLAY Reply ' YYYY not numeric' UPON Prtr-Out ELSE IF (JDN-Pkt-Status = JDN-Con-OutOfRangeDD) DISPLAY Reply ' DD out of range' UPON Prtr-Out ELSE IF (JDN-Pkt-Status = JDN-Con-OutOfRangeDDD) DISPLAY Reply ' DDD out of range' UPON Prtr-Out ELSE IF (JDN-Pkt-Status = JDN-Con-OutOfRangeInt) DISPLAY Reply ' JDN > 999999' UPON Prtr-Out ELSE IF (JDN-Pkt-Status = JDN-Con-OutOfRangeMM) DISPLAY Reply ' MM < 1 or > 12' UPON Prtr-Out PERFORM 0099-AllowOverflow ELSE IF (JDN-Pkt-Status = JDN-Con-OutOfRangeYYYY) DISPLAY Reply ' YYYY < 1601 or > 3000' UPON Prtr-Out PERFORM 0099-AllowOverflow ELSE DISPLAY 'JDNCalc out of sync with JDNSub' UPON Prtr-Out. / 0099-AllowOverflow. MOVE SPACES TO Reply. DISPLAY 'YYYY < 1601, MM < 1 and DD < 1 are never allowed, ' 'but YYYY and MM can overflow.' UPON Prtr-Out. DISPLAY 'Do you wish to allow overflow? Y/N' UPON Prtr-Out. ACCEPT Reply FROM Card-In. IF (Reply1 = 'Y' or 'y') MOVE 1 TO JDN-Pkt-AllowOvMM, JDN-Pkt-AllowOvYYYY DISPLAY 'Overflow will be allowed 1 time' UPON Prtr-Out ELSE IF (Reply = SPACES) DISPLAY 'END JDNCalc' UPON Prtr-Out ELSE DISPLAY 'Overflow will not be allowed' UPON Prtr-Out. * System procs are S-OFF'd: S-OFF COPY JDN-Record-Access IN S. @EOF @ELT,IQD UUSIG*1100-001-001.JDNCALC/RUN,,SENT,,ELT @XQT S.JDNCAL Enter NNNNNN (6 chars = JDN) YYYYDDD (7 chars = Day) or YYYYMMDD (8 chars = Date). Processing will continue until you enter a blank line to exit. 144000 144000 is the JDN of Date = 19950405, Day = 1995095 19951004 19951004 = day 144182 144182 144182 is the JDN of Date = 19951004, Day = 1995277 262143 262143 is the JDN of Date = 23180922, Day = 2318265 END JDNCalc @END SENT @PDP,IC UUSIG*1100-001-001.JDNCONWS ***************************************************************** * COMMENT SECTION * ***************************************************************** * * * Related PROCs: In order to use JDN-RECORD-ACCESS, you must * * also copy JDN-CONSTANTS-WS, JDN-PACKET-WS and * * JDN-RECORD-WS into WORKING-STORAGE. * * * * The WORKING-STORAGE procs cannot be combined * * because they are also used in JDNSUB, which * * must have them separate. * * * ***************************************************************** * DESCRIPTION OF THE PROC * ***************************************************************** * * * The COBOL-85 standard (FIPS 21-2) was expanded in 1989 to * * include the Intrinsic Functions Module, and the result became * * FIPS 21-3. As such, the date routines it contains are a FIPS * * standard that the SBA can rely on to be implemented on all * * future COBOLs. Unfortunately, they aren't yet implemented in * * our present COBOLs (ACOB and UCOB), hence this proc. * * * * This proc defines constants used to emulate the following * * new UCOB intrinsic functions, which otherwise wouldn't be * * available until System Base Release 5R1: * * * * DATE-OF-INTEGER * * DAY-OF-INTEGER * * INTEGER-OF-DATE * * INTEGER-OF-DAY * * * * Used in this context, INTEGER means "the number of days * * since December 31st, 1600 AD, Gregorian". In other words, * * January 1st, 1601 AD, Gregorian, is day 1. The common term * * for a sequential numbering of days is "Julian Day Number", * * or JDN. Don't confuse this term with "Julian Date", which * * is the number of days within a year, or "Julian Calendar", * * which is the calendar introduced by Julius Caesar, in which * * every year divisible evenly by 4 is a leap year (even if * * it's a turn-of-the-century). * * * * The US Naval Observatory's atomic clocks are the official * * time standard for the United States and astronomers world- * * wide. This is significant to us only because the USNO uses * * a **different** JDN (also a FIPS standard!) based on 4713 BC, * * Julian. To get USNO JDN, add JDN-CON-USNO-OFFSET to JDN-INT. * * * * JDN-CON-USNO-OFFSET is the USNO JDN of December 31st, 1600 AD,* * Gregorian, as you probably guessed. JDN-CON-USNO-OFFSET is * * defined here in JDN-CONSTANTS-WS. * * * ***************************************************************** * REVISION HISTORY * ***************************************************************** * * * ------------------------F O R M A T-------------------------- * * CHANGE CHANGE CHANGED RMIS * * NUMBER DATE BY NUMBER DESCRIPTION OF CHANGE * * ------ ------ ------------- ------ ------------------------- * * CH-NNN MMDDYY FMLLLLLLLLLLL NNNNNN XXXXXXXXXXXXXXXXXXXXXXXXX * * ------------------------------------------------------------- * * CH-000 030194 SRSeaquist 931115 Initial implementation * ***************************************************************** JDN-CONSTANTS-WS PROC / 01 JDN-Constants. word alignd 02 JDN-Con-Action-Codes. 05 JDN-Con-DateOfInt PIC 1(09) VALUE 1. 05 JDN-Con-DayOfInt PIC 1(09) VALUE 2. 05 JDN-Con-IntOfDate PIC 1(09) VALUE 3. 05 JDN-Con-IntOfDay PIC 1(09) VALUE 4. word alignd 02 JDN-Con-Status-Codes. 05 JDN-Con-NoErr PIC 1(09) VALUE 0. 05 JDN-Con-BadAction PIC 1(09) VALUE 1. 05 JDN-Con-NonNumericDD PIC 1(09) VALUE 2. 05 JDN-Con-NonNumericDDD PIC 1(09) VALUE 3. 05 JDN-Con-NonNumericMM PIC 1(09) VALUE 4. 05 JDN-Con-NonNumericYYYY PIC 1(09) VALUE 5. 05 JDN-Con-NotImplemented PIC 1(09) VALUE 6. 05 JDN-Con-OutOfRangeDD PIC 1(09) VALUE 7. 05 JDN-Con-OutOfRangeDDD PIC 1(09) VALUE 8. 05 JDN-Con-OutOfRangeInt PIC 1(09) VALUE 9. 05 JDN-Con-OutOfRangeMM PIC 1(09) VALUE 10. 05 JDN-Con-OutOfRangeYYYY PIC 1(09) VALUE 11. 05 JDN-Con-Strange PIC 1(09) VALUE 12. 05 FILLER PIC 1(27) VALUE 0. word alignd 02 JDN-Con-Year-Type-Codes. 05 JDN-Con-YearTypeUnknown PIC 1(09) VALUE 0. 05 JDN-Con-Leap PIC 1(09) VALUE 1. 05 JDN-Con-NotLeap PIC 1(09) VALUE 2. 05 FILLER PIC 1(09). word alignd 02 JDN-Con-Misc. 05 JDN-Con-USNO-Offset PIC 1(36) VALUE 2305813. END @EOF @PDP,IC UUSIG*1100-001-001.JDNPKTWS ***************************************************************** * COMMENT SECTION * ***************************************************************** * * * Related PROCs: In order to use JDN-RECORD-ACCESS, you must * * also copy JDN-CONSTANTS-WS, JDN-PACKET-WS and * * JDN-RECORD-WS into WORKING-STORAGE. * * * * The WORKING-STORAGE procs cannot be combined * * because they are also used in JDNSUB, which * * must have them separate. * * * ***************************************************************** * DESCRIPTION OF THE PROC * ***************************************************************** * * * The COBOL-85 standard (FIPS 21-2) was expanded in 1989 to * * include the Intrinsic Functions Module, and the result became * * FIPS 21-3. As such, the date routines it contains are a FIPS * * standard that the SBA can rely on to be implemented on all * * future COBOLs. Unfortunately, they aren't yet implemented in * * our present COBOLs (ACOB and UCOB), hence this proc. * * * * This proc defines a packet used to emulate the following * * new UCOB intrinsic functions, which otherwise wouldn't be * * available until System Base Release 5R1: * * * * DATE-OF-INTEGER * * DAY-OF-INTEGER * * INTEGER-OF-DATE * * INTEGER-OF-DAY * * * * Used in this context, INTEGER means "the number of days * * since December 31st, 1600 AD, Gregorian". In other words, * * January 1st, 1601 AD, Gregorian, is day 1. The common term * * for a sequential numbering of days is "Julian Day Number", * * or JDN. Don't confuse this term with "Julian Date", which * * is the number of days within a year, or "Julian Calendar", * * which is the calendar introduced by Julius Caesar, in which * * every year divisible evenly by 4 is a leap year (even if * * it's a turn-of-the-century). * * * * The US Naval Observatory's atomic clocks are the official * * time standard for the United States and astronomers world- * * wide. This is significant to us only because the USNO uses * * a **different** JDN (also a FIPS standard!) based on 4713 BC, * * Julian. To get USNO JDN, add JDN-CON-USNO-OFFSET to JDN-INT. * * * * JDN-CON-USNO-OFFSET is the USNO JDN of December 31st, 1600 AD,* * Gregorian, as you probably guessed. JDN-CON-USNO-OFFSET is * * defined in JDN-CONSTANTS-WS. * * * ***************************************************************** * REVISION HISTORY * ***************************************************************** * * * ------------------------F O R M A T-------------------------- * * CHANGE CHANGE CHANGED RMIS * * NUMBER DATE BY NUMBER DESCRIPTION OF CHANGE * * ------ ------ ------------- ------ ------------------------- * * CH-NNN MMDDYY FMLLLLLLLLLLL NNNNNN XXXXXXXXXXXXXXXXXXXXXXXXX * * ------------------------------------------------------------- * * CH-000 030194 SRSeaquist 931115 Initial implementation * ***************************************************************** JDN-PACKET-WS PROC 01 JDN-Packet. 05 JDN-Pkt-Action PIC 1(09). 05 JDN-Pkt-Flags. 10 JDN-Pkt-AllowOvDD PIC 1(01). 10 JDN-Pkt-AllowOvDDD PIC 1(01). 10 JDN-Pkt-AllowOvInt PIC 1(01). 10 JDN-Pkt-AllowOvMM PIC 1(01). 10 JDN-Pkt-AllowOvYYYY PIC 1(01). 10 FILLER PIC 1(04). 05 FILLER PIC X(02). 05 JDN-Pkt-LY PIC 1(09). 05 JDN-Pkt-Status PIC 1(09). 05 JDN-Pkt-Status-Text PIC X(78). 05 JDN-Pkt-Reserved PIC X(80). END @EOF @PDP,IC UUSIG*1100-001-001.JDNRECPD ***************************************************************** * COMMENT SECTION * ***************************************************************** * * * Related PROCs: In order to use JDN-RECORD-ACCESS, you must * * also copy JDN-CONSTANTS-WS, JDN-PACKET-WS and * * JDN-RECORD-WS into WORKING-STORAGE. * * * * The WORKING-STORAGE procs cannot be combined * * because they are also used in JDNSUB, which * * must have them separate. * * * ***************************************************************** * DESCRIPTION OF THE PROC * ***************************************************************** * * * The COBOL-85 standard (FIPS 21-2) was expanded in 1989 to * * include the Intrinsic Functions Module, and the result became * * FIPS 21-3. As such, the date routines it contains are a FIPS * * standard that the SBA can rely on to be implemented on all * * future COBOLs. Unfortunately, they aren't yet implemented in * * our present COBOLs (ACOB and UCOB), hence this proc. * * * * This proc calls the subprogram JDNSUB to emulate the following* * new UCOB intrinsic functions, which otherwise wouldn't be * * available until System Base Release 5R1: * * * * DATE-OF-INTEGER * * DAY-OF-INTEGER * * INTEGER-OF-DATE * * INTEGER-OF-DAY * * * * Used in this context, INTEGER means "the number of days * * since December 31st, 1600 AD, Gregorian". In other words, * * January 1st, 1601 AD, Gregorian, is day 1. The common term * * for a sequential numbering of days is "Julian Day Number", * * or JDN. Don't confuse this term with "Julian Date", which * * is the number of days within a year, or "Julian Calendar", * * which is the calendar introduced by Julius Caesar, in which * * every year divisible evenly by 4 is a leap year (even if * * it's a turn-of-the-century). * * * * The US Naval Observatory's atomic clocks are the official * * time standard for the United States and astronomers world- * * wide. This is significant to us only because the USNO uses * * a **different** JDN (also a FIPS standard!) based on 4713 BC, * * Julian. To get USNO JDN, add JDN-CON-USNO-OFFSET to JDN-INT. * * * * JDN-CON-USNO-OFFSET is the USNO JDN of December 31st, 1600 AD,* * Gregorian, as you probably guessed. JDN-CON-USNO-OFFSET is * * defined in JDN-CONSTANTS-WS. * * * ***************************************************************** * REVISION HISTORY * ***************************************************************** * * * ------------------------F O R M A T-------------------------- * * CHANGE CHANGE CHANGED RMIS * * NUMBER DATE BY NUMBER DESCRIPTION OF CHANGE * * ------ ------ ------------- ------ ------------------------- * * CH-NNN MMDDYY FMLLLLLLLLLLL NNNNNN XXXXXXXXXXXXXXXXXXXXXXXXX * * ------------------------------------------------------------- * * CH-000 030194 SRSeaquist 931115 Initial implementation * * ------ ------ ------------- ------ ------------------------- * CH-001 * CH-001 091295 SRSeaquist 931115 Minor cleanup * CH-001 ***************************************************************** JDN-RECORD-ACCESS PROC / JDN-RECORD-ACCESS SECTION. JDN-Acc-Call. CALL 'JDNSUB' USING JDN-Packet, JDN-Record. JDN-Acc-CC-Inferred. Infer IF (JDN-YY NOT NUMERIC) based OR (JDN-YY > 52) on MOVE 19 TO JDN-CC SBA's ELSE b'day. MOVE 20 TO JDN-CC. JDN-Acc-Date-Of-Int. MOVE JDN-Con-DateOfInt TO JDN-Pkt-Action. PERFORM JDN-Acc-Call. JDN-Acc-Day-Of-Int. MOVE JDN-Con-DayOfInt TO JDN-Pkt-Action. PERFORM JDN-Acc-Call. JDN-Acc-Int-Of-Date. MOVE JDN-Con-IntOfDate TO JDN-Pkt-Action. IF (JDN-CC NOT NUMERIC) OR (JDN-CC = 0) CH-001 PERFORM JDN-Acc-CC-Inferred PERFORM JDN-Acc-Call MOVE 0 TO JDN-CC ELSE PERFORM JDN-Acc-Call. JDN-Acc-Int-Of-Day. MOVE JDN-Con-IntOfDay TO JDN-Pkt-Action. IF (JDN-CC NOT NUMERIC) OR (JDN-CC = 0) CH-001 PERFORM JDN-Acc-CC-Inferred PERFORM JDN-Acc-Call MOVE 0 TO JDN-CC ELSE PERFORM JDN-Acc-Call. * IMPORTANT!: PERFORM the following paragraph before using * **ANY** of the previous paragraphs in a self-initializing * transaction! JDN-Acc-Self-Init. MOVE LOW-VALUES TO JDN-Packet. * The following are "To" versions that use the "Of" versions. * Don't use them on purpose. (Why incur the extra overhead * of an extra PERFORM?) * * They are provided just in case someone misreads their name * and codes the wrong name. The official versions are the * "Of" names, of course, because their names correspond to * those of the new COBOL-85 intrinsic functions. JDN-Acc-Date-To-Int. PERFORM JDN-Acc-Int-Of-Date. JDN-Acc-Day-To-Int. PERFORM JDN-Acc-Int-Of-Day. JDN-Acc-Int-To-Date. PERFORM JDN-Acc-Date-Of-Int. JDN-Acc-Int-To-Day. PERFORM JDN-Acc-Day-Of-Int. JDN-Acc-Exit. EXIT. END @EOF @PDP,IC UUSIG*1100-001-001.JDNRECWS ***************************************************************** * COMMENT SECTION * ***************************************************************** * * * Related PROCs: In order to use JDN-RECORD-ACCESS, you must * * also copy JDN-CONSTANTS-WS, JDN-PACKET-WS and * * JDN-RECORD-WS into WORKING-STORAGE. * * * * The WORKING-STORAGE procs cannot be combined * * because they are also used in JDNSUB, which * * must have them separate. * * * ***************************************************************** * DESCRIPTION OF THE PROC * ***************************************************************** * * * The COBOL-85 standard (FIPS 21-2) was expanded in 1989 to * * include the Intrinsic Functions Module, and the result became * * FIPS 21-3. As such, the date routines it contains are a FIPS * * standard that the SBA can rely on to be implemented on all * * future COBOLs. Unfortunately, they aren't yet implemented in * * our present COBOLs (ACOB and UCOB), hence this proc. * * * * This proc defines a data record used to emulate the following * * new UCOB intrinsic functions, which otherwise wouldn't be * * available until System Base Release 5R1: * * * * DATE-OF-INTEGER * * DAY-OF-INTEGER * * INTEGER-OF-DATE * * INTEGER-OF-DAY * * * * Used in this context, INTEGER means "the number of days * * since December 31st, 1600 AD, Gregorian". In other words, * * January 1st, 1601 AD, Gregorian, is day 1. The common term * * for a sequential numbering of days is "Julian Day Number", * * or JDN. Don't confuse this term with "Julian Date", which * * is the number of days within a year, or "Julian Calendar", * * which is the calendar introduced by Julius Caesar, in which * * every year divisible evenly by 4 is a leap year (even if * * it's a turn-of-the-century). * * * * The US Naval Observatory's atomic clocks are the official * * time standard for the United States and astronomers world- * * wide. This is significant to us only because the USNO uses * * a **different** JDN (also a FIPS standard!) based on 4713 BC, * * Julian. To get USNO JDN, add JDN-CON-USNO-OFFSET to JDN-INT. * * * * JDN-CON-USNO-OFFSET is the USNO JDN of December 31st, 1600 AD,* * Gregorian, as you probably guessed. JDN-CON-USNO-OFFSET is * * defined in JDN-CONSTANTS-WS. * * * ***************************************************************** * REVISION HISTORY * ***************************************************************** * * * ------------------------F O R M A T-------------------------- * * CHANGE CHANGE CHANGED RMIS * * NUMBER DATE BY NUMBER DESCRIPTION OF CHANGE * * ------ ------ ------------- ------ ------------------------- * * CH-NNN MMDDYY FMLLLLLLLLLLL NNNNNN XXXXXXXXXXXXXXXXXXXXXXXXX * * ------------------------------------------------------------- * * CH-000 030194 SRSeaquist 931115 Initial implementation * ***************************************************************** JDN-RECORD-WS PROC / 01 JDN-Record. * Part 1 of JDN-Record (display formats). * * Easy-to-remember convention: Fields containing CC, YY, MM, * DD and DDD in their name are numeric. Date and Day are not. * Also, since COBOL's DATE and DAY do not include century, use * one of the following: * * MOVE 0 TO JDN-CC. * ACCEPT JDN-YYMMDD FROM DATE. * or * MOVE 0 TO JDN-CC. * ACCEPT JDN-YYDDD FROM DAY. * * If you do that, JDN-Acc-Int-Of-Date and JDN-Acc-Int-Of-Day * will infer century based on YY and the birthdate of the SBA. * Moreover, unless you yourself stuff 19 or 20 into JDN-CC, or * if you call JDN-Acc-Date-Of-Int or JDN-Acc-Day-Of-Int (which * return a value in JDN-CC), Int-Of-Date and Int-Of-Day will * continue to keep 0 in JDN-CC and continue to infer century. word alignd 05 JDN-Date. 10 JDN-CC PIC 9(02). 10 JDN-YYMMDD PIC 9(06). 10 JDN-Filler1 REDEFINES JDN-YYMMDD. 15 JDN-YY PIC 9(02). 15 JDN-MM PIC 9(02). 15 JDN-DD PIC 9(02). 05 JDN-CCYYMMDD REDEFINES JDN-Date PIC 9(08). 05 JDN-YYYYMMDD REDEFINES JDN-Date PIC 9(08). word alignd 05 JDN-Filler2 REDEFINES JDN-Date. 10 JDN-Day. 15 JDN-CCYY PIC 9(04). 15 JDN-YYYY REDEFINES JDN-CCYY PIC 9(04). 15 JDN-DDD PIC 9(03). 10 JDN-CCYYDDD REDEFINES JDN-Day PIC 9(07). 10 JDN-YYYYDDD REDEFINES JDN-Day PIC 9(07). 10 JDN-Filler3 REDEFINES JDN-Day. 15 FILLER PIC X(02). 15 JDN-YYDDD PIC 9(05). 10 FILLER PIC X(01). * Part 2 of JDN-Record (number of days since 12/31/1600 AD): word alignd 05 JDN-Int PIC 1(36). END @EOF @ELT,IQ UUSIG*1100-001-001.JDNSUB,,,,COB COPY ProgId IN ASC-PROC REPLACING P1 BY JdnSub. /**************************************************************** * * * This subprogram calculates the same values as the following * * ANSI X3.23-1989a / FIPS 21-3 intrinsic functions for date * * calculations, available in UCOB as of SB5R1: * * * * DATE-OF-INTEGER * * DAY-OF-INTEGER * * INTEGER-OF DATE * * INTEGER-OF DAY * * * * Used in this context, INTEGER means "the number of days * * since December 31st, 1600 AD, Gregorian". In other words, * * January 1st, 1601 AD, Gregorian, is day 1. The common term * * for a sequential numbering of days is "Julian Day Number", * * or JDN. Don't confuse this term with "Julian Date", which * * is the number of days within a year, or "Julian Calendar", * * which is the calendar introduced by Julius Caesar, in which * * every year divisible evenly by 4 is a leap year (even if * * it's a turn-of-the-century). * * * * The US Naval Observatory also has its own Julian Day Number. * * To derive that value, add JDN-CON-USNO-OFFSET to FIPS-JDN. * * (JDN-CON-USNO-OFFSET is the USNO JDN of December 31st, 1600 * * AD, Gregorian, as you probably guessed.) * * * * Implementation notes: * * * * (1) The turn-of-the-century algorithm introduced by * * Pope Gregory XIII is implicitly handled thru the * * use of appropriately-chosen constants. * * * * (2) We avoid COMPUTE, just in case this subprogram is * * inadvertantly compiled with @GEN,F (= @ACOB ,,,,T). * * * ***************************************************************** * JDNSUB Compile/Map ECL * * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * * * * @GEN,R File.JDNSUB * * * ***************************************************************** * REVISION HISTORY * ***************************************************************** * * * ------------------------F O R M A T-------------------------- * * CHANGE CHANGE CHANGED RMIS * * NUMBER DATE BY NUMBER DESCRIPTION OF CHANGE * * ------ ------ ------------- ------ ------------------------- * * CH-NNN MMDDYY FMLLLLLLLLLLL NNNNNN XXXXXXXXXXXXXXXXXXXXXXXXX * * ------------------------------------------------------------- * * CH-000 111993 SRSeaquist 940026 Initial implementation * ***************************************************************** / DATA DIVISION. WORKING-STORAGE SECTION. 01 Counters-Flags-Etc. 05 i PIC 1(36). 05 j PIC 1(36). 05 LeapDiv PIC 1(36). 05 LeapMod PIC 1(36). 05 MonDiv12 PIC 1(36). 05 MonMod12 PIC 1(36). 05 NbrDaysDiv001Year PIC 1(36). 05 NbrDaysDiv004Years PIC 1(36). 05 NbrDaysDiv100Years PIC 1(36). 05 NbrDaysDiv400Years PIC 1(36). 05 NbrDaysMinus1 PIC 1(36). 05 NbrDaysMod001Year PIC 1(36). 05 NbrDaysMod004Years PIC 1(36). 05 NbrDaysMod100Years PIC 1(36). 05 NbrDaysMod400Years PIC 1(36). 05 NbrYearsDiv004 PIC 1(36). 05 NbrYearsDiv100 PIC 1(36). 05 NbrYearsDiv400 PIC 1(36). 05 NbrYearsMod004 PIC 1(36). 05 NbrYearsMod100 PIC 1(36). 05 NbrYearsMod400 PIC 1(36). 05 NbrYearsSince1601 PIC 1(36). COPY JDN-Constants-Ws IN ASC-PROC. 05 JDN-Con-DaysIn001Year PIC 1(18) VALUE 365. 05 JDN-Con-DaysIn004Years PIC 1(18) VALUE 1461. 05 JDN-Con-DaysIn100Years PIC 1(18) VALUE 36524. 05 JDN-Con-DaysIn400Years PIC 1(18) VALUE 146097. 02 JDN-Con-Table-Values. 05 FILLER PIC X(52) VALUE '000,031,060,091,121,152,182,213,244,274,305,335,366'. 05 FILLER PIC X(36) VALUE '31,29,31,30,31,30,31,31,30,31,30,31'. 05 FILLER PIC X(52) VALUE '000,031,059,090,120,151,181,212,243,273,304,334,365'. 05 FILLER PIC X(36) VALUE '31,28,31,30,31,30,31,31,30,31,30,31'. 02 JDN-Con-Tables REDEFINES JDN-Con-Table-Values. 05 JDN-Con-LY OCCURS 2. 10 JDN-Con-Days-Before OCCURS 12. 15 JDN-Con-DaysBef PIC 9(03). 15 FILLER PIC X(01). 10 JDN-Con-DaysInYear PIC 9(03). 10 FILLER PIC X(01). 10 JDN-Con-Nbr-Of-Days OCCURS 12. 15 JDN-Con-NbrDays PIC 9(02). 15 FILLER PIC X(01). / LINKAGE SECTION. COPY JDN-Packet-Ws IN ASC-PROC. COPY JDN-Record-Ws IN ASC-PROC. / PROCEDURE DIVISION USING JDN-Packet JDN-Record . 0000-Main-Section SECTION. 0000-Main. IF (1 = JDN-Pkt-AllowOvDD OR JDN-Pkt-AllowOvDDD) PERFORM 9060-Return-NotImplemented. PERFORM 9000-Setup-NoErr-Dont-Return. IF (JDN-Pkt-Action = JDN-Con-DateOfInt) PERFORM 1010-Date-Of-Int ELSE IF (JDN-Pkt-Action = JDN-Con-DayOfInt) PERFORM 1020-Day-Of-Int ELSE IF (JDN-Pkt-Action = JDN-Con-IntOfDate) PERFORM 1030-Int-Of-Date ELSE IF (JDN-Pkt-Action = JDN-Con-IntOfDay) PERFORM 1040-Int-Of-Day ELSE PERFORM 9010-Return-BadAction. PERFORM 9999-Exit-Program. / 1010-Date-Of-Int. PERFORM 8010-Validate-Int. IF (NbrDaysMod400Years = JDN-Con-DaysIn400Years - 1) OR (NbrDaysMod004Years = JDN-Con-DaysIn004Years - 1) MOVE 12 TO JDN-MM MOVE 31 TO JDN-DD ELSE MOVE NbrDaysMod001Year TO i IF (i < JDN-Con-DaysBef (JDN-Pkt-LY, 9)) IF (i < JDN-Con-DaysBef (JDN-Pkt-LY, 5)) IF (i < JDN-Con-DaysBef (JDN-Pkt-LY, 3)) IF (i < JDN-Con-DaysBef (JDN-Pkt-LY, 2)) MOVE 1 TO JDN-MM PERFORM 1012-Set-DD ELSE MOVE 2 TO JDN-MM PERFORM 1012-Set-DD ELSE IF (i < JDN-Con-DaysBef (JDN-Pkt-LY, 4)) MOVE 3 TO JDN-MM PERFORM 1012-Set-DD ELSE MOVE 4 TO JDN-MM PERFORM 1012-Set-DD ELSE IF (i < JDN-Con-DaysBef (JDN-Pkt-LY, 7)) IF (i < JDN-Con-DaysBef (JDN-Pkt-LY, 6)) MOVE 5 TO JDN-MM PERFORM 1012-Set-DD ELSE MOVE 6 TO JDN-MM PERFORM 1012-Set-DD ELSE IF (i < JDN-Con-DaysBef (JDN-Pkt-LY, 8)) MOVE 7 TO JDN-MM PERFORM 1012-Set-DD ELSE MOVE 8 TO JDN-MM PERFORM 1012-Set-DD ELSE IF (i < JDN-Con-DaysBef (JDN-Pkt-LY, 11)) IF (i < JDN-Con-DaysBef (JDN-Pkt-LY, 10)) MOVE 9 TO JDN-MM PERFORM 1012-Set-DD ELSE MOVE 10 TO JDN-MM PERFORM 1012-Set-DD ELSE IF (i < JDN-Con-DaysBef (JDN-Pkt-LY, 12)) MOVE 11 TO JDN-MM PERFORM 1012-Set-DD ELSE IF (i < JDN-Con-DaysInYear (JDN-Pkt-LY)) MOVE 12 TO JDN-MM PERFORM 1012-Set-DD ELSE PERFORM 9120-Return-Strange. 1012-Set-DD. SUBTRACT JDN-Con-DaysBef (JDN-Pkt-LY, JDN-MM) FROM NbrDaysMod001Year GIVING JDN-DD. ADD 1 TO JDN-DD. / 1020-Day-Of-Int. PERFORM 8010-Validate-Int. IF (NbrDaysMod400Years = JDN-Con-DaysIn400Years - 1) OR (NbrDaysMod004Years = JDN-Con-DaysIn004Years - 1) MOVE 366 TO JDN-DDD ELSE ADD NbrDaysMod001Year 1 GIVING JDN-DDD. / 1030-Int-Of-Date. PERFORM 8020-Validate-YYYY. IF (JDN-MM NOT NUMERIC) PERFORM 9040-Return-NonNumericMM. IF (JDN-MM < 1 OR > 12) PERFORM 9100-Return-OutOfRangeMM. IF (JDN-DD NOT NUMERIC) PERFORM 9020-Return-NonNumericDD. IF (JDN-DD < 1 OR > JDN-Con-NbrDays (JDN-Pkt-LY, JDN-MM)) PERFORM 9070-Return-OutOfRangeDD. ADD JDN-Con-DaysBef (JDN-Pkt-LY, JDN-MM) TO JDN-Int. ADD JDN-DD TO JDN-Int. 1040-Int-Of-Day. PERFORM 8020-Validate-YYYY. IF (JDN-DDD NOT NUMERIC) PERFORM 9030-Return-NonNumericDDD. IF (JDN-DDD < 1 OR > JDN-Con-DaysInYear (JDN-Pkt-LY)) PERFORM 9080-Return-OutOfRangeDDD. ADD JDN-DDD TO JDN-Int. / 8000-Set-Leap-Year-Flag. DIVIDE JDN-YYYY BY 4 GIVING LeapDiv REMAINDER LeapMod. IF (LeapMod > 0) MOVE JDN-Con-NotLeap TO JDN-Pkt-LY ELSE DIVIDE JDN-YYYY BY 100 GIVING LeapDiv REMAINDER LeapMod IF (LeapMod > 0) MOVE JDN-Con-Leap TO JDN-Pkt-LY ELSE DIVIDE JDN-YYYY BY 400 GIVING LeapDiv REMAINDER LeapMod IF (LeapMod > 0) MOVE JDN-Con-NotLeap TO JDN-Pkt-LY ELSE MOVE JDN-Con-Leap TO JDN-Pkt-LY. / 8010-Validate-Int. IF (JDN-Int < 1) PERFORM 9090-Return-OutOfRangeInt. IF (JDN-Pkt-AllowOvInt = 0) AND (JDN-Int > 999999) PERFORM 9090-Return-OutOfRangeInt. SUBTRACT 1 FROM JDN-Int GIVING NbrDaysMinus1. MOVE 1600 TO JDN-YYYY. DIVIDE NbrDaysMinus1 BY JDN-Con-DaysIn400Years GIVING NbrDaysDiv400Years REMAINDER NbrDaysMod400Years. MULTIPLY 400 BY NbrDaysDiv400Years. ADD NbrDaysDiv400Years TO JDN-YYYY. IF (NbrDaysMod400Years = JDN-Con-DaysIn400Years - 1) ADD 400 TO JDN-YYYY PERFORM 8000-Set-Leap-Year-Flag ELSE PERFORM 8011-Continue. 8011-Continue. DIVIDE NbrDaysMod400Years BY JDN-Con-DaysIn100Years GIVING NbrDaysDiv100Years REMAINDER NbrDaysMod100Years. MULTIPLY 100 BY NbrDaysDiv100Years. ADD NbrDaysDiv100Years TO JDN-YYYY. DIVIDE NbrDaysMod100Years BY JDN-Con-DaysIn004Years GIVING NbrDaysDiv004Years REMAINDER NbrDaysMod004Years. MULTIPLY 4 BY NbrDaysDiv004Years. ADD NbrDaysDiv004Years TO JDN-YYYY. IF (NbrDaysMod004Years = JDN-Con-DaysIn004Years - 1) ADD 4 TO JDN-YYYY PERFORM 8000-Set-Leap-Year-Flag ELSE PERFORM 8012-Continue. 8012-Continue. DIVIDE NbrDaysMod004Years BY JDN-Con-DaysIn001Year GIVING NbrDaysDiv001Year REMAINDER NbrDaysMod001Year. ADD NbrDaysDiv001Year TO JDN-YYYY. ADD 1 TO JDN-YYYY. PERFORM 8000-Set-Leap-Year-Flag. / 8020-Validate-YYYY. IF (JDN-YYYY NOT NUMERIC) PERFORM 9050-Return-NonNumericYYYY. IF (JDN-YYYY < 1601) PERFORM 9110-Return-OutOfRangeYYYY. IF (JDN-Pkt-AllowOvMM = 1) AND (JDN-Pkt-Action = JDN-Con-IntOfDate) AND (JDN-MM IS NUMERIC) AND (JDN-MM > 0) SUBTRACT 1 FROM JDN-MM DIVIDE JDN-MM BY 12 GIVING MonDiv12 REMAINDER MonMod12 ADD MonDiv12 TO JDN-YYYY ADD MonMod12, 1 GIVING JDN-MM. IF (JDN-Pkt-AllowOvYYYY = 0) AND (JDN-YYYY > 3000) PERFORM 9110-Return-OutOfRangeYYYY. MOVE JDN-YYYY TO NbrYearsSince1601. SUBTRACT 1601 FROM NbrYearsSince1601. DIVIDE NbrYearsSince1601 BY 400 GIVING NbrYearsDiv400 REMAINDER NbrYearsMod400. DIVIDE NbrYearsSince1601 BY 100 GIVING NbrYearsDiv100 REMAINDER NbrYearsMod100. DIVIDE NbrYearsSince1601 BY 004 GIVING NbrYearsDiv004 REMAINDER NbrYearsMod004. MOVE NbrYearsSince1601 TO JDN-Int. MULTIPLY 365 BY JDN-Int. ADD NbrYearsDiv004 TO JDN-Int. SUBTRACT NbrYearsDiv100 FROM JDN-Int. ADD NbrYearsDiv400 TO JDN-Int. PERFORM 8000-Set-Leap-Year-Flag. * (Resist the temptation to use our own Div and Mod variables * to set year type here, because they are relative to 1601.) / 9000-Setup-NoErr-Dont-Return. MOVE JDN-Con-NoErr TO JDN-Pkt-Status. MOVE 'JDNSUB unexpectedly got no error.' TO JDN-Pkt-Status-Text. 9010-Return-BadAction. MOVE JDN-Con-BadAction TO JDN-Pkt-Status. MOVE 'JDNSUB called with unknown action code.' TO JDN-Pkt-Status-Text. PERFORM 9999-Exit-Program. 9020-Return-NonNumericDD. MOVE JDN-Con-NonNumericDD TO JDN-Pkt-Status. MOVE 'JDNSUB day-of-month not numeric.' TO JDN-Pkt-Status-Text. PERFORM 9999-Exit-Program. 9030-Return-NonNumericDDD. MOVE JDN-Con-NonNumericDDD TO JDN-Pkt-Status. MOVE 'JDNSUB day-of-year not numeric.' TO JDN-Pkt-Status-Text. PERFORM 9999-Exit-Program. 9040-Return-NonNumericMM. MOVE JDN-Con-NonNumericMM TO JDN-Pkt-Status. MOVE 'JDNSUB month not numeric.' TO JDN-Pkt-Status-Text. PERFORM 9999-Exit-Program. 9050-Return-NonNumericYYYY. MOVE JDN-Con-NonNumericYYYY TO JDN-Pkt-Status. MOVE 'JDNSUB year not numeric.' TO JDN-Pkt-Status-Text. PERFORM 9999-Exit-Program. 9060-Return-NotImplemented. MOVE JDN-Con-NotImplemented TO JDN-Pkt-Status. MOVE 'JDNSUB feature not implemented yet.' TO JDN-Pkt-Status-Text. PERFORM 9999-Exit-Program. / 9070-Return-OutOfRangeDD. MOVE JDN-Con-OutOfRangeDD TO JDN-Pkt-Status. MOVE 'JDNSUB day-of-month out of range.' TO JDN-Pkt-Status-Text. PERFORM 9999-Exit-Program. 9080-Return-OutOfRangeDDD. MOVE JDN-Con-OutOfRangeDDD TO JDN-Pkt-Status. MOVE 'JDNSUB day-of-year out of range.' TO JDN-Pkt-Status-Text. PERFORM 9999-Exit-Program. 9090-Return-OutOfRangeInt. MOVE JDN-Con-OutOfRangeInt TO JDN-Pkt-Status. MOVE 'JDNSUB Julian Day Number was out of range.' TO JDN-Pkt-Status-Text. PERFORM 9999-Exit-Program. 9100-Return-OutOfRangeMM. MOVE JDN-Con-OutOfRangeMM TO JDN-Pkt-Status. MOVE 'JDNSUB month out of range.' TO JDN-Pkt-Status-Text. PERFORM 9999-Exit-Program. 9110-Return-OutOfRangeYYYY. MOVE JDN-Con-OutOfRangeYYYY TO JDN-Pkt-Status. MOVE 'JDNSUB year out of range.' TO JDN-Pkt-Status-Text. PERFORM 9999-Exit-Program. 9120-Return-Strange. MOVE JDN-Con-Strange TO JDN-Pkt-Status. MOVE 'JDNSUB got a strange logic error.' TO JDN-Pkt-Status-Text. PERFORM 9999-Exit-Program. 9999-Exit-Program. EXIT PROGRAM. @EOF @ELT,IQ UUSIG*1100-001-001.JDNVERFY,,,,COB IDENTIFICATION DIVISION. PROGRAM-ID. JdnVerify. ***************************************************************** * Program Description * ***************************************************************** * * * This is just a test program to prove that JDNSUB produces an * * accurate Julian Day Number across the entire range of January * * 1st, 1601 AD thru December 31st, 3000 AD. It also produces * * execution time statistics, which prove that it's a real speed * * demon too, even with the overhead of this program. When we * * get a higher level of UCOB here at SBA, it will also verify * * that our JDN is the same as UCOB's FUNCTION values. * * * * If there were a mistake in JDNSUB's logic (we're speaking * * hypothetically, of course), and JDNVERIFY used the same logic,* * then JDNVERIFY wouldn't detect the bug. Therefore, JDNVERIFY * * uses completely different logic to determine date, day, leap * * year and number of days since 12/31/1600. (The latter is a * * simple counter variable that gets incremented!) * * * ***************************************************************** ***************************************************************** * REVISION HISTORY * ***************************************************************** * * * ------------------------F O R M A T-------------------------- * * CHANGE CHANGE CHANGED RMIS * * NUMBER DATE BY NUMBER DESCRIPTION OF CHANGE * * ------ ------ ------------- ------ ------------------------- * * CH-NNN MMDDYY FMLLLLLLLLLLL NNNNNN XXXXXXXXXXXXXXXXXXXXXXXXX * * *------------------------------------------------------------ * * CH-000 030194 SRSeaquist 931115 Initial implementation. * ***************************************************************** ***************************************************************** * Compile/Map ECL * ***************************************************************** * * * @GEN,RAN File.JdnVerify * * @CHG,A File.JdnVerify,.JdnVerify/Acob * * @GEN,RUN File.JdnVerify * * @CHG,A File.JdnVerify,.JdnVerify/Ucob * * * * This 2-part process is necessary because @GEN,RAUN would gen * * 2 absolutes with the same name, and the 2nd one would delete * * the 1st one! Also, if you want to print both breakpoint * * files, copy the 1st one to another filename before doing the * * 2nd gen. * * * ***************************************************************** / ENVIRONMENT DIVISION. CONFIGURATION SECTION. COPY ComCon IN ASC-PROC. *COPY ComConDebug IN ASC-PROC. / DATA DIVISION. WORKING-STORAGE SECTION. 01 Counters-Flags-Etc. 05 CtrErrs PIC 1(36). 05 Hold-Date PIC X(08). 05 Hold-Date-Redef REDEFINES Hold-Date. 10 Hold-Day PIC X(07). 10 FILLER PIC X(01). 05 NbrOfDaysInYear PIC 1(36). 05 Prev PIC 1(36). 05 Year PIC 1(36). 05 YearRedef REDEFINES Year. 10 YearDiv4 PIC 1(34). 10 YearMod4 PIC 1(02). 01 NbrOfDaysConstants. 05 FILLER PIC X(24) VALUE '312931303130313130313031'. 01 NbrOfDaysTable REDEFINES NbrOfDaysConstants. 05 NbrOfDays OCCURS 12 PIC 9(02). 01 PicZ9s PIC ZZZ,ZZZ,ZZ9.99. 01 Time-Comp. 05 Time-Comp-Beg PIC 9(08)V99. 05 Time-Comp-Dur PIC 9(08)V99. 05 Time-Comp-End PIC 9(08)V99. 05 Time-Comp-Value PIC 9(08)V99. 05 Time-Comp-Value-Redef REDEFINES Time-Comp-Value. 10 Time-Comp-Secs PIC 9(08). 10 Time-Comp-Hun PIC 9(02). 01 Time-Disp. 05 Time-Disp-HH PIC 9(02). 05 FILLER PIC X(01) VALUE ':'. 05 Time-Disp-MM PIC 9(02). 05 FILLER PIC X(01) VALUE ':'. 05 Time-Disp-SS PIC 9(02). 05 FILLER PIC X(01) VALUE '.'. 05 Time-Disp-Hun PIC 9(02). 01 Time-Sys. 05 Time-Sys-HH PIC 9(02). 05 Time-Sys-MM PIC 9(02). 05 Time-Sys-SS PIC 9(02). 05 Time-Sys-Hun PIC 9(02). COPY JDN-Constants-Ws IN ASC-PROC. / COPY JDN-Packet-Ws IN ASC-PROC. COPY JDN-Record-Ws IN ASC-PROC. / PROCEDURE DIVISION. 0000-Main-Section SECTION. 0000-Main. PERFORM 0010-Date-Test. PERFORM 0020-Day-Test. DISPLAY 'END JDNVERIFY' UPON Prtr-Out. STOP RUN. 0010-Date-Test. PERFORM 0030-Display-Time-Beg. PERFORM 1000-Handle-Date-YYYY VARYING JDN-YYYY FROM 1601 BY 1 UNTIL JDN-YYYY > 3000. DISPLAY 'End of 2-way "Date" test after ' CtrErrs ' error(s).' UPON Prtr-Out. PERFORM 0040-Display-Time-End. 0020-Day-Test. PERFORM 0030-Display-Time-Beg. PERFORM 2000-Handle-Day-YYYY VARYING JDN-YYYY FROM 1601 BY 1 UNTIL JDN-YYYY > 3000. DISPLAY 'End of 2-way "Day" test after ' CtrErrs ' error(s).' UPON Prtr-Out. PERFORM 0040-Display-Time-End. 0030-Display-Time-Beg. PERFORM 0050-Get-Time. DISPLAY ' ' UPON Prtr-Out. DISPLAY 'Began ' Time-Disp UPON Prtr-Out. MOVE Time-Comp-Value TO Time-Comp-Beg. MOVE LOW-VALUES TO Counters-Flags-Etc, JDN-Record. / 0040-Display-Time-End. PERFORM 0050-Get-Time. DISPLAY 'Ended ' Time-Disp UPON Prtr-Out. MOVE Time-Comp-Value TO Time-Comp-End. SUBTRACT Time-Comp-Beg FROM Time-Comp-End GIVING Time-Comp-Dur. MOVE Time-Comp-Dur TO PicZ9s. DISPLAY 'Duration' PicZ9s ' seconds,' UPON Prtr-Out. Prev*2 ADD Prev TO Prev. DISPLAY 'Divided by ' Prev ' conversions,' UPON Prtr-Out. COMPUTE Time-Comp-Value = (1000000 * Time-Comp-Dur) / Prev. MOVE Time-Comp-Value TO PicZ9s. DISPLAY 'Yields ' PicZ9s ' microseconds per conversion.' UPON Prtr-Out. DISPLAY ' ' UPON Prtr-Out. 0050-Get-Time. ACCEPT Time-Sys FROM TIME. MOVE Time-Sys-HH TO Time-Disp-HH. MOVE Time-Sys-MM TO Time-Disp-MM. MOVE Time-Sys-SS TO Time-Disp-SS. MOVE Time-Sys-Hun TO Time-Disp-Hun. MoveHH MOVE Time-Sys-HH TO Time-Comp-Secs. Cvt MM MULTIPLY 60 BY Time-Comp-Secs. Add MM ADD Time-Sys-MM TO Time-Comp-Secs. Cvt SS MULTIPLY 60 BY Time-Comp-Secs. Add SS ADD Time-Sys-SS TO Time-Comp-Secs. MoveHn MOVE Time-Sys-Hun TO Time-Comp-Hun. / 1000-Handle-Date-YYYY. MOVE JDN-YYYY TO Year. IF (YearMod4 = 0) IF (JDN-YY = 0) IF (JDN-CC = 16 OR 20 OR 24 OR 28) MOVE 29 TO NbrOfDays (2) ELSE MOVE 28 TO NbrOfDays (2) ELSE MOVE 29 TO NbrOfDays (2) ELSE MOVE 28 TO NbrOfDays (2). PERFORM 1010-Handle-MM VARYING JDN-MM FROM 1 BY 1 UNTIL JDN-MM > 12. 1010-Handle-MM. PERFORM 1020-Handle-DD VARYING JDN-DD FROM 1 BY 1 UNTIL JDN-DD > NbrOfDays (JDN-MM). 1020-Handle-DD. PERFORM JDN-Acc-Int-Of-Date. IF (JDN-Pkt-Status = JDN-Con-NoErr) IF (JDN-Int = Prev + 1) NotYet* AND (JDN-Int = FUNCTION INTEGER-OF-DATE (JDN-Date)) PERFORM 1030-Verify-Reverse-Direction ELSE DISPLAY 'At ' JDN-Date ', Prev was ' Prev ', but JDN-Int was ' JDN-Int NotYet* ', and function was ' NotYet* FUNCTION INTEGER-OF-DATE (JDN-Date) UPON Prtr-Out PERFORM 8010-Abort-If-Too-Many-Msgs ELSE PERFORM 8000-Complain. MOVE JDN-Int TO Prev. / 1030-Verify-Reverse-Direction. MOVE JDN-Date TO Hold-Date. PERFORM JDN-Acc-Date-Of-Int. IF (JDN-Pkt-Status = JDN-Con-NoErr) IF (JDN-Date NOT = Hold-Date) NotYet* OR (JDN-Date NOT = FUNCTION DATE-OF-INTEGER (JDN-Int)) DISPLAY 'On day ' JDN-Int ', Date was ' Hold-Date ', but JDN-Date was ' JDN-Date NotYet* ', and function was ' NotYet* FUNCTION DATE-OF-INTEGER (JDN-Int) UPON Prtr-Out PERFORM 8010-Abort-If-Too-Many-Msgs MOVE Hold-Date TO JDN-Date ELSE NEXT SENTENCE ELSE PERFORM 8000-Complain. / 2000-Handle-Day-YYYY. MOVE JDN-YYYY TO Year. IF (YearMod4 = 0) IF (JDN-YY = 0) IF (JDN-CC = 16 OR 20 OR 24 OR 28) MOVE 366 TO NbrOfDaysInYear ELSE MOVE 365 TO NbrOfDaysInYear ELSE MOVE 366 TO NbrOfDaysInYear ELSE MOVE 365 TO NbrOfDaysInYear. PERFORM 2010-Handle-DDD VARYING JDN-DDD FROM 1 BY 1 UNTIL JDN-DDD > NbrOfDaysInYear. 2010-Handle-DDD. PERFORM JDN-Acc-Int-Of-Day. IF (JDN-Pkt-Status = JDN-Con-NoErr) IF (JDN-Int = Prev + 1) NotYet* AND (JDN-Int = FUNCTION INTEGER-OF-DAY (JDN-Day)) PERFORM 2020-Verify-Reverse-Direction ELSE DISPLAY 'At ' JDN-Day ', Prev was ' Prev ', but JDN-Int was ' JDN-Int NotYet* ', and function was ' NotYet* FUNCTION INTEGER-OF-DAY (JDN-Day) UPON Prtr-Out PERFORM 8010-Abort-If-Too-Many-Msgs ELSE PERFORM 8000-Complain. MOVE JDN-Int TO Prev. / 2020-Verify-Reverse-Direction. MOVE JDN-Day TO Hold-Day. PERFORM JDN-Acc-Day-Of-Int. IF (JDN-Pkt-Status = JDN-Con-NoErr) IF (JDN-Day NOT = Hold-Day) NotYet* OR (JDN-Day NOT = FUNCTION DAY-OF-INTEGER (JDN-Int)) DISPLAY 'On day ' JDN-Int ', Day was ' Hold-Day ', but JDN-Day was ' JDN-Day NotYet* ', and function was ' NotYet* FUNCTION DAY-OF-INTEGER (JDN-Int) UPON Prtr-Out PERFORM 8010-Abort-If-Too-Many-Msgs MOVE Hold-Day TO JDN-Day ELSE NEXT SENTENCE ELSE PERFORM 8000-Complain. / 8000-Complain. DISPLAY 'JDN-Date = ' JDN-Date ', JDN-Int = ' JDN-Int ', result was "' JDN-Pkt-Status-Text '"' UPON Prtr-Out. PERFORM 8010-Abort-If-Too-Many-Msgs. 8010-Abort-If-Too-Many-Msgs. ADD 1 TO CtrErrs. IF (CtrErrs > 33) MOVE '30008888' TO JDN-Date, Hold-Date. COPY JDN-Record-Access IN ASC-PROC. @EOF @ELT,IQD UUSIG*1100-001-001.JDNVERFY/RUN,,SENT,,PLS @XQT S.JDNVERIFY/ACOBLOOP2CA Began 00:48:36.54 End of 2-way "Date" test after 00000000000 error(s). Ended 00:49:42.63 Duration 66.09 seconds, Divided by 00001022678 conversions, Yields 64.62 microseconds per conversion. Began 00:49:42.63 End of 2-way "Day" test after 00000000000 error(s). Ended 00:50:36.08 Duration 53.45 seconds, Divided by 00001022678 conversions, Yields 52.26 microseconds per conversion. END JDNMAIN @XQT S.JDNVERIFY/UCOBLOOP2CAL Began 00:50:36.39 End of 2-way "Date" test after 00000000000 error(s). Ended 00:52:12.55 Duration 96.16 seconds, Divided by 00001022678 conversions, Yields 94.02 microseconds per conversion. Began 00:52:12.55 End of 2-way "Day" test after 00000000000 error(s). Ended 00:53:29.64 Duration 77.09 seconds, Divided by 00001022678 conversions, Yields 75.38 microseconds per conversion. END JDNMAIN @HDG,N .L,0. . ECL PAGE EJECT @XQT S.JDNVERIFY/ACOB Began 00:53:30.72 End of 2-way "Date" test after 00000000000 error(s). Ended 00:54:31.85 Duration 61.13 seconds, Divided by 00001022678 conversions, Yields 59.77 microseconds per conversion. Began 00:54:31.85 End of 2-way "Day" test after 00000000000 error(s). Ended 00:55:26.59 Duration 54.74 seconds, Divided by 00001022678 conversions, Yields 53.52 microseconds per conversion. END JDNMAIN @XQT S.JDNVERIFY/UCOB Began 00:55:26.95 End of 2-way "Date" test after 00000000000 error(s). Ended 00:56:36.08 Duration 69.13 seconds, Divided by 00001022678 conversions, Yields 67.59 microseconds per conversion. Began 00:56:36.08 End of 2-way "Day" test after 00000000000 error(s). Ended 00:57:34.80 Duration 58.72 seconds, Divided by 00001022678 conversions, Yields 57.41 microseconds per conversion. END JDNMAIN @BRKPT PRINT$ @END SENT @PDP,IC UUSIG*1100-001-001.PROGID ***************************************************************** * COMMENT SECTION * ***************************************************************** * RELATED PROCS * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * COMCON: SOURCE-COMPUTER thru SPECIAL-NAMES. * * **DOES** define some older SPECIAL-NAMES. * * Does **NOT** specify "WITH DEBUGGING MODE". * * * * COMCONDEBUG: SOURCE-COMPUTER thru SPECIAL-NAMES. * * **DOES** define some older SPECIAL-NAMES. * * **DOES** specify "WITH DEBUGGING MODE". * * * * PROGID: IDENTIFICATION DIVISION thru SPECIAL-NAMES. * * Does **NOT** define the older SPECIAL-NAMES. * * Does **NOT** specify "WITH DEBUGGING MODE". * * * * PROGIDDEBUG: IDENTIFICATION DIVISION thru SPECIAL-NAMES. * * Does **NOT** define the older SPECIAL-NAMES. * * **DOES** specify "WITH DEBUGGING MODE". * * * * Comparison: * * * * Use COMCON or COMCONDEBUG if you have to get a program * * thru PathVu, or in older programs that still use COMCON's * * older SPECIAL-NAMES. (PathVu isn't smart enough to * * tolerate the IDENTIFICATION DIVISION being in a COPY proc * * so you have no choice in that situation.) * * * * Use PROGID or PROGIDDEBUG if you'd like to take a short- * * cut to define everything from IDENTIFICATION down thru * * SPECIAL-NAMES all in one swell foop. If you have program * * remarks, you would include them as comments rather than * * as a REMARKS paragraph. (This should not be regarded as * * deficiency in PROGID, incidentally. It is, in fact, * * **REQUIRED** that you replace the REMARKS paragraph with * * comments when you convert a program to UCOB). * * * * PROGID and PROGIDDEBUG are ideal for "quick and dirty" * * programs. PROGID gets its name from the fact that the * * only parameter that you have to provide it is the * * PROGRAM-ID (by replacing P1). * * * * Debug Versions: * * * * Use COMCONDEBUG or PROGIDDEBUG if you want to turn on * * debug lines ("D" in column 7). Be aware that UCOB does * * **NOT** support USE FOR DEBUGGING MODE in DECLARATIVES. * * (It doesn't complain, but it also doesn't generate code!) * * * ***************************************************************** * DESCRIPTION OF THE PROCS * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * These COPY procs provide a standard set of easy-to-remember * * SPECIAL-NAMES that should be used when converting programs to * * UCOB. The new names are needed because UCOB doesn't support * * ACOB's ACCEPT and DISPLAY mnemonics. In addition, there are * * versions of these procs in UCS-PROC that ease UCOB conversion * * by explicitly defining the old ACOB mnemonics. * * * * Another reason to use one of these COPY procs is that they * * contain the OBJECT-COMPUTER clause that is best optimized for * * our current system. * * * * Commentary About The SPECIAL-NAMES: * * =================================== * * * * The following observations should make the new names **VERY** * * easy to remember: * * * * (1) All non-switch names begin with 4 letters. * * * * (2) Almost all non-switch names end in "-In" or "-Out". * * (The only exception is "Page-Eject".) * * * * (3) Switch names are just shortened Unisys names. * * (That is, SWITCH- is simply shortened to SW-.) * * * * You may notice that "PAGE IS Page" is not defined among the * * ACOB mnemonics explicitly defined for UCOB programs. The * * reason is that PAGE is still a reserved word under UCOB * * (WRITE ... AFTER ADVANCING PAGE). Use "Page-Eject" instead. * * * * All switches are given ON STATUS names, but only switches 13 * * thru 24 are given switch names. The reason for this is the * * fact that only 13 thru 24 are settable with the SET verb. * * In fact, there is no syntactically-valid situation in which * * switch names for 1 thru 12 would be usable. By *NOT* naming * * switches 1 thru 12, we save ourselves the trouble of having * * to look up which ones are settable in the ACOB or UCOB PRM. * * (We need only look at a gen listing of the program.) * * * * Also note the similarity between the switch ON STATUS names * * and the 88-levels in EROPT-WS. This was on-purpose. It * * allows you to change back and forth between @SETC and @XQT * * options (for batch program runtime control) very easily. * * * * The SYMBOLIC CHARACTERS clause allows UCOB programs not to * * care which COMPAT option was used to gen the program as far * * as the meaning of HIGH-VALUES is concerned. Programs that * * use these names will not be compilable with ACOB, however. * * (The ordinal value only *looks* wrong. Ordinal = actual+1.) * * * ***************************************************************** * USAGE * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * To use this proc in ACOB programs: * * COPY PROGID IN ASC-PROC REPLACING * * P1 BY <>. * * * * To use this proc in UCOB programs: * * COPY PROGID IN UCS-PROC REPLACING * * P1 BY <>. * * * * Note!: The only things that differ are the IN clause on the * * COPY and whether or not the old ACOB mnemonics are defined. * * Therefore, if you use only the new mnemonics (for example, * * "Prtr-Out" instead of "PRINTER"), you could, if you wish, * * continue to say IN ASC-PROC, even after the program has been * * converted to UCOB. * * * ***************************************************************** ***************************************************************** * REVISION HISTORY * ***************************************************************** * * * ------------------------F O R M A T-------------------------- * * CHANGE CHANGE CHANGED RMIS * * NUMBER DATE BY NUMBER DESCRIPTION OF CHANGE * * ------ ------ ------------- ------ ------------------------- * * CH-NNN MMDDYY FMLLLLLLLLLLL NNNNNN XXXXXXXXXXXXXXXXXXXXXXXXX * * ------------------------------------------------------------- * * CH-000 111092 SRSeaquist 930030 Initial Implementation * * ------ ------ ------------- ------ ------------------------- * * CH-001 120192 SRSeaquist 930030 Removed S-OFF and SLIST * * ------ ------ ------------- ------ ------------------------- * * CH-002 080693 SRSeaquist 930035 Complete rewrite: * * * * (1) Changed SOURCE- and OBJECT-COMPUTER paragraphs to * * say "UNISYS-2200" to improve runtime efficiency. * * * * (2) Condensed out white space as much as readably * * possible. * * * * (3) Added switch names for all switches settable by * * the SET verb. (See DESCRIPTION OF THE PROC.) * * * * (4) Added SYMBOLIC CHARACTERS clause for explicit * * control of HIGH-VALUE(S) in UCOB programs. * * * * (5) Greatly expanded documentation. * * * ***************************************************************** PROGID PROC IDENTIFICATION DIVISION. *PROGID* PROGRAM-ID. P1. *PROGID* DATE-COMPILED. *PROGID* *PROGID* ENVIRONMENT DIVISION. *PROGID* CONFIGURATION SECTION. *PROGID* SOURCE-COMPUTER. UNISYS-2200. *PROGID* OBJECT-COMPUTER. UNISYS-2200 MEMORY 3 MODULES. *PROGID* SPECIAL-NAMES. *PROGID* *PROGID* * Old names, don't use in new programs: *PROGID* UCOB * CARD-PUNCH IS Card-Punch CARD-READER IS Card-Reader *PROGID* UCOB * CONSOLE IS Console PRINTER IS Printer *PROGID* *PROGID* * New names, preferred: *PROGID* CARD-PUNCH IS Card-Out CARD-READER IS Card-In *PROGID* CONSOLE IS Oper-In CONSOLE IS Oper-Out *PROGID* PAGE IS Page-Eject PRINTER IS Prtr-Out *PROGID* SWITCH-1 ON IS 1-Opt SWITCH-13 IS Sw-13 ON IS 13-Opt *PROGID* SWITCH-2 ON IS 2-Opt SWITCH-14 IS Sw-14 ON IS 14-Opt *PROGID* SWITCH-3 ON IS 3-Opt SWITCH-15 IS Sw-15 ON IS 15-Opt *PROGID* SWITCH-4 ON IS 4-Opt SWITCH-16 IS Sw-16 ON IS 16-Opt *PROGID* SWITCH-5 ON IS 5-Opt SWITCH-17 IS Sw-17 ON IS 17-Opt *PROGID* SWITCH-6 ON IS 6-Opt SWITCH-18 IS Sw-18 ON IS 18-Opt *PROGID* SWITCH-7 ON IS 7-Opt SWITCH-19 IS Sw-19 ON IS 19-Opt *PROGID* SWITCH-8 ON IS 8-Opt SWITCH-20 IS Sw-20 ON IS 20-Opt *PROGID* SWITCH-9 ON IS 9-Opt SWITCH-21 IS Sw-21 ON IS 21-Opt *PROGID* SWITCH-10 ON IS 10-Opt SWITCH-22 IS Sw-22 ON IS 22-Opt *PROGID* SWITCH-11 ON IS 11-Opt SWITCH-23 IS Sw-23 ON IS 23-Opt *PROGID* SWITCH-12 ON IS 12-Opt SWITCH-24 IS Sw-24 ON IS 24-Opt *PROGID* UCOB * SYMBOLIC CHARACTERS High-Value-0177 High-Values-0177 *PROGID* UCOB * High-Value-0377 High-Values-0377 *PROGID* UCOB * ARE 128 128 256 256 *PROGID* . *PROGID* END @EOF