TITLE RPGIIA FOR RPGII %1 SUBTTL RPGII INITIALIZATION BOB CURRIER ;WITH CREDIT DUE TO AL BLACKINGTON FOR HIS COBOL INITIALIZATION ; ROUTINES, WHICH I STOLE MOST OF. MAY THE GREAT BIRD OF MAYNARD ; OVERLOOK SUCH LITTLE THINGS AS COPYRIGHTS. ; ; PHASE A FOR RPGII COMPILER ; ; PHASE A IS THE PHASE THAT THE USER INTERACTS WITH. IT ; IS THIS PHASE WHICH ACCEPTS THE USERS COMMAND STRING ; AND SETS UP ALL THE FILES, AS WELL AS INITIALIZING ; THE TABLES, PDL, DEVICES ETC. NOTE THAT THE COMMAND ; ANALYZER IS NOT THE STANDARD SCAN/WILD AS IT SHOULD ; BE, BUT IS INSTEAD THE COBOL STYLE COMMAND SCANNER. ; OH WELL. ; ; JUNE 17, 1975 13:59:12 ; ; Copyright (C) 1975, 1976 Bob Currier and Cerritos College ; All rights reserved (See reservations above) ; TWOSEG RELOC 400000 .REQUIRE HELPER ; ;START 'ER UP ; RPGIIA: PORTAL START ; COMMANDS FROM TTY PORTAL COMDSK ; COMMANDS FROM DSK PORTAL RPGLAR ; RESTART START: MOVEM 7,RUNPPN ; SAVE DEVICE AND PPN OF RUN IFN %CPU-%20,< TRNE 11,777777 ; did we get a device? > HRLZI 11,'DSK' ; no - default to DSK MOVEM 11,RUNDEV MOVEI SW,0 ; CLEAR FLAGS ;START A BRAND NEW COMPILATION RPGLAR: TSWF FDSKC ; INPUT COMMANDS FROM TTY? JRST RPGLAS ; NO RESET ; YES--RESET ALL DEVICES IFN DEBUG, ; FOR DEBUGGING PURPOSES, MOVE SYMBOLS BELOW .JBFF INIT COM,1 ; GET TTY FOR COMMANDS SIXBIT "TTY" XWD 0,COMBH HALT .-3 ; NO TTY? (WOT THE...) INBUF COM,2 ; GET TWO COMMAND BUFERS SETZM SAVJFF ; IF RESTART, FORCE SAVING .JBFF RPGLAS: CPUCHK TB ; verify what CPU we're on SKIPN TA,SAVJFF ; SAVE .JBFF IF IT WASN'T DONE ALREADY MOVE TA,.JBFF MOVEM TA,SAVJFF MOVEM TA,.JBFF ; RESTORE .JBFF MOVE TA,RUNDEV ; IS RUN DEVICE A REAL DISK? DEVCHR TA, TLNN TA,$DSK JRST NOTDSK ; NO--GO CRY ABOUT IT ;SET UP THE IMPURE AREA ;GET A COMMAND STRING AND BOP OFF LEADING CARRIAGE RETURNS SETFAZ A; TSWF FDSKC; JRST TYST1 MSG < *> TYST1: PUSHJ PP,SETIMP ; SET UP IMPURE AREA PUSHJ PP,GETDT ; SET UP DATE AND TIME PUSHJ PP,GETVER ; SET UP VERSION MOVEI TB,^D100 ; INITIALIZE ERROR COUNT MOVEM TB,BADCNT## JRST TESTCR TYPEST: TSWF FDSKC; JRST TESTCR MSG < *> TESTCR: PUSHJ PP,COMKAR ; GET FIRST CHAR FROM COMMAND STRING TSWF FECOM; ; END OF COMMAND FILE? EXIT ; YES--QUIT JUMPE CH,TYPEST ; NO--NULL? CAIN CH,15 ; NO-CARRIAGE RETURN? JRST TYPEST ; YES--LOOP ON THRU SWON FCOMCH; ; NO--SET THE "REGET CHARACTER" FLAG SWON FTERA ; SET "WE ARE TYPING ERRORS" SETZM CREFSW ; CLEAR /C ;SET UP THE BINARY DEVICE SETBIN: MOVEI DA,BINDEV PUSHJ PP,GETFIL ; GET FIRST FILE TSWT FDSKC ; INPUT FROM TTY? JRST SETBNC MSG ; ; NO - SETBNC: CAIE CH,"-" ; IS IT A NULL FILE? JRST SETBNB ; NO-- SETZM BINDEV ; YES IT IS-- PUSHJ PP,COMKAR CAIE CH,"," CAIN CH,"=" JRST SETLST JRST TUMANY SETBNA: MOVSI TA,'DSK' ; USE DEVICE 'DSK' MOVEM TA,BINDEV ; JRST SETLST SETBNB: JUMPE TA,SETBNA TRNE TA,$BIN ; BINARY MODE LEGAL? TLNN TA,$OUT ; YES--OUTPUT DEVICE? JRST BADBIN ; NO--TYPETH THY ERROR ;SET UP LISTING DEVICE SETLST: CAIN CH,"=" ; ANY FILE THERE? JRST SETLSA ; NO-- CAIN CH,15 ; END OF STRING? JRST NOSRC ; YES--ERROR MOVEI DA,LSTDEV PUSHJ PP,GETFIL ; GET SECOND FILE CAIE CH,"-" ; NULL FILE? JRST SETLSB ; NO-- SWON FNOLST ; YES--SAY NO LISTING FILE PUSHJ PP,COMKAR ; GET ANOTHER CHARACTER CAIE CH,"=" JRST TUMANY SETLSA: MOVSI TA,'DSK' ; NO DEVICE--USE DISK MOVEM TA,LSTDEV ; SET LISTING DEVICE JRST SETSRC ; IT MUST BE LEGAL SETLSB: JUMPE TA,SETLSA TLNN TA,$OUT ; OUTPUT DEVICE? JRST BADOUT ; NOPE--ERROR ;SET UP SOURCE DEVICE SETSRC: CAIN CH,15 ; END OF COMMAND STRING? JRST NOSRC ; YES--ERROR CAIE CH,"=" ; ANY MORE OUTPUT TYPE FILES? JRST TUMANY ; YESS--ANOTHER ERROR PUSHJ PP,SCNCOM ; SCAN ALL SOURCE FILES PUSHJ PP,STINFL ; SET UP FIRST SOURCE FILE TSWTZ FHELP ; /H? JRST SETSR1 ; NO-- HELP: MOVE 1,[SIXBIT "RPGII"] ; YES--PRINT RPGII.HLP PUSHJ PP,.HELPR JRST BADC2 ; IGNORE ALL ELSE IN COMMAND STRING SETSR1: SKIPN SRCDEV ; ANY FILE THERE? JRST NOSRC ; NO--ERROR ;FILE NAMES HAVE ALL BEEN READ - FINISH UP MOVE TA,SRCDEV+1 SKIPN LSTDEV+1 ; ANY LIST FILE-NAME? MOVEM TA,LSTDEV+1 ; NO--JAM SOURCE NAME SKIPN BINDEV+1 ; ANY BINARY FILENAME? MOVEM TA,BINDEV+1 ; NO--JAM SOURCE NAME MOVSI TA,'REL' SKIPN BINDEV+2 ; ANY BINARY EXTENSION? MOVEM TA,BINDEV+2 ; NO--USE "REL" MOVSI TA,'LST' SKIPN LSTDEV+2 ; ANY LISTING EXTENSION? MOVEM TA,LSTDEV+2 ; NO--USE "LST" ;INITIALIZE BINARY DEVICE INITB: MOVEI I1,14 MOVEI DA,BINDEV MOVEI DC,BIN SKIPN BINDEV ; ANY BINARY FILE? JRST INITL ; NO-- PUSHJ PP,OPNOUT MOVE TA,BINSWS ; REWIND? TRNE TA,2 MTAPE BIN,$REW TRNE TA,4 ; CLEAR DIRECTORY? UTPCLR BIN, SETOM BINBLK ;INITIALIZE LISTING DEVICE INITL: MOVEI I1,0 MOVEI DA,LSTDEV MOVEI DC,LST TSWF FNOLST; ; ANY LISTING DEVICE? JRST INITS ; NO-- MOVE TA,LSTDEV ; YES--TTY:? DEVCHR TA, TLNE TA,$AVAIL TLNN TA,$CONSL JRST INITL1 ; NO-- SWON FLTTY; ; YES-- INITL1: PUSHJ PP,OPNOUT MOVE TA,.JBFF MOVEM TA,LSTBUF OUTBUF LST,2 MOVE TA,LSTSWS ; REWIND? TRNE TA,2 MTAPE LST,$REW TRNE TA,4 ; CLEAR DIRECTORY? UTPCLR LST, SETOM LSTBLK ;INITIALIZE SCRATCH FILES INITS: TSWF FNOLST ; IF NO LISTING SETZM CREFSW ; CLEAR "/C" PJOB TC, ; GET JOB NUMBER INTO LH OF TA, DECIMAL MOVEI TD,3 IDIVI TC,^D10 ADDI TB,"0"-40 LSHC TB,-6 SOJG TD,.-3 MOVE TB,DEVXWD OPNSCR: MOVE DA,DEVTAB(TB) MOVSI TC,'DSK' ; SCRATCH DEVICE MOVEM TC,DEVDEV(DA) HLR TA,DEVTAB(TB) ; CREATE A FILENAME MOVEM TA,DEVFIL(DA) MOVSI TC,'TMP' ; SCRATCH FILE EXTENSION MOVEM TC,DEVEXT(DA) MOVEI DC,FSC(TB) ; SET CHANNEL NUMBER CAIE DC,CRF ; IF THIS IS THE CREF FILE JRST OPNSC0 ; AND THERE IS NO "/C" SKIPN CREFSW ; DON'T OPEN THE CREF FILE JRST OPNSC1 OPNSC0: MOVEI I3,DEVBHI(DA) HRLI I3,3(I3) MOVEI I4,0 MOVEI I1,14 ; USUALLY IS BINARY MODE CAIE DC,CAL ; CALFIL? CAIN DC,CPY ; OR CPYFIL? MOVEI I1,0 ; YES--ASCII MODE CAIE DC,NAM ; NAMFIL? CAIN DC,LIT ; OR LITFIL? MOVEI I1,17 ; YES--DUMP MODE PUSHJ PP,OPNTMP SETOM DEVBLK(DA) ; SET BLOCK COUNT TO -1 CAIE DC,LIT ; LITFIL? CAIN DC,AS3 ; AS3FIL? JRST OPNSC1 ; YES--NO BUFFER RIGHT NOW CAIN DC,NAM ; DO THE SAME FOR JRST OPNSC1 ; NAMFIL HRRZ I0,.JBFF ; NO--SET BUFFER ADDRESS MOVEM I0,DEVBUF(DA) MOVE I0,OUTBOP DPB DC,I0CHAN XCT I0 ; DO AN OUTBUF OPNSC1: AOBJN TB,OPNSCR MOVE TA,SRCBUF ; AS3 OVERLAYS SRCFIL MOVEM TA,AS3BUF MOVE TA,GENBUF ; BINFIL OVERLAYS GENFIL MOVEM TA,BINBUF ;SET UP ALL WORK AREAS EXCEPT NAMTAB SETWRK: HRRZ TA,.JBFF MOVEM TA,FREESP MOVE TA,WRKXWD STWRK1: MOVE TB,(TA) MOVE TC,TB HRR TC,FREESP MOVEM TC,(TB) MOVEM TC,1(TB) HLRE TC,TB MOVMS TC ADDI TC,1 ADDB TC,FREESP STWRK3: CAMG TC,TOPLOC JRST STWRK2 PUSHJ PP,ADDCOR MOVE TC,FREESP JRST STWRK3 STWRK2: AOBJN TA,STWRK1 JRST SETNAM ;SET UP INITIAL ENTRIES IN NAMTAB ;ENTER AT SETNAM PUSHJ PP,ADDCOR ; GRAB ANOTHER K OF CORE SETNAM: MOVE TA,TOPLOC ; ROOM FOR SUBI TA,NAMPSZ+1 ; NAMTAB SUB TA,NTSIZE ; + NM1TAB SUB TA,NTSIZE ; + NM2TAB ? CAMGE TA,FREESP JRST SETNAM-1 ; NO - GRAB SOME MORE ROOM MOVE TE,[XWD NTSIZE,SIZTAB] MOVNI TD,NTNSIZ BLT TE,SIZTAB-1(TD) MOVE TE,NTSIZE MOVEM TE,NM12SZ MOVE TE,[XWD NTNSIZ,SIZTAB] MOVEM TE,NSZPTR HRLI TA,TC MOVEM TA,NM1LOC MOVSI TE,(TA) HRRI TE,1(TA) SETOM (TA) ADD TA,NM12SZ BLT TE,-1(TA) MOVEM TA,NM2LOC MOVSI TE,(TA) HRRI TE,1(TA) SETZM (TA) ADD TA,NM12SZ BLT TE,-1(TA) HRLI TA,NAMNSZ-1 MOVEM TA,NAMLOC MOVEM TA,NAMNXT HRRZ TA,NM1LOC ; RESET LEFT HALF OF FREESP SUB TA,FREESP HRLM TA,FREESP ;SET UP INITIAL ENTRIES IN EXTAB SETEXT: SETZM NAMWRD+1 ; CLEAR NAMWRD'S LAST 4 LOC'S MOVE TA,[XWD NAMWRD+1,NAMWRD+2] BLT TA,NAMWRD+4 MOVS TE,EXTLOC ; CLEAR EXTAB HRR TE,EXTLOC+3 SUBI TE,1 PUSHJ PP,CLRSOM MOVE LN,EXTPTR ; GET TABLE POINTER SETEX1: MOVE TA,[POINT 6,(LN)] MOVE TB,[POINT 6,NAMWRD] SETX1A: ILDB CH,TA CAIN CH,"."-40 MOVEI CH,";"-40 ; REPLACE SIXBIT PERIODS WITH SIXBIT SEMI'S IDPB CH,TB ; STORE IT AGAIN TLNE TA,770000 JRST SETX1A PUSHJ PP,TRYNAM ; IS IT IN NAMTAB ALREADY? JRST SETEX2 ; NO - JRST DBLNAM ; YES - ERROR SETEX2: PUSHJ PP,BLDNAM ; ADD IT TO NAMTAB SETEX3: MOVE TB,EXTNXT AOBJP TB,SETEX4 ; ROOM FOR FIRST WORD? TLO TA,500000 ; YES - PUT NAMTAB CHAIN IN EXTAB HLLZM TA,(TB) HRRZI TD,(TB) ; SET UP EXTAB LINK HRRZ TE,EXTLOC SUBI TD,(TE) IORI TD,B20 AOBJP TB,SETEX4 ; ROOM FOR SECOND WORD? SETZM (TB) ; YES - ZERO IT MOVEM TB,EXTNXT ; RESTORE EXTNXT AOBJN LN,SETEX1 ; ANYMORE ENTRIES? JRST FINISH ; NO - SETEX4: PUSH PP,TA ; EXPAND EXTAB PUSHJ PP,XPNEXT POP PP,TA JRST SETEX3 ;FINISH UP PHASE A FINISH: HLLZS SW ; CLEAR RH OF SWITCHES IFN DEBUG, TSWF FNOLST ; IF NO LISTING, SWOFF FOBJEC!FMAP ; THEN NO MAPS OR ASSEMBLY LISTING TSWF FNOLST ; IF NO LISTING SETZM LSTDEV ; CLEAR DEVICE NAME TSWF FLTTY ; IF LISTING ON TTY SWOFF FTERA ; WE DON'T TYPE ERRORS TWICE ENDFAZ A; ;SCAN REMAINDER OF SOURCE FILES IN COMMAND STRING SCNCOM: MOVSI DA,(SIXBIT "DSK") MOVEM DA,LASTDV MOVEI DA,IOSRCS ; SET SRCEND & DA MOVEM DA,SRCEND SCNCM1: TSWF FESRC ; ANY MORE SOURCE FILES? JRST SCNCM5 ; NO-- PUSHJ PP,GETFIL ; YES--GET NEXT ONE JUMPN TA,SCNCM3 ; JUMP IF DEVICE FOUND SKIPN DEVFIL(DA) ; NO DEVICE - ANY FILE? SKIPE DEVEXT(DA) JRST SCNCM2 ; YES-- JRST SCNCM6 ; NO--ERROR SCNCM2: MOVE TA,LASTDV MOVEM TA,DEVDEV(DA) DEVCHR TA, SCNCM3: PUSHJ PP,CHEKIN ; CHECK VALIDITY OF FILE ADDI DA,DEVSZ ; [316] BOP UP TO NEXT ENTRY MOVEM DA,SRCEND CAIE DA,SRCEND ; TABLES FULL? JRST SCNCM1 ; NO-- LOOP TSWT FESRC ; YES--ANY MORE SOURCES? JRST NOROOM ; YES--ERROR SCNCM5: MOVEI TA,IOSRCS ; RESET SRCEND MOVEM TA,SRCEND POPJ PP, SCNCM6: CAIN CH,15 ; END OF LINE? CAIE DA,IOSRCS ; YES--ANY SOURCE FILES? JRST SCNCM2 ; YES JRST NOSRC ; NO-ERROR ;OPEN UP OUTPUT DEVICE ;ENTER WITH DA POINTING TO A FILE ENTRY SET UP BY GETFIL OPNOUT: MOVSI I3,DEVBH(DA) ; ENTRY FOR BIN, LST MOVE I4,DEVPP(DA) OPNTMP: PUSHJ PP,OPENIT ; OPEN AND SET UP ENTER CAIN DC,LIT ; DON'T ENTER IF IT IS POPJ PP, ; LITFIL MOVE I0,ENTROP ; CREATE AN ENTER DPB DC,I0CHAN XCT I0 ; ENTER.... JRST NOENTR ; COULDN'T - POPJ PP, ;CHECK VALIDITY OF SOURCE FILE. ;ENTER WITH CHARACTERISTICS IN TA CHEKIN: TLNN TA,$IN ; INPUT DEVICE? JRST NOTIN ; NO - ERROR TLNE TA,$DIREC ; DIRECTORY DEVICE? SKIPE DEVFIL(DA) ; YES - ANY FILE NAME? SKIPA JRST NOFILE ; NO - ERROR POPJ PP, ;SET UP TO GET COMMANDS FROM DISK COMDSK: MOVEM 7,RUNPPN ; SAVE DEV AND PPN OF RUN COMMAND MOVEM 11,RUNDEV MOVSI SW,FDSKC/1000000 ; CLEAR FLAGS - SET "COMMANDS FROM DISK" RESET MOVSI TA,(SIXBIT "RPG") ; SET UP FIRST MOVEM TA,COMBH+1 ; WORD FOR TMPCOR UUO MOVE TA,.JBFF ; SET UP SUBI TA,1 ; SECOND HRLI TA,-200 ; WORD MOVEM TA,COMBH+2 ; FOR TMPCOR UUO MOVE TA,[XWD 1,COMBH+1] ; GET FILE IN TMPCOR TA, ; CORE JRST CMDSK5 ; WAS NONE - TRY DISK MOVE TB,.JBFF ; SET UP HRLI TB,(POINT 7,0) ; BYTE POINTER TO MOVEM TB,COMBH+1 ; COMMAND ADDM TA,.JBFF ; UPDATE .JBFF WITH SIZE OF INPUT IMULI TA,5 ; CALCULATE ADDI TA,1 ; NUMBER OF CHARACTERS + 1 MOVEM TA,COMBH+2 ; STASH THAT SETZM COMBH ; CLEAR COMBH TO INDICATE TMPCOR JRST CMDSK9 ; RETURN CMDSK5: INIT COM,0 SIXBIT /DSK/ XWD 0,COMBH JRST RPGIIA ; NO DSK - USE TTY: MOVEI I1,(SIXBIT "RPG") ; SET LOOKUP PARAMETERS MOVSI I2,(SIXBIT "TMP") SETZB I3,I4 HLRZM I2,COMEXT PJOB TC, ; PUT IN JOB NUMBER MOVEI I0,3 IDIVI TC,^D10 ADDI TB,"0"-40 LSHC TB,-6 SOJG I0,.-3 HLL I1,TA INBUF COM,1 ; GET A SINGLE BUFFER MOVE I0,LOOKOP ; LOOKUP "JJJRPG.TMP" MOVEI DC,COM DPB DC,I0CHAN XCT I0 JRST RPGIIA ; NOT FOUND - USE TTY: CMDSK9: MOVE TE,.JBFF MOVEM TE,SAVJFF JRST RPGLAS ;SETIMP SET UP IMPURE AREA ; ; ; SETIMP: MOVE TA,[XWD %WEDID,WEDIED] ; MOVE "GETSEG" ROUTINE TO LOW-SEGMENT IFN DEBUG,< BLT TA,-1+DDTSTP## MOVE TA,[XWD %GTFNM,GETFNM] > BLT TA,GETEND IFE ONESEG,< MOVE TA,RUNPPN ; GETSEG WILL USE DEV AND PPN MOVEM TA,GETFNM+4 ; OF RUN COMMAND MOVE TA,RUNDEV MOVEM TA,GETFNM > SETI2: MOVE TB,[XWD FSTCLR,FSTCLR+1] SETZM FSTCLR IFN %CPU-%20,< HLRZ TE,.JBSA > IFE %CPU-%20,< HRRZ TE,.JBSYM > IFN DEBUG,< IFN %CPU-%20,< MOVEI TD,(TB) CAIG TD,DDT## MOVEI TE,DDT >> BLT TB,-1(TE) HRLZ TE,.JBFF ; get start of free core HRR TE,.JBREL ; get the end PUSHJ PP,CLRSOM ; and zero it all HRRZ TE,.JBSYM ; IF SYMBOLS TRNE TE,1B18 ; ARE IN HI-SEG, TDCA TE,TE ; USE ZERO LENGTH, HLRE TE,.JBSYM ; ELSE USE LENGTH OF SYMBOL TABLE MOVMS TE IFN DEBUG,< IFN %CPU-%20,< ADDI TE,^D50+DDTEND## ; LEAVE ROOM FOR DDT SUBI TE,DDT >> ADDI TE,-1+WRKSIZ PJRST SETCOR ;CLEAR SOME CORE ;ENTER WITH FIRST ADDRESS IN LH OF "TE", LAST ADDRESS IN RH OF "TE" CLRSOM: HLRZ TD,TE SETZM (TD) HLL TD,TE ADDI TD,1 BLT TD,(TE) POPJ PP, ;MOVE SYMBOLS DOWN BELOW .JBFF, IF WE ARE DEBUGGING IFN DEBUG,< MOVSYM: HLRE TC,.JBSYM JUMPGE TC,MOVSY2 MOVMS TC HRRZ TE,.JBSYM ; IF SYMBOLS ARE IN HI-SEG, TRNE TE,1B18 POPJ PP, ; FORGET IT - HRRZ TD,.JBFF ; SYMBOLS WILL BE ADDI TD,^D50 ; MOVED TO THIS LOC CAIL TD,(TE) ; UNLESS THAT MOVES JRST MOVSY1 ; THEM UP INSTEAD OF DOWN HRRM TD,.JBSYM ; RESET .JBSYM HRLI TD,(TE) ; TO ADDI TC,(TD) ; SET TC TO FIRST LOC AFTER SYMBOLS BLT TD,-1(TC) ; BLIIIIIIIIT THOSE SYMBOLS... MOVSY1: HLRE TE,.JBSYM ; RESET MOVMS TE ; JOFF ADD TE,.JBSYM ; TO BE HRRM TE,.JBFF ; AFTER SYMBOLS MOVSY2: POPJ PP, > ;GET CURRENT DATE AND TIME GETDT: DATE TC, ; GET DATE FROM SYSTEM IDIVI TC,^D31 ; TB_(DAY-1) PUSHJ PP,DECONV ; CONVERT TO TWO DECIAML DIGITS DPB TB,[POINT 14,STDATE,13] IDIVI TC,^D12 ; TB_(MONTH-1) MOVE TB,MOTABL(TB) ; CONVERT TO ASCII MONTH LSHC TB,-16 IORM TB,STDATE LSHC TB,-1 MOVEM TA,STDATE+1 MOVEI TB,^D63(TC) ;TB_(YEAR-1) CAIL TB,^D100-1 ; CHECK FOR YEAR 2000+ SUBI TB,^D100 ; IF SO, CHANGE TO 00+ PUSHJ PP,DECONV DPB TB,[POINT 14,STDATE+1,27] MSTIME TC, ; GET TIME OF DAY IDIVI TC,^D1000*^D60 ; CONVERT TO MINUTES IDIVI TC,^D60 ; TB_MINUTES, TC_HOURS PUSHJ PP,DECONV+1 LSH TB,1 IOR TB,[ASCII " :"] MOVEM TB,STTIME MOVE TB,TC PUSHJ PP,DECONV+1 DPB TB,[POINT 14,STTIME,13] POPJ PP, ;CONVERT A NUMBER TO DECIMAL DECONV: ADDI TB,1 ; ADD 1 TO IT IDIVI TB,^D10 ; TA_UNITS, TB_TENS LSH TB,7 ADDI TB,14060(TA) ; CONVERT TO ASCII POPJ PP, ;SET UP VERSION NUMBER GETVER: SETZM VERZUN SETZM VERZUN+1 SETZM VERZUN+2 MOVE TC,[POINT 6,VERZUN] LDB TE,[POINT 9,.JBVER,11] ; GET VERSION NUMBER SKIPE TE ; IF NON-ZERO, PUSHJ PP,GTVER8 ; PRINT IT LDB TE,[POINT 6,.JBVER,17] ; GET MINOR VERSION NUMBER JUMPE TE,GTVER4 ; IF ZERO, NO LETTER CAIG TE,^D26 ; IF LESS THAN 27, SOJA TE,GTVER3 ; IT IS A SINGLE LETTER MOVEI CH,"A"-40 ; IT IS A DOUBLE LETTER MOVEI TE,-1(TE) GTVER1: SUBI TE,^D26 CAILE TE,^D25 AOJA CH,GTVER1 GTVER2: IDPB CH,TC GTVER3: ADDI TE,"A"-40 IDPB TE,TC GTVER4: HRRZ TE,.JBVER ; GET PATCH NUMBER JUMPE TE,GTVER5 ; IF ZERO DON'T PRINT IT MOVEI CH,"("-40 IDPB CH,TC PUSHJ PP,GTVER8 MOVEI CH,")"-40 IDPB CH,TC GTVER5: LDB TE,[POINT 3,.JBVER,2] ; GET EDITOR JUMPE TE,GTVER9 ; IF MAYNARD CRAZIES, DON'T PRINT IT MOVEI CH,"-"-40 IDPB CH,TC GTVER8: LDB TD,[POINT 3,TE,35] HRLM TD,(PP) LSH TE,-3 SKIPE TE PUSHJ PP,GTVER8 HLRZ TE,(PP) ADDI TE,"0"-40 IDPB TE,TC GTVER9: POPJ PP, ;GET IN "DEV:FILE.EXT[PROJ,PROG]/X" GETFIL: MOVEI TA,1(DA) HRLI TA,(DA) SETZM (DA) BLT TA,DEVSZ-1(DA) ; [316] TSWFZ FCOMWD; ; DEVICE WAITING? JRST GETFL6 ; YUP - GETFL1: PUSHJ PP,GETSIX ; NO - GET ONE CAIN CH,":" ; ":"? JRST GETFL7 ; SHO 'NUF GETFL2: CAIE CH,"=" ;"="? CAIN CH,"," ;","? JRST GTFL4A ; YA CAIN CH,"." ; "."? JRST GETFL5 ; YES CAIN CH,"[" ; "["? JRST GETFL8 ; YES CAIN CH,15 ; END OF COMMAND? JRST GETFL4 ; YES CAIN CH,"/" ; SWITCH? JRST GETFL9 ; YES-- CAIN CH,"-" ; NULL FILE? JRST GTFL8C ; YES CAIN CH,"(" ; MULTI SWITCH? JRST GTFL13 ; YES CAIN CH,"@" ; INDIRECT? JRST GTFL12 ; YES-- CAIN CH,"!" ; CUSP CALL? JRST GTFL14 ; YES CAIE CH," " ; SPACE? JRST BADKAR ; NO--BAD CHARACTER PUSHJ PP,COMKAR ; YES--GET NEXT CHARACTER GTFL2A: CAIN CH," " ; ANOTHER SPACE? JRST .-2 ; YES - LOOP BACK AND SAVE SOME TIME CAIG CH,"Z" ; NO-LETTER? CAIGE CH,"A" SKIPA JRST GETFL3 ; YES - TREAT LIKE A COMMA CAIG CH,"9" ; NOT A LETTER - DIGIT? CAIGE CH,"0" JRST GETFL2 ; NO - TRY PUNCTUATION GETFL3: MOVEI CH,"," ; LETTER OF DIGIT - TREAT LIKE COMMA SWON FCOMCH; ; SET "REGET CHARACTER" JRST GTFL4A ;STASH FILE-NAME AND LEAVE GETFL4: SWON FESRC; ; END OF COMMAND STRING GTFL4A: PUSHJ PP,GTFL4B SKIPN TA,DEVDEV(DA) ; ANY DEVICE? POPJ PP, ; NO - RETURN DEVCHR TA, ; YES - GET CHARACTERISTICS JUMPE TA,NOTDEV ; IS IT A LEGAL DEVICE? POPJ PP, GTFL4B: JUMPE TA,GTFL4C SKIPE DEVFIL(DA) JRST BADSTR MOVEM TA,DEVFIL(DA) GTFL4C: POPJ PP, ;DOT - STASH FILE NAME, GET EXTENSION GETFL5: SKIPE DEVEXT(DA) JRST BADSTR PUSHJ PP,GTFL4B PUSHJ PP,GETSIX HLLZM TA,DEVEXT(DA) MOVEI TA,0 JRST GETFL2 ;GET PREVIOUS DEVICE GETFL6: SKIPA TA,LASTDV ;GET PREVIOUS DEVICE ;COLON - STASH DEVICE NAME GETFL7: MOVEM TA,LASTDV ; STASH AS LAST DEVICE SKIPE DEVDEV(DA) ; IS THERE ONE ALREADY? JRST GTFL7A ; YES MOVEM TA,DEVDEV(DA) ; NO - STASH IN DEVICE ENTRY JRST GETFL1 GTFL7A: SWON FCOMWD; ; YES - GET "REGET WORD" POPJ PP, ;BRACKET - GET PROJ,PROG GETFL8: PUSHJ PP,GTFL4B PUSHJ PP,GETNUM ; GET PROJ CAIE CH,"," ; COMMA SEPERATOR? JRST BADPPN ; NO - ERROR MOVSM TA,DEVPP(DA) ; YES - STASH PUSHJ PP,GETNUM ; GET PROG HRRM TA,DEVPP(DA) ; STASH CAIE CH,"]" ; "]" TERMINATOR? JRST BADPPN ; NO - ERROR JRST GETFL1 ;HYPHEN - IT SHOULD BE ALONE GTFL8C: JUMPN TA,BADKAR SKIPN DEVDEV(DA) SKIPE DEVFIL(DA) JRST BADKAR SKIPN DEVPP(DA) SKIPE DEVEXT(DA) JRST BADKAR POPJ PP, ;SWITCH (/ TYPE) GETFL9: PUSHJ PP,GTFL4B PUSHJ PP,COMKAR PUSHJ PP,SWICH GTFL10: MOVEI TA,0 SKIPE DEVDEV(DA) JRST GTFL11 SKIPN DEVFIL(DA) ; IS THERE ANY FILE? SKIPE DEVEXT(DA) SKIPA JRST GETFL1 ; NO - LOOP GTFL11: PUSHJ PP,COMKAR ; YES - GET NEXT CHARACTER JRST GTFL2A ;"@" SEEN - SET UP INDIRECT COMMAND FILE GTFL12: PUSHJ PP,GTFL4B ; STASH FILE NAME SKIPN DEVDEV(DA) ; ANY ENTRY? SKIPE DEVFIL(DA) JRST GTF12A ; YES SKIPN DEVPP(DA) ; NOT YET - TRY SOME MORE SKIPE DEVEXT(DA) JRST GTF12B ; YES - PUSHJ PP,GETFIL ; NO - SCAN SOME MORE JRST GTF12B GTF12A: PUSHJ PP,COMKAR GTF12B: CAIE CH,15 JRST BADSTR RESET SKIPN I2,DEVDEV(DA) MOVSI I2,(SIXBIT "DSK") MOVEI I1,0 MOVEI I3,COMBH OPEN COM,I1 JRST NOCOMD SKIPE I1,DEVFIL(DA) JRST GTF12D MOVEI I2,3 PJOB I3, IDIVI I3,^D10 MOVEI I0,"0"-40(I4) LSHC I0,-6 SOJG I2,.-3 HRRI I1,(SIXBIT "RPG") GTF12D: HLLZ I2,DEVEXT(DA) GTF12E: MOVEI I3,0 MOVE I4,DEVPP(DA) JUMPE I2,GTF12H GTF12F: LOOKUP COM,I1 JRST NOCOMF GTF12G: HLRZM I2,COMEXT INBUF COM,1 MOVE TE,.JBFF MOVEM TE,SAVJFF MOVSI SW,FDSKC/1000000 JRST GETFIL GTF12H: MOVSI I2,(SIXBIT "CCL") LOOKUP COM,I1 SKIPA JRST GTF12G MOVEI I2,0 MOVE I4,DEVPP(DA) JRST GTF12F ;SWITCH ( ( TYPE ) GTFL13: PUSHJ PP,GTFL4B PUSHJ PP,COMKAR GTF13A: PUSHJ PP,SWICH PUSHJ PP,COMKAR CAIE CH,")" JRST GTF13A JRST GTFL10 ;"!" SEEN - CALL CUSP GTFL14: MOVSI TE,(SIXBIT "SYS") MOVE TD,TA SETZB TC,TB SETZB TA,PP MOVE CH,[XWD 1,TE] ; [303] [373] enter at CCL entry point RUN CH, JRST 4., MSG EXIT ;DETERMINE TYPE OF SWITCH SWICH: CAIN CH,"S" JRST SWICHS CAIN CH,"M" JRST SWICHM CAIN CH,"L" JRST SWICHL CAIN CH,"A" JRST SWICHA CAIN CH,"E" JRST SWICHE CAIN CH,"H" JRST SWICHH CAIN CH,"C" JRST SWICHC CAIN CH,"Z" JRST SWICHZ CAIN CH,"W" JRST SWICHW CAIN CH,"R" JRST SWICHR CAIN CH,"N" JRST SWICHN CAIN CH,"P" JRST SWICHP JRST BADCSW ; ILLEGAL SWITCH ;SWITCH HANDLEING ROUTINES SWICHP: SETOM PRODSW ; SET '/P' POPJ PP, IFN CREF,< SWICHC: SETOM CREFSW ; SET '/C' POPJ PP,> IFE CREF,< SWICHC: MSG < ?RPGCNS CREF not supported this version > JRST BADC1 > SWICHE: SWON FFATAL ; TURN ON '/E' POPJ PP, SWICHH: SWON FHELP ; TURN ON '/H' POPJ PP, SWICHS: SWON FSEQ ; TURN ON '/S' POPJ PP, IFN MAPS,< SWICHM: SWON FMAP ; TURN ON '/M' POPJ PP, > IFE MAPS,< SWICHM: MSG < ?RPGMNS Maps not supported this version > JRST BADC1 > SWICHL: MOVEI TA,1 ; SET 'L' FLAG IN TABLE JRST SWZWL SWICHA: SWON FOBJEC ; TURN ON '/A' POPJ PP, SWICHZ: MOVEI TA,4 ; SET 'Z' FLAG IN TABLE JRST SWZWL IFN REENT,< SWICHR: SWON FREENT ; TURN ON '/R' POPJ PP, > IFE REENT,< SWICHR: MSG < ?RPGRNS Reentrant code not supported this version > JRST BADC1 > SWICHN: SWOFF FTERA ; TURN OFF "WE'RE TYPING ERRORS" POPJ PP, SWICHW: MOVEI TA,DEVSW(DA) ; SET 'W' FLAG IN TABLE SWZWL: IORM TA,DEVSW(DA) POPJ PP, ;PICK UP A SIXBIT WORD FROM COMMAND STRING GETSIX: MOVEI TA,0 MOVE TB,[POINT 6,TA] GETSX1: PUSHJ PP,COMKAR ; NO GET NEXT GETSX2: CAIG CH,"Z" ; LETTER? CAIGE CH,"A" JRST GETSX4 ; NO -- GETSX3: TLNN TB,770000 JRST BADNAM SUBI CH,40 ; YES--STASH IT IDPB CH,TB JRST GETSX1 GETSX4: CAIG CH,"9" ; NOT A LETTER - A DIGIT? CAIGE CH,"0" POPJ PP, ; NO - RETURN JRST GETSX3 ; YES - STASH IT ;PICK UP AN OCTAL NUMBER GETNUM: MOVEI TA,0 ; CLEAR THE SUMMER PUSHJ PP,COMKAR ; GET FIRST CHARACTER CAIN CH," " ; SPACE? JRST .-2 ; YES - SO IGNORE IT ALREADY GETNM1: CAIG CH,"7" ; OCTAL DIGIT? CAIGE CH,"0" JRST GETNM2 ; NO - LSH TA,3 ; YES ADD TO SUM IORI TA,-"0"(CH) TLNE TA,-1 ; SUM > 777777 ? JRST BADPPN ; YES - NOT SO GOOD PUSHJ PP,COMKAR ; NO - GET ANOTHER DIGIT JRST GETNM1 ; LOOP ON THRU GETNM2: JUMPE TA,BADPPN ; SUM = 0? POPJ PP, ; NO - SO RETURN ;GET A CHARACTER FROM COMMAND STRING COMKAR: TSWFZ FCOMCH ; REGET SAME CHARACTER JRST COMKR6 ; YES - COMKR0: SOSG COMBH+2 ; GET CHARACTER FROM DISK OR TMPCOR JRST COMKR2 COMKR1: ILDB CH,COMBH+1 JUMPE CH,COMKAR ; IGNORE NULLS CAIN CH,15 ; IGNORE CARRIAGE RETURNS JRST COMKAR CAIG CH,172 ; BETWEEN LC Z AND LC A ? CAIGE CH,141 CAIA ; NOT LC SUBI CH,40 ; YES - CONVERT TO UPPER CASE DPB CH,COMBH+1 ; [303] store new character CAIE CH,175 ; SOME KIND OF ALTMODE? CAIN CH,176 JRST COMKR9 ; YES - CAIE CH,32 ; END-OF-FILE? CAIN CH,33 ; STILL ANOTHER KIND OF ALTMODE? JRST COMKR9 ; YES - IS ALT CAIE CH,12 CAIN CH,14 JRST COMK99 CAIE CH,"_" ; IS IT "_" ? POPJ PP, ; NO - RETURN MOVEI CH,"=" ; YES, CHANGE TO "=" DPB CH,COMBH+1 ; STASH BACK INTO BUFFER FOR NEXT TIME (IF ANY) POPJ PP, ;GET NEXT BUFFER FULL OF COMMANDS COMKR2: SKIPN COMBH ; FROM TMPCOR? JRST COMK2B ; YES - NO MORE IN COM, ; GET NEXT BUFFER FULL JRST COMKR1 ; NO ERRORS - RETURN GETSTS COM,CH ; ERROR - GET DEVICE STATUS TRNE CH,$ERAS ; ANY ERROR FLAGS UP? JRST COMKR8 ; YES - YOU LOSE! CLOSE COM, ; NO - CLOSE COMMAND FILE MOVE CH,COMEXT ; IS EXTENSION "TMP"? CAIE CH,(SIXBIT "TMP") JRST COMK2A ; NO - DON'T DELETE MOVEI CH,0 ; DELETE COMMAND FILE RENAME COM,CH JFCL COMK2A: RELEASE COM, ; RELEASE IT JRST COMKR3 ;GET RID OF TMPCOR AREA COMK2B: MOVSI CH,(SIXBIT "RPG") MOVEM CH,COMBH+1 MOVS CH,.JBSA SUBI CH,1 HRLI CH,-200 MOVEM CH,COMBH+2 MOVE CH,[XWD 2,COMBH+1] TMPCOR CH, JFCL ;END OF COMMAND FILE COMKR3: SWON FECOM ; TURN ON "END OF COMMAND" COMKR4: MOVEI CH,15 ; RETURN A CARRIAGE RETURN POPJ PP, ;REGET SAME CHARACTER COMKR6: LDB CH,COMBH+1 ; FROM DISK OR TMPCR POPJ PP, ;READ ERROR COMKR8: MSG EXIT ;AN ALTMODE WAS SEEN COMKR9: PUSHJ PP,COMK99 JRST COMKR3 ;TYPE OUT A CRLF IN INPUT FROM TTY COMK99: TSWT FDSKC; MSG < > JRST COMKR4 ;ERROR ROUTINES ;"DSK" IS NOT THE DISK NOTDSK: MSG EXIT ;TOO MANY OUTPUT FILES TUMANY: MOVEI TB,[ASCIZ "?RPGIRC Improper RPGII command"] JRST BADCOM ;BINARY DEVICE CANNOT DO BINARY BADBIN: MOVEI TB,[ASCIZ ": cannot do binary output"] MOVE TA,[SIXBIT "RPGCDB"] JRST TYPEIT ;OUTPUT DEVICE CANNOT DO OUTPUT BADOUT: MOVEI TB,[ASCIZ ": cannot do output"] MOVE TA,[SIXBIT "RPGCDO"] JRST TYPEIT ;SOURCE FILE IS NOT AN INPUT DEVICE NOTIN: MOVEI TB,[ASCIZ ": cannot do input"] MOVE TA,[SIXBIT "RPGCDI"] TYPEIT: MSG ; PUSHJ PP,SIXOUT ; OUTPUT RPGxxx MSG < >; ; A SPACE MOVE TA,DEVDEV(DA) PUSHJ PP,SIXOUT JRST BADCOM ;MORE ERROR ROUTINES ;SOMETHING A BIT ODD ABOUT STRING BADSTR: MOVEI TB,[ASCIZ "?RPGIRC improper RPGII command"] JRST BADCOM ;COMMAND DEVICE IS UNAVAILABLE NOCOMD: MOVEI [ASCIZ "?RPGCDU Indirect command device unavailable"] JRST BADCOM ;COMMAND FILE CANNOT BE FOUND NOCOMF: MOVEI TB,[ASCIZ "?RPGCFC Cannot find command file"] JRST BADCOM ;NAME TOO LONG BADNAM: MOVEI TB,[ASCIZ "?RPGNMS Name of more than six characters"] JRST BADCOM ; [267] type error message ;BAD PPN BADPPN: MOVEI TB,[ASCIZ "?RPGIPP Improper Project-Programmer Number"] JRST BADCOM ;IMPROPER CHARACTER IN STRING BADKAR: MOVEI TB,[ASCIZ "?RPGICC Improper character in command"] JRST BADCOM ;BAD SWITCH BADCSW: MSG ; CHROUT CH MOVEI TB,[ASCIZ " is not a legal switch"] JRST BADCOM ;ERROR WHILE INITIALIZING THE DEVICE ;NOT A LEGAL DEVICE NOTDEV: MOVEI TB,[ASCIZ ": is not a legal device"] MSG ; MOVE TA,DEVDEV(DA) PUSHJ PP,SIXOUT JRST BADCOM ;STILL MORE ERROR ROUTINES ;NO FILE FOR DIRECTORY DEVICE NOFILE: MSG ; MOVE TA,DEVDEV(DA) ; GET DEVICE PUSHJ PP,SIXOUT ; OUTPUT IT MSG <: >; ; BE NEAT JRST BADC1 ; GO FINISH ;TOO MANY SOURCE FILES NOROOM: MOVEI TB,[ASCIZ "?RPGTMS Too many source files"] JRST BADCOM ;NO SOURCE FILES AT ALL NOSRC: TSWFZ FHELP ; IS /H ON? JRST HELP ; YES - OK MOVEI TB,[ASCIZ "?RPGNSF No source files specified"] ;TYPE OUT MESSAGES AND RESTART COMPILATION BADCOM: OUTSTR (TB) BADC0: MSG < > BADC1: TSWF FESRC!FECOM ; END OF COMMAND STRING? JRST BADC2 ; YES PUSHJ PP,COMKAR ; NO - GET CHARACTER CAIE CH,15 ; CARRIAGE RETURN? JRST BADC1 ; NO - LOOP BADC2: TSWT FDSKC ; COMMANDS FROM TTY? JRST RPGIIA ; YES - AND SW,[EXP FDSKC] ; NO - CLEAR ALL SWITCHES EXCEPT FDSKC JRST RPGLAS ;AND EVEN MORE ERROR ROUTINES DBLNAM: MSG JRST KILL ;CANNOT ENTER A FILE NOENTR: MSG ; JRST ERATYP ;This routine gets moved to the Low-segment %WEDID: JRST @WEDIED+1 ; Go to KILL routine Z %GETLD: MOVEM 17,SAVEAC+17 ; Save MOVEI 17,SAVEAC ; all BLT 17,SAVEAC+16 ; AC's MOVEI 1,WEDIED+%CANT-%WEDID ; Set up "REENTER" to go to error HRRM 1,.JBREN HRRM 1,.JBSA MOVSI 1,1 ; Throw away CORE 1, ; the hi-seg JRST 4,WEDIED+.-%WEDID ; couldn't - monitor problem MOVEI 1,GETFNM ; call GETSEG 1, ; GETSEG JRST 4,WEDIED+.-%WEDID ; Error MOVSI 17,SAVEAC ; Restore AC's BLT 17,16 MOVE 17,SAVEAC+17 %DDTST: JRST @GETFST ; Go to HiSeg %GTFNM: Z Z SIXBIT "SHR" Z Z Z %GTFST: Z %CANT: OUTSTR WEDIED+%CANT+2-%WEDID EXIT ASCIZ "?Cannot restart" ;TABLE OF SCRATCH DEVICES ;LH IS NAME OF A FILE, IN SIXBIT ;RH IS THE ADDRESS OF AN ENTRY TO CONTAIN DEVICE NAME, ETC. DEVTAB: XWD 'CAL',CALDEV XWD 'NAM',NAMDEV XWD 'ERA',ERADEV XWD 'GEN',GENDEV XWD 'CPY',CPYDEV XWD 'AS1',AS1DEV XWD 'AS2',AS2DEV XWD 'AS3',AS3DEV XWD 'LIT',LITDEV XWD 'CRF',CRFDEV DEVXWD: XWD DEVTAB-.,0 ;TABLE OF MONTHES MOTABL: ASCII "-Jan-" ASCII "-Feb-" ASCII "-Mar-" ASCII "-Apr-" ASCII "-May-" ASCII "-Jun-" ASCII "-Jul-" ASCII "-Aug-" ASCII "-Sep-" ASCII "-Oct-" ASCII "-Nov-" ASCII "-Dec-" ;TABLE OF WORK TABLES DEFINE TABSET (A,B,C,E,F,G),< IFDIF ,,>> XALL WRKTAB: TABLES; WRKXWD: XWD WRKTAB-.,WRKTAB SALL EXTERNAL SRCDEV,LSTDEV,BINDEV,ERADEV,GENDEV,CPYDEV,NAMDEV,CALDEV EXTERNAL AS1DEV,AS2DEV,AS3DEV,LITDEV,CRFDEV EXTERNAL SRCBUF,LSTBUF,BINBUF,AS1BUF,AS2BUF,AS3BUF EXTERNAL GENBUF EXTERNAL COMBH,I0CHAN,LSTBLK,BINBLK EXTERNAL PPOINT,ENTROP,LOOKOP,OUTBOP,TOPLOC,LASTDV EXTERNAL STDATE,STTIME,PHASEN,FSTCLR,FREESP EXTERNAL NAMLOC,EXTPTR,CREFSW,PRODSW EXTERNAL NAMVAL,NAMWRD,NAMNXT,NAMNSZ,NM12SZ,NAMBAS,NM1SIZ,NSZPTR EXTERNAL NM1LOC,NM2LOC,NAMPSZ,NTSIZE,NTNSIZ,SIZTAB EXTERNAL GETLOD,GETFNM,GETFST EXTERNAL DEVDEV,DEVFIL,DEVEXT,DEVBHI,DEVBH,DEVBLK,DEVBUF,DEVPP,DEVSW,DEVSZ EXTERNAL SRCTOP,LSTSWS,BINSWS,IOSRCS,SRCEND,COMEXT EXTERNAL RUNPPN,RUNDEV,STINFL,.HELPR,OPENIT,ADDCOR,TRYNAM EXTERNAL .JBFF,SAVJFF,GETEND,GETFNM,.JBSA,WRKSIZ,SETCOR,.JBSYM EXTERNAL .JBVER,SIXOUT,ERATYP,.JBREN EXTERNAL BLDNAM,EXTNXT,XPNEXT EXTERNAL WEDIED,SAVEAC,VERZUN,KILL END RPGIIA