Google
 

Trailing-Edge - PDP-10 Archives - BB-H548C-BM - iql-source/iqsch.cbl
There are 2 other files named iqsch.cbl in the archive. Click here to see a list.
000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.             IQSCH.
000300 SECURITY.               COPYRIGHT 1981 AZREX INC;
000400                         ALL RIGHTS RESERVED.
000500   
000600 ENVIRONMENT DIVISION.
000700 CONFIGURATION SECTION.
000800 INPUT-OUTPUT SECTION.
000900 FILE-CONTROL.
001000     SELECT DICT-TRNS-FILE ASSIGN TO DSK
001100      RECORDING MODE IS ASCII.
001200 DATA DIVISION.
001300 FILE SECTION.
001400
001500 FD DICT-TRNS-FILE
001600     VALUE OF IDENTIFICATION IS TRNS-FILE-VID
001700     LABEL RECORDS ARE STANDARD
001800     BLOCK CONTAINS 1 RECORD.
001900 01  DICT-TRNS-REC DISPLAY-7.
002000     02  TRNS-CODE       PIC X(2).
002100     02  TRNS-ACT        PIC X(1).
002200     02  FILLER          PIC X(38).
002300     02  TRNS-RTYPE      PIC XXX.
002400     02  FILLER          PIC X(9).
002500     02  TRNS-FCHAR      PIC 9(4).
002600     02  TRNS-NCHAR      PIC 9(4).
002700     02  TRNS-ITYPE      PIC X.
002800     02  FILLER          PIC X(58).
002900
003000 WORKING-STORAGE SECTION.
000000*
000000 01  COPYRIGHT-NOTICE     PIC X(50)     VALUE
000000     "COPYRIGHT 1981 - AZREX, INC. - ALL RIGHTS RESERVED".
000000*
003100   
003200 01  CODEX               PIC X          VALUE SPACE.
003300 01  LAST-REC-TYPE       PIC XXX        VALUE SPACE.
003400 01  NEXT-FCHAR-SLOT     PIC S9(8) COMP VALUE 0.
003500 01  I                   PIC S9(8) COMP VALUE 0.
003600 01  J                   PIC S9(8) COMP VALUE 0.
003700 01  ERR                 INDEX.
003800 01  FLAG                INDEX.
003900 01  IJOB-NO             INDEX.
004000 01  LOCKX               PIC X(30) VALUE SPACES DISPLAY-7.
004010 01  LOCKX-SIXBIT        PIC X(30) VALUE SPACES DISPLAY-6.
004100 01  SCH                 PIC X(30) VALUE SPACES DISPLAY-7.
004200 01  SCH-SIXBIT          PIC X(30) VALUE SPACES DISPLAY-6.
004300 01  SSC                 PIC X(30) VALUE SPACES DISPLAY-7.
004400 01  SSC-SIXBIT          PIC X(30) VALUE SPACES DISPLAY-6.
004500 01  STSBLK.
004600     02  FILLER          PIC X(6)   VALUE SPACES DISPLAY-6.
004700 01  SYSCOM.
004800     02  FILLER          PIC X(70) VALUE SPACES DISPLAY-7.
004900     02  ERROR-STATUS    INDEX.
005000     02  FILLER          PIC X(105) VALUE SPACES DISPLAY-7.
005100 01  TRNSBLK DISPLAY-7.
005200     02  TRNSELEM        OCCURS 2160 TIMES INDEXED BY IX.
005300         04  TRNS-ID     PIC XX.
005400         04  FILLER      PIC X(118).
005500 01  BUFFER REDEFINES TRNSBLK PIC X(259200) DISPLAY-7.
005600 01  TRNS-FILE-VID.
005700     02  FILLER          PIC XX VALUE "QC".
005800     02  JOB-NO          PIC 999 VALUE 0.
005900     02  FILLER          PIC X(4) VALUE "DTMP".
006000
006100 PROCEDURE DIVISION.
006200
006300 BEGIN.
006400     PERFORM INIT THRU INIT-EXIT.
006500     ENTER MACRO IQDBDM USING
006600         SCH,SSC,LOCKX,BUFFER,FLAG,ERR,STSBLK,SYSCOM,TRNSBLK.
006700     IF ERR NOT = 0 
006800         DISPLAY " "
006900         DISPLAY "?-Error occurred in IQDBDM..check"
007000            " that your schema name"
007100         DISPLAY "  sub-schema name and key are correct"
007200         STOP RUN.
007300     PERFORM WRITE-TRNS THRU WRITE-TRNS-EXIT.
007400     DISPLAY " ".
007500     DISPLAY "[  Finished. Please run IQD to update QPDICT.SEQ]".
007600     STOP RUN.
007700
007800 INIT.
007900     DISPLAY " ".
008000     DISPLAY "[IQSCH - Program to create IQL dictionary"
008100      " from .SCH file]".
008200     DISPLAY " ".
008300     DISPLAY    "SCHEMA=" WITH NO ADVANCING
008400     ACCEPT SCH-SIXBIT.  
008500     MOVE SCH-SIXBIT TO SCH.
008600     DISPLAY "SUB-SCHEMA=" WITH NO ADVANCING.
008700     ACCEPT SSC-SIXBIT.  
008800     MOVE SSC-SIXBIT TO SSC.
008900     DISPLAY "PRIVACY KEY (if any)=" WITH NO ADVANCING.
009000     ACCEPT LOCKX-SIXBIT.
009010     MOVE LOCKX-SIXBIT TO LOCKX.
009100
009200 INIT1.
009300     DISPLAY "UPDATE CODE (H for help) =" WITH NO ADVANCING.
009400     ACCEPT CODEX.
009500     IF CODEX = "H" 
009600         DISPLAY "A means ADD this as a new dictionary"
009700         DISPLAY
009800           "R means REPLACE the current dictionary with this one"
009900         GO TO INIT1.
010000     IF CODEX NOT = "A" AND CODEX NOT = "R" 
010100         DISPLAY "%-Please type A, R, or H" GO TO INIT1.
010200     MOVE 2 TO FLAG.
010300     ENTER MACRO IQGJOB USING IJOB-NO.
010400     MOVE IJOB-NO TO JOB-NO.
010500
010600 INIT-EXIT.   
010700     EXIT.
010800
010900 WRITE-TRNS.
011000     OPEN OUTPUT DICT-TRNS-FILE.
011100     SET IX TO 2.
011200     PERFORM WRITE-ONE-TRNS THRU WRITE-ONE-TRNS-EXIT.
011300     MOVE "A" TO CODEX.
011400
011500 WRITE-TRNS-LOOP.
011600     IF TRNS-ID (IX) = LOW-VALUES OR TRNS-ID (IX) = SPACES
011700         CLOSE DICT-TRNS-FILE
011800         GO TO WRITE-TRNS-EXIT
011900       ELSE PERFORM WRITE-ONE-TRNS THRU WRITE-ONE-TRNS-EXIT
012000         GO TO WRITE-TRNS-LOOP.
012100
012200 WRITE-TRNS-EXIT.   
012300     EXIT.
012400
012500 WRITE-ONE-TRNS.
012600     MOVE TRNSELEM (IX) TO DICT-TRNS-REC.
012700     MOVE CODEX TO TRNS-ACT.
012800     IF TRNS-CODE = "RD" MOVE TRNS-RTYPE TO LAST-REC-TYPE
012900         MOVE 1 TO NEXT-FCHAR-SLOT
013000         GO TO WRITE-ONE-TRNS-WRITE.
013100     IF TRNS-CODE NOT = "DD" GO TO WRITE-ONE-TRNS-WRITE.
013200*   *CALCULATE CURRENT LEFTMOST CHAR ORIGIN FOR DD IN-HAND*.
013300     IF TRNS-ITYPE = "1" OR "A" OR "2" OR "N"  
013400         MOVE NEXT-FCHAR-SLOT TO TRNS-FCHAR
013500         ADD TRNS-NCHAR TO NEXT-FCHAR-SLOT
013600         GO TO WRITE-ONE-TRNS-WRITE.
013700     IF TRNS-ITYPE NOT = "6" AND TRNS-ITYPE NOT = "B" 
013800         DISPLAY "%-Error in item type generated by IQSCH: "
013900             TRNS-ITYPE UPON CONSOLE
014000     GO TO WRITE-ONE-TRNS-WRITE.
014100     IF LAST-REC-TYPE = "006" GO TO WRITE-ONE-TRNS6.
014200     IF LAST-REC-TYPE = "007" GO TO WRITE-ONE-TRNS7.
014300     DISPLAY "%-Error in record type generated by IQSCH:"
014400         LAST-REC-TYPE UPON CONSOLE.
014500     DISPLAY "   assuming 007 (ASCII)" UPON CONSOLE.
014600     MOVE "007" TO LAST-REC-TYPE.
014700    
014800 WRITE-ONE-TRNS7.
014900*   *CALCULATE NEXT POSSIBLE ASCII ORIGIN FOR A COMP (BINARY)*
015000     DIVIDE NEXT-FCHAR-SLOT BY 5 GIVING I REMAINDER J.
015100     IF J > 1 ADD 1 TO I.
015200     COMPUTE NEXT-FCHAR-SLOT = (I * 5) + 1.
015300     MOVE NEXT-FCHAR-SLOT TO TRNS-FCHAR.
015400     IF TRNS-NCHAR > 10 ADD 10 TO NEXT-FCHAR-SLOT
015500         ELSE ADD 5 TO NEXT-FCHAR-SLOT.
015600     GO TO WRITE-ONE-TRNS-WRITE.
015700   
015800 WRITE-ONE-TRNS6.
015900*   *HERE CALCULATE NEXT POSSIBLE SIXBIT SLOT FOR COMP (BINARY)*.
016000     DIVIDE NEXT-FCHAR-SLOT BY 6 GIVING I REMAINDER J.
016100     IF J > 1 ADD 1 TO I.
016200     COMPUTE NEXT-FCHAR-SLOT = (I * 6) + 1.
016300     IF TRNS-NCHAR > 10 ADD 12 TO NEXT-FCHAR-SLOT
016400         ELSE ADD 6 TO NEXT-FCHAR-SLOT.
016500    
016600 WRITE-ONE-TRNS-WRITE.
016700     WRITE DICT-TRNS-REC.
016800     SET IX UP BY 1.
016900    
017000 WRITE-ONE-TRNS-EXIT.
017100     EXIT.