TITLE 'ALGOL W COMPILER DRIVER - MTS VERSION' PRINT NOGEN SPACE *********************************************************************** * * * NUMAC ALGOL W COMPILER INTERFACE * * (OBJECT MODULE OUTPUT) * * APRIL 1971 * * * *********************************************************************** SPACE ALGOLW CSECT SPACE USING ALGOLW,15 ESTABLISH LINKAGE SAVE (14,12),,* LR 12,15 USING ALGOLW,12 DROP 15 LR 2,13 L 13,=A(SAVE) ST 13,8(,2) ST 2,4(,13) SPACE BAL 4,ANALYZE DECODE PARAMETER LIST LA 0,3 L 1,FREESIZE OBTAIN WORKING STORAGE CALL GETSPACE ST 1,FREEBASE A 1,FREESIZE SET WORK AND COMMON BOUNDS LR 0,1 S 0,COMMSIZE ST 0,FREEPTR STM 0,1,COMMLIM SPACE LA 0,6 GET TIME AND DATE ST 0,TIMEKEY CALL TIME,(TIMEKEY,TIMEOPT,MTSTIME) MVI RUNID,C' ' SET ID STRING MVC RUNID+1(31),RUNID MVC RUNID+10(2),MTSTIME+12 DAY MVC RUNID+13(3),MTSTIME+8 MONTH MVC RUNID+17(2),MTSTIME+18 YEAR MVI RUNID+21,C'@' MVC RUNID+24(5),MTSTIME TIME EJECT MVI PANEL,0 SET FAILURE TRAP LM 0,1,=A(COMPERR,PANEL) CALL PGNTTRP CALL LOAD,(DPHASEA,0,LOADSW,0) LOAD PHASE A ST 15,EPA ST 0,SI#A SR 0,0 MASK INTERRUPTIONS SPM 0 ST 0,PRINTX SELECT SPRINT FOR OUTPUT CALL TIME,(ZERO,ZERO) INITIALIZE TIMER LA 1,ENTVECT PARAMETER LIST L 15,EPA BALR 14,15 EXECUTE PHASE A LR 4,15 SAVE RETURN CODE CALL UNLOAD,(0,SI#A,0) UNLOAD PHASE A LTR 4,4 TEST RETURN CODE BNZ EXIT SPACE 2 LA 0,4 SELECT SERCOM OUTPUT ST 0,PRINTX MVI MAINFLAG,0 CLEAR FLAG CALL LOAD,(DPHASEB,0,LOADSW,0) LOAD PHASE B ST 0,SI#B LA 1,ENTVECT PARAMETER LIST BALR 14,15 EXECUTE PHASE B LR 4,15 SAVE RETURN CODE CALL UNLOAD,(0,SI#B,0) UNLOAD PHASE B LTR 4,4 TEST RETURN CODE BNZ EXIT CLI MAINFLAG,X'FF' TEST FOR MAIN PROGRAM BNE EXIT MVC BUFFER(80),BLANK PUNCH 'CONTINUE' CARD MVC BUFFER(32),=C'$CONTINUE WITH *ALGOLWLIB RETURN' LA 0,BUFFER L 3,=A(PUTCARD) BALR 2,3 SPACE EXIT L 0,FREESIZE RELEASE WORKING STORE L 1,FREEBASE CALL FREESPAC LR 15,4 RETURN CODE L 13,4(,13) RETURN RETURN (14,12),RC=(15) EJECT *********************************************************************** * THE FOLLOWING CODE IS ENTERED FOR COMPILER ERRORS * *********************************************************************** SPACE 2 COMPERR DS 0H SPACE USING COMPERR,15 LM 12,13,=A(ALGOLW,SAVE) RESTORE ADDRESSING DROP 15 L 3,=A(PUTLINE) PREPARE FOR PRINTING MVC BUFFER(132),BLANK MVC BUFFER(30),=C'** COMPILER ERROR. JOB ABORTED.' LA 0,BUFFER LA 1,C'1' BALR 2,3 MVC BUFFER(41),BLANK LR 1,0 DISPLAY PSW L 0,OLDPSW BAL 4,UNPACK L 0,OLDPSW+4 BAL 4,UNPACK LA 0,BUFFER LA 1,C'0' BALR 2,3 SR 5,5 DISPLAY GENERAL REGISTERS LA 6,4 CERR1 LR 1,0 MVC BUFFER(132),BLANK LA 7,4 CERR2 L 0,OLDREG(5) BAL 4,UNPACK LA 5,4(,5) BCT 7,CERR2 LA 0,BUFFER LA 1,C' ' BALR 2,3 BCT 6,CERR1 LA 4,20 RETURN FATAL ERROR CODE B EXIT QUIT SPACE UNPACK ST 0,TEMP UNPACK HEX NUMBER IN R0 UNPK 0(9,1),TEMP(5) TO ADDRESS IN R1 TR 0(8,1),DECTOHEX-240 MVI 8(1),C' ' LA 1,12(,1) STEP DESTINATION POINTER BR 4 DECTOHEX DC C'0123456789ABCDEF' EJECT *********************************************************************** * THE FOLLOWING CODE ANALYZES ANY PAR FIELD SPECIFICATIONS * *********************************************************************** SPACE 2 ANALYZE DS 0H SPACE K EQU 1024 CMIN EQU 18*K MINIMUM COMMON SIZE WMIN EQU 12*K MINIMUM SCRATCH SIZE WMAX EQU 24*K MAXIMUM SCRATCH SIZE STDSIZE EQU 56*K DEFAULT STORAGE REQUEST SPACE L 0,=A(STDSIZE) ST 0,SIZE L 1,0(,1) RECOVER PARAMETERS LH 2,0(,1) LTR 2,2 BZ AN3 (NONE) LA 6,2(2,1) SCAN LIMIT LA 5,1(,1) SPACE AN1 LA 5,1(,5) SCAN TO NON-BLANK CR 5,6 BNL AN3 CLI 0(5),C' ' BE AN1 ST 5,AKEYTEXT DECODE AS A POSSIBLE KEYWORD LA 1,KEYPAR L 15,=V(KEYWRD) BALR 14,15 AN2 CLI 1(5),C' ' SKIP OVER KEYWORD BE AN1 LA 5,1(,5) B AN2 SPACE AN3 L 0,SIZE CHECK AND SPLIT SPACE N 0,=F'-8' C 0,=A(CMIN+WMIN) FORCE INTO RANGE BNL AN4 L 0,=A(CMIN+WMIN) AN4 ST 0,FREESIZE TOTAL STORAGE REQUEST S 0,=A(WMIN) COMPUTE COMMON SIZE LR 1,0 S 1,=A(2*CMIN) FIRST CMIN EXTRA TO COMMON BL AN6 SRA 1,5 REMAINDER/32 TO WORK SPACE N 1,=F'-8' C 1,=A(WMAX-WMIN) (OR MAXIMUM USEFUL) BNH AN5 L 1,=A(WMAX-WMIN) AN5 SR 0,1 SUBTRACT WORK AREA INCREMENT AN6 ST 0,COMMSIZE SAVE COMMON SIZE BR 4 SPACE EXTAB DS 0H KEYWORD EXECUTE TABLE ST 2,SIZE SPACE LHTAB DS 0X KEYWORD LEFT-HAND TABLE DC AL1(0,0,4),C'SIZE' SIZE SPACE RHTAB DS 0X KEYWORD RIGHT-HAND TABLE DC AL1(4,0,15) SIZE DC C'/',AL4(1000) DC C'K',AL4(1024),C'P',AL4(4096) DC X'FF' SPACE KEYPAR DS 0A KEYWORD PARAMETER LIST DC A(LHTLEN,LHTAB,EXTAB) AKEYTEXT DS A DC A(RHTAB) LHTLEN DC AL2(RHTAB-LHTAB) SPACE DROP 12 EJECT LTORG SAVE DS 18F SAVE AREA PROVIDED BY MONITOR DPHASEA DC CL16'*AWXCMPA2 ' PHASE A FILE ID DPHASEB DC CL16'*AWXCMPB2 ' PHASE B FILE ID ZERO DC F'0' LOADSW DC XL4'00000019' LOADING OPTIONS SPACE SIZE DS F STORAGE REQUEST COMMSIZE DS F COMMON AREA SIZE SI#A DS F PHASE A STORAGE INDEX SI#B DS F PHASE B STORAGE INDEX EPA DS A PHASE A ENTRY POINT RUNID DS CL32 SYSTEM IDENTIFICATION SPACE ENTVECT DS 0F ENTRY VECTOR PASSED TO COMPILER COMMLIM DS 2F COMMON LIMITS DC A(PUTLINE) SERVICE ROUTINE ENTRY POINTS DC A(GETCARD) DC A(PUTCARD) DC A(GETMAIN) DC A(FREEMAIN) DC A(GETTIME) DC 7A(0) RESERVED FOR EXPANSION DC X'40',AL3(RUNID) SYSTEM IDENTIFICATION EJECT *********************************************************************** * GETCARD * * SUPPLY 80 CHARACTER INPUT RECORD, DETECT SYSTEM CONTROL CARDS * * R0 = ADDRESS OF RECORD DESTINATION, R0(0:0) := 1 FOR EOF * *********************************************************************** SPACE 2 GETCARD DS 0H GET CARD IMAGE SPACE USING GETCARD,3 STM 14,2,SSAVE SAVE REGISTERS LR 2,0 SAVE DESTINATION ADDRESS MVC 0(8,2),BLANK CLEAR DESTINATION MVC 8(72,2),0(2) CALL SCARDS,(BUFFER,LINELEN,0,LINENO) LTR 15,15 TEST FOR EOF BZ READ1 OI SSAVE+8,X'80' SET EOF BIT B READ5 READ1 LH 1,LINELEN TEST LINE LENGTH LTR 1,1 NULL LINE? BZ READ5 BCTR 1,0 C 1,=F'79' OVER LENGTH? BNH READ4 CLI BUFFER+80,C' ' CHECK FOR NON-BLANKS BNE READ2 S 1,=F'81' BL READ3 EX 1,BLNKTEST BE READ3 READ2 SERCOM '** LINE TRUNCATED - SCARDS' READ3 LA 1,79 TRUNCATE READ4 EX 1,MOVECARD MOVE CHARACTER STRING SPACE * THE FOLLOWING CODE IS A TEMPORARY TRANSITION AID CLI 0(2),C'$' BNE READ5 CLC 1(4,2),=C'LIST' BE FUDGE CLC 1(6,2),=C'NOLIST' BE FUDGE CLC 1(7,2),=C'NOCHECK' BE FUDGE CLC 1(5,2),=C'STACK' BE FUDGE CLC 1(6,2),=C'SYNTAX' BNE READ5 FUDGE MVI 0(2),C'@' SPACE READ5 TM SSAVE+8,X'80' SET CONDITION CODE LM 14,2,SSAVE BR 2 SPACE MOVECARD MVC 0(0,2),BUFFER EXECUTED BLNKTEST CLC BUFFER+81(0),BUFFER+80 DROP 3 SPACE 3 *********************************************************************** * PUTLINE * * ACCEPT 132 CHARACTER OUTPUT STRING AND USASI CONTROL CODE * * R0 = ADDRESS OF STRING, R1 = CONTROL CHARACTER * *********************************************************************** SPACE 2 PUTLINE DS 0H PRINT LINE IMAGE SPACE USING PUTLINE,3 STM 14,2,SSAVE LR 2,0 MVC BUFFER+136(132),0(2) MOVE LINE IMAGE STC 1,BUFFER+135 PREFIX CONTROL CHARACTER L 15,PRINTX SELECT OUTPUT STREAM CLI BUFFER+135,C'1' CHECK FOR DIAGNOSTICS BNE WRITE CLC BUFFER+182(23),=C'COMPILATION DIAGNOSTICS' BNE WRITE LA 15,4 SELECT SERCOM FOR OUTPUT ST 15,PRINTX WRITE B *+4(15) B SPRINT SERCOM CALL SERCOM,(BUFFER+135,H133,0) B WRITE0 SPRINT CALL SPRINT,(BUFFER+135,H133,0) WRITE0 LM 14,2,SSAVE BR 2 RETURN H133 DC H'133' DROP 3 SPACE 3 *********************************************************************** * PUTCARD * * ACCEPT 80 CHARACTER OBJECT OUTPUT STRING * * R0 = ADDRESS OF STRING, R1 = ADDRESS OF HIGHEST COMMON IN USE * *********************************************************************** SPACE 2 PUTCARD DS 0H PUNCH CARD IMAGE SPACE USING PUTCARD,3 STM 14,2,SSAVE LR 2,0 CLC 1(3,2),=C'ESD' TEST FOR '(MAIN)' BNE PUNCH1 CLC 16(8,2),=C'AWXSC001' BNE PUNCH1 MVI MAINFLAG,X'FF' (NEEDS 'CONTINUE' CARD) PUNCH1 SPUNCH (2),H80 PUNCH CARD IMAGE LM 14,2,SSAVE BR 2 H80 DC H'80' DROP 3 SPACE 3 *********************************************************************** * GETMAIN * * SUPPLY VARIABLE-LENGTH FREE STORAGE AREA (NESTED ALLOCATION) * * R0,R1 = MINIMUM, MAXIMUM LENGTH, R0 := ADDRESS, R1 := LENGTH * *********************************************************************** SPACE 2 GETMAIN DS 0H OBTAIN FREE STORAGE SPACE USING GETMAIN,3 L 0,FREEPTR LOWEST ALLOCATED LOCATION SR 0,1 TRY MAXIMUM REQUEST C 0,FREEBASE BNL GM1 L 0,FREEBASE OTHERWISE, GIVE ALL REMAINING GM1 L 1,FREEPTR UPDATE POINTER ST 0,FREEPTR SR 1,0 COMPUTE AREA SIZE BR 2 DROP 3 SPACE 3 *********************************************************************** * FREEMAIN * * RETURN FREE STORAGE AREA TO SYSTEM (NESTED ALLOCATION) * * R0 = ADDRESS, R1 = LENGTH * *********************************************************************** SPACE 2 FREEMAIN DS 0H RELEASE FREE STORAGE SPACE USING FREEMAIN,3 A 1,FREEPTR ADD SPACE BACK ST 1,FREEPTR UPDATE POINTER BR 2 DROP 3 SPACE 3 *********************************************************************** * GETTIME * * OBTAIN ELAPSED TIME IN OS TIMER UNITS (1 OS TU = 2 MACHINE TU) * * R0 := ELAPSED TIME * *********************************************************************** SPACE 2 GETTIME DS 0H GET ELAPSED COMPILATION TIME SPACE USING GETTIME,3 STM 13,1,SSAVE LA 0,8 ST 0,TIMEKEY OBTAIN PROBLEM STATE TIME CALL TIME,(TIMEKEY,TIMEOPT,MTSTIME) L 0,MTSTIME SRL 0,1 CONVERT TO OS TU LM 13,15,SSAVE L 1,SSAVE+16 BR 2 DROP 3 SPACE 3 EJECT TIMEOPT DC F'0' LTORG DS 0D BLANK DC CL8' ' MUST PRECEDE BUFFER BUFFER DS CL268 CARD AND LINE BUFFER MTSTIME DS 5F BINARY/BCD TIMER VALUES TIMEKEY DS F TIMER OPTION TIMEINIT DS F INITIAL TIMER SETTING SSAVE DS 5F LOCAL SAVE AREA FREESIZE DS F TOTAL SIZE OF WORKING STORE FREEBASE DS A BASE OF WORKING STORE FREEPTR DS A TOP OF FREE STORAGE PRINTX DS F OUTPUT STREAM INDEX LINENO DS F MTS LINE NUMBER TEMP DS F PANEL DS 18F OLDPSW EQU PANEL+0 INTERRUPTION PSW OLDREG EQU PANEL+8 INTERRUPTION REGISTERS LINELEN DS H MTS LINE LENGTH MAINFLAG DS X SET FOR MAIN PROGRAM END ALGOLW