$JOB OTSASM[5,2] $; $; THIS JOB ASSEMBLES ALL OTS MODULES FOR $; ALL FORTRAN LIBRARIES. $; $RUN MACRO #; #; THIS SECTION ASSEMBLES ALL MODULES FOR THE #; BASIC LIBRARY: FORLIB.OBJ. #; #ABS,LP:,,<1ST DIM. PAR INDEX>, ;<2ND DIM. PAR INDEX>,<3RD DIM. PAR INDX> ; ;ANY PARAMETER INDEXES TO BE IGNORED WILL BE -1. ;R0,R1,R3 CLOBBERED: R4 ADVANCED OVER PARAMETERS ; .GLOBL MOV C1(SP),C2(SP) MOV D1(SP),D2(SP) A1Z: TST (SP)+ ;FLUSH SIGNS JMP OUT ;DONE A2NZ: ROLB SIGNS+1(SP) ;GET S2 MOVB #1,A2+1(SP) ;INSERT NORMAL BIT MOVB #1,A1+1(SP) ;INSERT NORMAL BIT SUB R4,R5 ;R5=E2-E1, R4=E1 BGT EXPA ;JUMP IF E2>E1 MOV A2(SP),R0 ;R0=A2 MOV B2(SP),R1 ;R1=B2 MOV C2(SP),R2 MOV D2(SP),R3 BR SCHK ;GO CHECK SIGNS EXPA: ADD R5,R4 ;R5=E2-E1,R4=E2,E2>E1 MOV A1(SP),R0 ;R0=A1 MOV B1(SP),R1 ;R1=B1 MOV C1(SP),R2 MOV D1(SP),R3 MOV A2(SP),A1(SP) MOV B2(SP),B1(SP)!PRM,OPPRM,OPFPU1 #OPFPU2,LP:=E1 MOV A2(SP),R0 ;R0=A2 MOV B2(SP),R1 ;R1=B2 BR SCHK ;CHECK SIGNS EXPA: ADD R2,R3 ;R2=E2-E1,R3=E2,E2>E1 MOV A1(SP),R0 ;R0=A1 MOV B1(SP),R1 ;R1=B1 MOV A2(SP),A1(SP) MOV B2(SP),B1(SP) SWAB @SP ;EXCHANGE SIGNS NEG R2 ;E1-E2 SCHK: CMPB SIGNS+1(SP),@SP ;SEE IF SIGNS ARE THE SAME BEQ ECHK ;YES, CHECK EXPONENTS NEG R1 ;NEGATE FRACTION ADC R0 NEG R0 ECHK: TST R2 BEQ SHFTD ;JUMP IF E1=E2 SHFT: CMP #-25.,R0HIGH ORDER NOW MOV R5,@#ASH MOV (R4)+,R0 ;HIGH ORDER DONE MOV @R4,R1 MOV (SP)+,R4 BR SHFTD .ENDC .IFNDF EAE&MULDIV SR16: CMP #-8.,R5 BLE SR8A ;JUMP IF NOT MORE THAN 1/2 WORD TO GO ADD #16.,R5 ;SHIFT LEFT 16-X SL8: ASL R3 ;SHIFT LEFT ROL R2 ROL R1 ROL R0 ROL @SP DEC R5 ;COUNT LOOP BGT SL8 MOV R2,R3 MOV R1,R2 MOV R0,R1 MOV (SP)+,R0 BR SHFTD ;SHIFT DONE .ENDC .IFDF MULDIV SR16: CMP #-3,R5 ;JUMP IF NOT MORE THAN 3 TO SHIFT BLE SR8A MOV R4,@SP ;SAVE EXP AND SH1POLEIS.R5,LP:l  aʋaՀ$ & * P$ ΋Ί   ΋   d Ί  ( 1'u  Q$f $5@ U C΋ Cb M΋U@ U &  B" .&0 I: 2**24, THE RESULT IS ; SIGN(ARG1)*PI/2. ; IF ARG2 <0 THE RESULT IS ARCTAN(ARG1/ARG2) + ; SIGN(ARG1)*PI. ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 F0=%0 F1=%1 F2=%2 F3=%3 F4=%4 F5=%5 .IFNDF FPU ATAN2: CLR -(SP) ;CLEAR SIGN FLAG CLR -(SP) ;CLEAR ATAN2 BIAS CLR -(SP) CLR -(SP) ;CLEAR QUADRANT BIAS CLR -(SP) MOV 2(R5),R4 ;GET FIRST ARG ADDRESS MOV 2(R4),-(SP) ;GET FIRST ARBNE ERROR1 ;YES TUT TUT. ;NOW HAUL STRNG INTO DECODING BUFFER IN IO BUFFER ;AREA AT GLOBAL $IOBUF! ALL IN DATA AREA. ;STRNG MUST NOT BE MORE THAN 23 BYTES LONG ;AND IS LOGICALLY TERMINATED BY A ;NULL CHARACTER OR BY LEN SUPPLIED. MOV 4(R5),R0 ;START ADDR OF STRNG MOV R0,R3 MOV @6(R5),R2 ;GET LEN BNE LOOP1 ;BRANCH IF SET LOOP: INC R2 ;ELSE COUNT AND SCAN TO NULL TSTB (R3)+ BNE LOOP LOOP1: CMP #23.,R2 ;SET MIN OF LEN AND 23. BHIS LOOP2 MOV #23.,R2 LOOP2: INC R2 MOV R2,52(R4) .TITLE $BI $VERSN 02 ; ; ; COPYRIGHT 1971, 1972, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. .CSECT R0=%0 R4=%4 SP=%6 .GLOBL $BI,$IB,$BL,$LB ; $BI - BYTE TO INTEGER CONVERSION ; $IB - INTEGER TO BYTE CONVERSION ; $BL - BYTE TO LOGICAL CONVERSION ; $LB - LOGICAL TO BYTE CONVERSION $IB: $LB: CLRB 1(SP) JMP @(R4)+ $BI: $BL: MOVB (SP)+,R0 MOV R0,-(SP ;TO $MLI SUB R0,R4 IARAY5: MOV (R2)+,-(SP) ;PUSH A DIMENSION DEC R0 BNE IARAY5 ;BRANCH IF MORE JMP @(R4)+ ;CALL $MLI IARAYX: $MLI,$MLI,IARAY6 IARAY6: MOV (SP)+,R0 ;GET PRODUCT MOV (SP)+,R4 ;RESTORE R4 IARAY7: MOV R0,-(SP) ;SAVE NUM ELEMS IN ARRAY ON STK JSR PC,@IOADDR(R4) ;CALL I/O ROUTINE JSR PC,IOELM3 ;CHECK IF ERR'S REQ I/O LIST FLUSHED ADD ARGLEN(R4),ARGPTR(R4) ;POINT TO NEXT ELEM CMP #4,ARGTYP(R4) ;IF LOGICAL*4 OR INTEGER*4 BEQ IARAY9 ;IGNORE SECOND WORD CMP #6,ARGTYP(R4G MOV @R4,-(SP) MOV @SP,R0 ;ARG1 TO R0 MOV 4(R5),R4 ;GET SECOND ARG ADDRESS MOV 2(R4),-(SP) ;GET SECOND ARG MOV @R4,-(SP) MOV @SP,R1 ;ARG2 TO R1 BEQ INF ;JUMP IF DENOMINATOR IS 0 ASL R0 ;GET ABS VAL ARG1 CLRB R0 ;GET EXPONENT SWAB R0 ASL R1 CLRB R1 ;GET EXPONENT ARG2 SWAB R1 SUB R1,R0 ;GET EXPONENT DIFFERENCE CMP #26.,R0 ;CHECK MAGNITUDE BLT INF ;TREAT AS INFINITY DIV: JSR R4,$POLSH .WORD $DVR,UNPOL ;GET ARG1/ARG2 UNPOL: TST @4(R5) ;IF ARG2 >0, BIAS =0 BGE ATANE ;IF A ;SET MBC MOV R2,56(R4) ;SET ABC CLR 54(R4) MOV R4,R3 ;SET BUFFER ADDDR ADD #60,R3 DEC R2 LOOP3: MOVB (R0)+,(R3)+ ;TRANSFER STRING DEC R2 BNE LOOP3 MOVB #12,(R3) ;END WITH LF ;NOW DO .CSII CALL TO DOS. MOV CSIBLK,-(SP) ;#$IOBUF+34,-(SP) EMT 56 TST (SP)+ BNE ERROR2 ;SYNTAX ERROR ;NOW DO .CS12 CALL TO FILL LOCAL FILE+LINK BLOCKS MOV #2,34(R4) ;OUTPUT FILE MOV #CSIBLK,-(SP) EMT 57 BIC #4,(SP) DEC (SP)+ ;SHOULD BE NO MORE FILES BNE ERROR2 ;NOW DO TRANSFER TO OTS TA) JMP @(R4)+ .END ) ;IF WAS COMPLEX CALL I/O ROUTINE BNE IARAY8 JSR PC,@IOADDR(R4) ;WITH IMAGINARY PART JSR PC,IOELM3 ;CHECK IF ERR'S REQ I/O LIST FLUSHED IARAY9: ADD ARGLEN(R4),ARGPTR(R4) IARAY8: MOV (SP)+,R0 ;CHECK IF MORE ARRAY ELEMS DEC R0 BNE IARAY7 ;GO PROCESS IF ANY DEC (SP) ;ELSE CHECK IF ANY MORE ARRAYS BNE IOARAY ;GO PROCESS IF ANY JMP $IOELM ;ELSE EXIT TO CALLER FOR MORE ; .END RG2<0, BIAS=SIGN(ARG1)*PI MOV #040511,8.(SP) ;PI MOV #007733,10.(SP) TST @2(R5) ;TEST ARG1 BGE ATANE ADD #100000,8.(SP) ;-PI ATANE: TST @SP ;SET CODES BR ATAN1 ;JOIN MAIN ROUTINE INF: ADD #18.,SP ;FLUSH STACK MOV #040311,R0 ;ANS = SIGN(ARG1)*PI/2 MOV #007733,R1 TST @2(R5) ;TEST ARG1 BGE INFR ;JUMP IF +PI/2 ADD #100000,R0 ;-PI/2 INFR: .F4RTN ;RETURN TO USER ; ATAN: CLR -(SP) ;CLEAR SIGN FLAG CLR -(SP) ;CLEAR ATAN2 BIAS CLR -(SP) CLR -(SP) ;CLEAR QUADRANT BIAS CLR -(SP) BLE. TST (R1)+ ;BUMP OTS TABLE POINTER ;WAS ANYTHING GIVEN? MOV #DEV,R2 MOV (R2)+,R0 ;GET DEVICE CODE BEQ ERROR2 ;YES TRANSFER DEVICE CODE MOV R0,(R1)+ CLRB (R1)+ ;HOW OPEN BYTE MOVB DEV-1,(R1)+ ;UNIT NUMBER ;SEE IF FILE WAS GIVEN NAME MOV (R2)+,R0 CMP R0,#52 ;*IS NOT ALLOWED! BEQ ERROR2 ;OK TRANSFER FILE NAME MOV R0,(R1)+ ;FIL MOV (R2)+,(R1)+ ;NAM MOV (R2)+,R0 ;EXT CMP R0,#52 ;* IS NOT ALLOWED! BEQ ERROR2 MOV R0,@R1 ;CHECK IF UIC GIVEN. TRUIC: MOV (R2)+,22( MOV 2(R5),R4 ;GET ARG ADDRESS MOV 2(R4),-(SP) ;GET LOW ORDER ARG MOV @R4,-(SP) ;GET HIGH ORDER ATAN1: BGE PLUS ;JUMP IF QUADRANT 1 OR 3 ADD #100000,@SP ;GET ABS VALUE INC 12.(SP) ;FLAG - PLUS: CMP @SP,#40200 ;CHECK IF <1. BLO LE1 ;JUMP IF <1. BGT GT1 ;>1. TST 2(SP) ;CHECK LOW ORDER BEQ LE1 ;=1. GT1: MOV #140311,4(SP) ;-PI/2 MOV #007733,6(SP) ;ATAN(X)=PI/2-ATAN(1/X) DEC 12.(SP) ;ADJUST SIGN MOV 2(SP),-(SP) ;MOVE ARG DOWN MOV 2(SP),-(SP) MOV #40200,4(SP) ;INSERT 1. CLR 6(SP)R1) ;CLEAR OUT ANY DEFINE FILE!! BICB #4,3(R1) ;ALL DONE RETURN ERROR CODE. LEAVE: MOV (SP)+,R4 CMPB @R5,#4 ;DOES HE WANT ERRS? BLT .+6 MOV R4,@10(R5) ;IF SO GIVE IT TO HIM .F4RTN ; ERROR2: INC (SP) ;BUMP ERROR CODE ERROR1: INC (SP) ;BUMP ERROR CODE BR LEAVE ;AND RETURN ; ;DATA AREA. ;*********IMPURE CODE********* ;AS ARE ALL $IOBUF REFERENCES!! ; LNKBLK=.-4 ;OVERLAPPED! .BYTE 1,0 DEV: .RAD50 'SY' ; FILBLK: .RAD50 'FOR' ;OVERLAPPED! .RAD50 '000' .RAD50 'DAT' .TITLE $BSP $VERSN 05 ; ; ; COPYRIGHT 1971, 1972, 1973 DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .GLOBL $BCKSP,$CLOSE,$IOSET,$OPEN,$READ,$FNDEV .GLOBL $ERRA,$EXIT .GLOBL $AIOB .CSECT R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 ; ;THIS ROUTINE DOES BACK SPACING IF FILE OPEN AND FMTD OR UNFMTD ;ELSE IGNORES ; $BCKSP: MOV (SP),R0 ;GET DEVICE NUM JS .TITLE $BX $VERSN 01 ; ; ; COPYRIGHT 1972, DIGITAL EQUIPMENT CORP., MAYNARD, MASS. ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .CSECT .GLOBL $BC,$BR,$BD; ENTRY POINTS .GLOBL $IR,$ID; REFERENCES R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 ; $BC: $BD: MOVB (SP)+,R0; CONVERT BYTE TO INTEGER MOV R0,-(SP); JMP $ID; CONVERT IT ; $BR: MOVB (SP)+,R0; MOV R0,-(SP); JMP $IR; .END JSR R4,$POLSH ;COMPUTE 1./X .WORD $DVR,LE1 LE1: MOV 2(SP),-(SP) ;MOVE ARG DOWN MOV 2(SP),-(SP) CLR 4(SP) CLR 6(SP) CMP @SP,#037611 ;TAN(15) BLO LT15 ;JUMP IF LESS THAN TAN(15) BHI TRANS ;JUMP IF > CMP 2(SP),#030243 BLOS LT15 TRANS: MOV #040006,4(SP) ;INSERT PI/6 MOV #005222,6(SP) MOV @SP,R0 ;ARG TO REGS MOV 2(SP),R1 MOV #131727,-(SP) ;PUSH -ROOT 3 MOV #140335,-(SP) MOV R1,-(SP) MOV R0,-(SP) ;PUSH ARG CLR -(SP) ;PUSH 1. MOV #40200,-(SP) MOV #131727,-(SP) ;PUSH ROOUIC: .WORD 0,0 ; ; CSIBLK: .WORD 0,LNKBLK,FILBLK ; .END R PC,$FNDEV ;GET DEVTAB ENTRY ADDR TST R1 BEQ BADEV ;BRANCH IF DEVICE NUM BAD MOVB DVSW(R1),R3 BIC #177774,R3 ;GET OPEN STATUS BNE BSP1 ;BRANCH IF FILE IPEN BSPX: TST (SP)+ ;IF FILE CLOSED, EXIT JMP @(R4)+ ; BSP1: CMP #3,R3 BEQ BSPX ;IF RANDOM FILE, EXIT DEC R3 ; JSR PC,$AIOB ;GET $IOBUF ADDR IN R2 MOV DVRCNT(R1),-(SP) ;SAVE OLD RECORD COUNT MOV #1,-(SP) ;SET IOSW = INPUT MOV R4,-(SP) ;SAVE R4 MOV R3,-(SP) ;SET IOTSW = FMTD/UNFMTD MOV SP,R4 ;SET R4 TO SIMULATE IOPSTK T3 MOV #040335,-(SP) MOV R1,-(SP) ;PUSH ARG MOV R0,-(SP) JSR R4,$POLSH ;TRANSFORM ARG ; (ROOT3*X-1)/(ROOT3 +X) .WORD $MLR,$SBR,UP,$SBR,$DVR,LT15 LT15: MOV @SP,R0 ;GET ARG MOV 2(SP),R1 MOV R1,-(SP) ;GET THREE COPIES MOV R0,-(SP) MOV R1,-(SP) MOV R0,-(SP) JSR R4,$POLSH .WORD $MLR ;GET ARG**2 .WORD POLY ;SET UP COEFFICIENTS .WORD $MLR,$ADR,$MLR,$ADR,$MLR,$ADR .WORD $MLR,$ADR,$MLR,$ADR .WORD $ADR ;P(X)+0 IF X<=1, P(X)-PI/2 IF X>1 .WORD SIGN ;ADJUST SIGN .WORD $ADR ;ADD SUB #IOTSW,R4 ;SETUP ON STACK ; MOV DVLP(R1),BFLP(R2) ;SET LINK PTR JSR PC,$CLOSE ;CLOSE FILE TST R3 BNE CLOSER ;BRANCH IF ERRORS ; JSR PC,$IOSET ;SETUP TO REOPEN JSR PC,$OPEN ;REOPEN FILE FOR INPUT TST R3 BNE BADOPN ;BRANCH IF ERRORS ; ; BSP2: DEC FMTADR(R4) BEQ BSPY ;BRANCH IF POSITIONED PROPERLY ; BSP4: JSR PC,$READ ;READ A RECORD TST R3 ;CHECK IF ERRORS BNE BADRED ;BRANCH IF SO ; TST IOTSW(R4) ;CHECK FMTD OR UNFMTD BNE B .TITLE $BYT $VERSN 01 ; ; ;COPYRIGHT 1971, 1972, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .CSECT R0 = %0 R1 = %1 R2 = %2 R3 = %3 R4 = %4 R5 = %5 SP = %6 PC = %7 ; ; $BYTE - COMMON POLISH BYTE ROUTINES ; ; ; GETTING A BYTE FROM AN ADDRESS ; SPECIFIED IN R0 (THE STACK IS THE OTHER OPERAND). ; R0 PREVIOUSLY SET BY THE SUBSCRIPT ROUTINE ; ; .GLOBL $GET0ATAN2 BIAS .WORD $POPR3,EXIT ;POP RESULT TO REGS EXIT: TST (SP)+ ;POP SIGN FLAG .F4RTN ;RETURN TO USER ; UP: MOV (SP)+,10.(SP) ;MOVE STACK ITEM UP MOV (SP)+,10.(SP) JMP @(R4)+ ; POLY: MOV (SP)+,R0 ;POP POLY ARG MOV (SP)+,R1 MOV #CONSTS+4,R2 ;POINT TO COEFFICIENT TABLE MOV #5,R3 ;LOOP 5 BR POLY1 POLY2: MOV R1,-(SP) ;PUSH ARG MOV R0,-(SP) POLY1: MOV -(R2),-(SP) ;PUSH CONSTANT MOV -(R2),-(SP) DEC R3 ;COUNT BGT POLY2 JMP @(R4)+ ; SIGN: TST 8.(SP) ;CHECK SIGN FLAG BEQ SIGN .TITLE $CAB $VERSN 02 ; ; ; COPYRIGHT 1971, 1972 DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .CSECT .GLOBL CABS,$DVR,$MLR,$ADR,$FCALL,SQRT .GLOBL $POLSH ; CABS --- THE FORTRAN COMPLEX ABSOLUTE ; VALUE FUNCTION. ; ; FORTRAN STANDARD CALLING SEQUENCE ; 1 COMPLEX ARG ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 CABS: MOV R5,-(SP) ;SAVE RETURN SP3 ;BRANCH IF UNFMTD FILE BSP5: INC DVRCNT(R1) ;COUNT RECORDS READ BR BSP2 ;CHECK IF DONE ; BSP3: BITB #2,BFPTR(R2) ;INC RECORD COUNT ONLY IF LAST BNE BSP5 ;SEGMENT OF RECORD BR BSP4 ;ELSE, READ NEXT SEGMENT ; BSPY: TST (SP)+ ;CLEAR STACK MOV (SP)+,R4 ;RESET R4 CMP (SP)+,(SP)+ MOV BFLP(R2),DVLP(R1) ;RESET LINK POINTER BR BSPX ;GO EXIT ; BADEV: MOV #12.,R3 BSPERR: MOV #1,R0 BSPER1: MOV BFLP(R2),DVLP(R1) ;RESET LINK POINTER SWAB R3 BIS R3,R0 JSR PC,$ERRA JSR PC,$EXIT B $GET0: MOVB @R0,-(SP) JMP @(R4)+ ; ; ; PUT A BYTE FROM THE STACK INTO ADDR SPECIFIED ; BY R0. R0 PREVIOUSLY SET BY THE SUBSCRIPT ROUTINE. ; .GLOBL $PUT0 $PUT0: MOVB (SP)+,(R0)+ JMP @(R4)+ ; ; ; ; PLACES THE LOW ORDER BYTE FROM R0 ON THE STACK ; USED AFTER A FUNCTION CALL TO PLACE FUNCTION RESULTS ; ON THE STACK ; .GLOBL $PSHR0 $PSHR0: MOVB R0,-(SP) ;PUSH ONE BYTE JMP @(R4)+ ; ; ; ; $POP0 - POP A BYTE ITEM ; .GLOBL $POP0 $POP0: MOVB (SP)+,@(R4)+ JMP @(R4)+ ; .END 1 ADD #100000,@SP ;NEGATE RESULT FOR (-1,0) & (1,INF) SIGN1: JMP @(R4)+ .ENDC ; .IFDF FPU ATAN2: SETF ; SET FP MODE FOR FPU MOV 2(R5),R3; ADDRESS OF ARG1 MOV 4(R5),R4; ADDRESS OF ARG2 MOV @R3,R0; HIGH ORDER ARG1 MOV @R4,R1; HIGH ORDER ARG2 BEQ INF; JUMP IF DENOMINATOR 0 ASL R0; CLRB R0; SWAB R0; EXPONENT OF ARG1 ASL R1; CLRB R1; SWAB R1; EXPONENT OF ARG2 SUB R1,R0; GET EXPONENT DIFFERENCE CMP #26.,R0; CHECK MAGNITUDE BLT INF; TREAT AS INFINITE LDF PI,F3; IN MOV 2(R5),R4 ;GET ARG POINTER MOV @R4,R0 ;GET HIGH ORDER REAL PART MOV 4(R4),R1 ;GET HIGH ORDER IMAGINARY ASL R0 ;GET ABS VALUES ASL R1 CMP R0,R1 ;GET MAX BHIS REHI ;JUMP IF REAL BIGGER MOV 6(R4),-(SP) ;PUSH IM MOV 4(R4),-(SP) MOV 2(R4),-(SP) ;PUSH RE MOV @R4,-(SP) MOV 6(R4),-(SP) ;IM AGAIN MOV 4(R4),-(SP) BR DIV REHI: TST R0 BEQ ZERO ;JUMP IF ARG IS 0 MOV 2(R4),-(SP) ;PUSH RE MOV @R4,-(SP) MOV 6(R4),-(SP) ;PUSH IM MOV 4(R4),-(SP) MOV 2(R4),-(SP) ;PUSH RE MOV @R4ADRED: TST R3 BGT BSPERR CLOSER: MOV #1,R3 CLR R0 BR BSPER1 BADOPN: TST R3 BLT CLOSER ADD #3,R3 BR BSPERR ; ; .END ITIALIZE BIAS=PI LDF @R3,F0; GET ARG1 CFCC BGE A1PLUS; JUMP IF ARG1>0 NEGF F3; BIAS=SIGN(ARG1)*PI A1PLUS: LDF @R4,F1; GET ARG2 CFCC BLT A2NEG; CLRF F3; IF ARG2>0, BIAS=0 A2NEG: DIVF F1,F0; ARG1/ARG2, SET FLOAT CC BR ATAN1; JOIN MAIN ROUTINE ; INF: LDF PI2,F1; RESULT=SIGN(ARG1)*PI/2 TST @R3; TEST ARG1 BGE EXIT; +PI/2 NEGF F1; -PI/2 BR EXIT; ; ATAN: SETF ; SET FP MODE FOR FPU CLRF F3; CLEAR ATAN2 BIAS LDF @2(R5),F0; GET ARGUMENT ATAN1: CLR R4; CLEAR SIGN FLAG,-(SP) DIV: JSR R4,$POLSH ;ENTER POLISH MODE .WORD $DVR,DUP ;GET 2 COPIES OF MIN/MAX .WORD $MLR,ONE,$ADR ;GET MIN/MAX**2 +1 .WORD ROOT ;SQRT(1 +(MIN/MAX)**2) DUP: MOV 2(SP),-(SP) ;GET 2 COPIES OF STACK ITEM MOV 2(SP),-(SP) JMP @(R4)+ ONE: CLR -(SP) ;PUSH A 1. MOV #40200,-(SP) JMP @(R4)+ ROOT: MOV SP,R5 ;POINT TO 1+(MIN/MAX)**2 MOV #SQRT,R4 ;POINT TO SQRT JSR PC,$FCALL ;GO GET SQUARE ROOT MOV R0,@SP ;PUT ON STACK MOV R1,2(SP) JSR R4,$POLSH .WORD $MLR,RTN ;SCALE BY MAX RTN: MO .TITLE $CEP $VERSN 03 ; ; ; COPYRIGHT 1971, 1972 DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .CSECT .GLOBL CEXP,SIN,$FCALL,$MLR,$SBR,COS,$MLC .GLOBL EXP,$POLSH,$PSHR3,$POPR4 ; CEXP --- COMPLEX EXPONENTIAL ; CALLING SEQUENCE: ; ; FORTRAN STANDARD (1 COMPLEX ARG) ; ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 CEXP: MOV R5,-(SP) ;SAVE RETURN CFCC ; GET SIGN OF ARGUMENT STF F3,F5; F5=ATAN2 BIAS CLRF F3; CLEAR QUADRANT BIAS BGE PLUS; JUMP IF QUADRANT 1 OR 3 ABSF F0; ABS(X) INC R4; FLAG - PLUS: LDF #1.0,F1; 1.0 CMPF F0,F1; CHECK IF X<=1.0 CFCC BLE LE1; GT1: DEC R4; X>1.0, ADJUST SIGN FLAG DIVF F0,F1; 1.0/X LDF F1,F0; ATAN(X)=PI/2-ATAN(1/X) LDF PI2,F3; QUADRANT BIAS=PI/2 ; LE1: STF F3,F4; F4=QUADRANT BIAS CLRF F3; F3=0.0 CMPF TAN15,F0; COMPARE TAN(15) : X CFCC BGE LT15; X<= TAN(15) LDF PI6,F3;V (SP)+,R0 ;POP RESULT TO REGS BIC #100000,R0 ;MAKE + MOV (SP)+,R1 OUT: MOV (SP)+,R5 ;GET RETURN CLR R2 ;IMAGINARY PART OF RESLT IS 0 CLR R3 .F4RTN ZERO: CLR R0 ;RESULT IS 0 CLR R1 BR OUT .END .TITLE $CJG $VERSN 03 ; ; ; COPYRIGHT 1971,1972 DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .CSECT .GLOBL CONJG ; THE FORTRAN CONJG FUNCTION. ; CALLING SEQUENCE: ; ; FORTRAN STANDARD (1 COMPLEX ARG) ; ; RETURNS THE COMPLEX CONJUGATE OF ARG IN ; R0 - R3. ; R0=%0 R1=%1 R2=%2 R3=%3 R5=%5 CONJG: MOV 2(R5),R3 ;GET ARG ADDRESS MOV (R3)+,R0 ;GET REAL PART MOV 2(R5),R5 ;GET ARG POINTER CMP (R5)+,(R5)+ ;POINT TO Y MOV R5,-(SP) ;SAVE POINTER MOV #SIN,R4 ;GET SIN POINTER JSR PC,$FCALL ;CALL SIN MOV (SP)+,R5 ;GET Y POINTER MOV R1,-(SP) ;PUSH SIN(Y) MOV R0,-(SP) MOV #COS,R4 ;POINT TO COS JSR PC,$FCALL ;GET COS(Y) MOV R1,-(SP) ;PUT IT ON STACK MOV R0,-(SP) MOV 8.(SP),R5 ;GET ARG POINTER MOV 2(R5),R5 MOV #EXP,R4 ;GET EXP(X) JSR PC,$FCALL CLR -(SP) ;MAKE COMPLEX FORMAT CLR -(SP) JSR R4,$POLSH .WORD $PSHR3 ;PUSH EXP(X) .WORD F3=PI/6 LDF F0,F1; MULF ROOT3,F0; SUBF #1.0,F0; X*ROOT3-1.0 ADDF ROOT3,F1; X+ROOT3 DIVF F1,F0; (X*ROOT3-1.0)/(X+ROOT3) ; LT15: LDF F0,F2; X MULF F0,F0; X**2 MOV #FCONST,R0; POINTER TO POLYNOMIAL CONSTANTS MOV #4,R1; COUNT OF COEFFICIENTS LDF (R0)+,F1; INITIALIZE ACCUMULATOR XPAND: MULF F0,F1; DEC R1; COUNT ADDF (R0)+,F1; F1:= F1* X**2 + C(I) BGT XPAND; LOOP MULF F2,F1; F1:= F1*X ADDF F3,F1; PI/6 OR 0.0 SUBF F4,F1; P(X)-QUAD BIAS TST R4; TEST SIGN FLAG BEQ SI MOV (R3)+,R1 MOV (R3)+,R2 ;GET IMAGINARY PART BEQ CONJG1; AVOID -0.0 ADD #100000,R2 ;NEGATE IT CONJG1: MOV @R3,R3 .F4RTN ;RETURN TO USER .END $MLC ;EXP(X)*(COS(Y)+I*SIN(Y)) .WORD $POPR4,RTN ;PUT RESULT IN REGS RTN: MOV (SP)+,R5 ;RESTORE RETURN .F4RTN .END GN1; NO ADJUSTMENT NEGF F1; NEGATE RESULT FOR (-1,0)&(1,INF) SIGN1: ADDF F5,F1; ATAN2 BIAS ; EXIT: STF F1,-(SP); MOVE RESULT TO STACK MOV (SP)+,R0; AND THEN TO REGISTERS MOV (SP)+,R1; .F4RTN ;EXIT ; PI: .WORD 040511,007733; PI PI2: .WORD 040311,007733; PI/2 TAN15: .WORD 037611,030243; TAN(15) PI6: .WORD 040006,005222; PI/6 ROOT3: .WORD 040335,131727; ROOT3 .ENDC FCONST: .WORD 037305,035302 ;.0963034789 .WORD 137421,056514 ;-.1419574624 .WORD 037514,143333 ;.1999773201 .WORD .TITLE $CLG $VERSN 02 ; ; ; COPYRIGHT 1971, 1972, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .CSECT .GLOBL CLOG,ATAN2,CABS,$FCALL,ALOG,$FCAL2 ; CLOG --- THE COMPLEX LOGARITHM FUNCTION ; CALLING SEQUENCE: ; ; FORTRAN STANDARD (1 COMPLEX ARG) ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 CLOG: MOV R5,-(SP) ;SAVE RETURN POINTER MOV 2(R5),R0 ;PO137652,125244 ;-.3333331319 CONSTS: .WORD 040200,000000 ;.9999999999 ; .END INT TO X MOV R0,-(SP) ;.WORD X CMP (R0)+,(R0)+ MOV R0,-(SP) ;.WORD Y MOV SP,R5 MOV #ATAN2,R4 JSR PC,$FCAL2 ;GET ATAN2(Y,X) CMP (SP)+,(SP)+ ;REMOVE CALL ARGS MOV @SP,R5 ;GET ARG POINTER AGAIN MOV R1,-(SP) ;PUSH ATAN2(Y,X) MOV R0,-(SP) MOV 2(R5),R5 ;POINT TO ARG MOV #CABS,R4 ;POINT TO CABS JSR PC,$FCALL MOV R1,-(SP) ;PUSH CABS(ARG) MOV R0,-(SP) MOV SP,R5 ;POINT TO IT MOV #ALOG,R4 ;POINT TO ALOG JSR PC,$FCALL CMP (SP)+,(SP)+ ;FLUSH CABS(ARG) MOV (SP)+,R2 ;GET IM(RESULT .TITLE $CLP $VERSN 01 ; ; ;COPYRIGHT 1971, 1972 DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .GLOBL $CLSUP; .GLOBL $FNDEV,$CLOSE,$AOTS; .CSECT ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 ; ; THIS IS THE OBJECT TIME $CLSUP ROUTINE ; IT IS CALLED TO CLOSE ALL FILES OPENED BY THE OTS ; ; $CLSUP: JSR PC,$AOTS ;ADDRESS OF OTS TABLES MOV R0,R4 ;TO SA .TITLE $CLS $VERSN 04 ; ; ; COPYRIGHT 1971,1972, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .GLOBL $CLOSE,$CLSE .CSECT ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 ; ; ; CLOSE AND RLSE A DATASET ; R0=DEVICE NUM ; R1=DEVICE TABLE ENTRY PTR ; R2=BUFF PTR ; R3=ERROR RETURN CODES (0=NONE, -1=OUT OF SPACE) ; $CLOSE: MOV #CLOSER,BFLKER(R2) ;SET LNK BLK) MOV (SP)+,R3 MOV (SP)+,R5 .F4RTN .END FE PLACE CLR R0; CYCLE THROUGH DEVICE TABLE CLP00: INC R0; AND CLOSE ALL OPEN FILES BLT CLP05; ALL DONE - EXIT CMP R0,@(R4); TEST IF ALL DEVICES DONE BGT CLP03; ALMOST FINISHED - DO CMO CLP01: JSR PC,$FNDEV; GET DEVICE ENTRY TST R1; ILLEGAL DEVICE BEQ CLP00; TRY NEXT DEVICE ENTRY BITB DVSW(R1),#3; IF FILE ALREADY CLOSED, BEQ CLP00; TRY THE NEXT ONE MOV 2(R4),R2; SET BUFFER ADDRESS MOV DVLP(R1),BFLP(R2);SET LINK BLK POINTER JSR PC,$CLOSE; CLOSE THE FILE MOV BFLP(R2),DVLP(R1 ERR RTN MOV R2,-(SP) ;PUSH LINK BLOCK ADDR EMT 13 ;STAT MOV (SP)+,R3 ;SAVE DEVICE STATUS WORD CMP (SP)+,(SP)+ ;CLEAN UP STACK BIT #400,R3 ;IS DEVICE A TERMINAL? BNE CLOSE1 ;OMIT CLOSE IF SO MOV R2,-(SP) ;PUSH LINK BLOCK ADDR EMT 17 ;CLOSE ; CLOSE1: MOV R2,-(SP) EMT 7 ;RLSE ; $CLSE: CLRB DVHOPN(R1) ;CLEAR HOW OPEN FLAG BICB #7,DVSW(R1) ;SET DEVICE CLOSED SWITCHES CLR DVFWRD(R1) ;CLEAR - STATUS/MODE, I/0 COUNT CLR DVBLKN(R1) ;FOR FMTD/UNFMTD I/O CLR DVBLKA(R1) ;FUNC .TITLE $CMB $VERSN 01 ; ; ; COPYRIGHT 1971, 1972, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. .CSECT R0=%0 R4=%4 SP=%6 .GLOBL $CMB ; $CMB - COMPARE BYTE $CMB: MOVB (SP)+,R0 BIC #177400,R0 CMPB (SP)+,R0 JMP @(R4)+ .END ); RESTORE LINK BLK POINTER BR CLP00; DO NEXT DEVICE ; CLP03: MOV (R4),R0; NOW DO THE ERROR LOG DEVICE MOV 2(R0),R0 BLT CLP01; IF IT IS UNIT -3 (CMO) ; CLP05: RTS PC; ALL DONE - EXIT .END WRD,BLKNUM,BUFF ADDR, BUFF LEN CLR DVBLKL(R1) ;FOR RANDOM I/O CLR DVLP(R1) ;CLEAR LINK PTR CLR R3 ;SET NO ERRORS RTS PC ;RETURN ; CLOSER: MOV #-1,R3 ;SET OUT OF SPACE ERROR RTS PC ;RETURN ; ; .END .TITLE $CMC $VERSN 01 ; ; ; COPYRIGHT 1972, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS. ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .CSECT .GLOBL $CMC; ; $CMC - COMPLEX COMPARISON (.EQ., .NE. ONLY) ; CALLED IN POLISH MODE, SETS THE Z BIT ; R0=%0 R4=%4 SP=%6 ; $CMC: MOV #1,R0; ASSUME NOT = CMP @SP,8.(SP); COMPARE 4 WORDSWORTH BNE NE; CMP 2(SP),10.(SP); BNE NE; CMP 4(SP),12.(SP); BNE NE; CM .TITLE $CMD $VERSN 02 ; ; ;COPYRIGHT 1971, 1972 DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS. ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .CSECT .GLOBL $CMD ; $CMD THE DOUBLE COMPARE ROUTINE. ; CALLED IN THE POLISH MODE WITH THE TWO ; COMPARANDS ON THE STACK: ; FIRST IS AT 8(SP), SECOND IS @SP ; FLUSH THE TWO COMPARANDS AND RETURN ; THE FOLLOWING CONDITION CODES: ; FIRST < SECOND N=1, Z=0 ; FIRST = SECOP 6(SP),14.(SP); BNE NE; CLR R0; WELL-THEY MUST BE EQUAL NE: ADD #16.,SP; POP TWO COMPLEX QUANTITIES TST R0; SET Z BIT APPROPRIATELY JMP @(R4)+; .END .TITLE $CMI $VERSN 01 ; ; ;COPYRIGHT 1971, 1972, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT R0 = %0 R1 = %1 R2 = %2 R3 = %3 R4 = %4 R5 = %5 SP = %6 PC = %7 ; .GLOBL $CMI ; ; $CMI - COMPARE INTEGER ; $CMI: SUB (SP)+,(SP)+ JMP @(R4)+ ; .END .TITLE $CMR $VERSN 02 ; ; ;COPYRIGHT 1971, 1972 DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .CSECT .GLOBL $CMR ; $CMR THE REAL COMPARE ROUTINE. ; CALLED IN THE POLISH MODE WITH THE TWO ; COMPARANDS ON THE STACK: ; FIRST IS AT 4(SP), SECOND IS @SP ; FLUSH THE TWO COMPARANDS AND RETURN ; THE FOLLOWING CONDITION CODES: ; FIRST < SECOND N=1, Z=0 ; FIRST = SECOND ND N=0, Z=1 ; FIRST > SECOND N=0, Z=0 R0=%0 R1=%1 R2=%2 R4=%4 SP=%6 PC=%7 F0=%0 .IFDF FPU $CMD: .WORD 170011 ;;SETD .WORD 172426 ;;LDD (SP)+,FO ;GET SECOND ARG .WORD 173426 ;;CMPD (SP)+,F0 ;COMPARE .WORD 170000 ;;CFCC ;GET CONDITION CODES JMP @(R4)+ .ENDC .IFNDF FPU $CMD: MOV @PC,R0 ;GET 00XXXXX XXXX01 IN R0 MOV 8.(SP),R1 ;GET HIGH ORDER FIRST ARG BGE FPOS ;JUMP IF FIRST ARG + ASL R0 ;FLAG FIRST ARG - MOV (SP)+,R2 ;GET HIGH SECOND ARG BLT SAME ;JUMP IF BOTH SIG N=0, Z=1 ; FIRST > SECOND N=0, Z=0 R0=%0 R1=%1 R2=%2 R4=%4 SP=%6 PC=%7 F0=%0 .IFDF FPU $CMR: .WORD 170001 ;;SETF .WORD 172426 ;;LDF (SP)+,F0 ;GET SECOND ARG .WORD 173426 ;;CMPF (SP)+,F0 ;COMPARE .WORD 170000 ;;CFCC ;GET CONDITION CODES JMP @(R4)+ .ENDC .IFNDF FPU $CMR: MOV @PC,R0 ;GET 00XXXXX XXXX01 IN R0 MOV 4(SP),R1 ;GET HIGH ORDER FIRST ARG BGE FPOS ;JUMP IF FIRST ARG + ASL R0 ;FLAG FIRST ARG - MOV (SP)+,R2 ;GET HIGH SECOND ARG BLT SAME ;JUMP IF BOTH SIGNS -NS - BR NEG ;JUMP IF FIRST - AND SECOND + FPOS: MOV (SP)+,R2 BLT PLS ;JUMP IF FIRST + AND SECOND - SAME: CMP R1,R2 ;COMPARE MAGNITUDES BNE OUT ;JUMP IF DIFFERENT CMP 8.(SP),@SP BNE OUT CMP 10.(SP),2(SP) BNE OUT CMP 12.(SP),4(SP) BNE OUT CLR R0 ;FLAG = OUT: ROR R0 ;SAVE C BIT AND TEST SECOND ARG - BCS PLS ;JUMP IF SECOND ARG + NEG: NEG R0 ;REVERSE C BIT PLS: ADD #14.,SP ;POP ARGS TST R0 ;SET Z AND N BITS CORRECTLY JMP @(R4)+ ;RETURN TO CALLER .ENDC .END .TITLE $CPX $VERSN 02 ; ; ; COPYRIGHT 1971, 1972, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .CSECT .GLOBL CMPLX ; THE FORTRAN CMPLX FUNCTION: ; C=CMPLX(R1,R2) ------- > C=R1+IR2. ; CALLING SEQUENCE: ; ; FORTRAN STANDARD (2 ARGS) ; ; RETURNS COMPLEX RESULT C IN R0 - R3. ; R0=%0 R1=%1 R2=%2 R3=%3 R5=%5 CMPLX: MOV 2(R5),R3 ;GET R1 ADDRESS MOV (R3)+ .TITLE $CSN $VERSN 03 ; ; ; COPYRIGHT 1971,1972 DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .CSECT .GLOBL CSIN,CCOS,SIN,COS,EXP,$FCALL,$ADR .GLOBL $SBR,$DVR,$MLR,$POLSH ; CSIN --- COMPLEX SINE ROUTINE. ; CCOS --- COMPLEX COSINE ROUTINE. ; CALLING SEQUENCE: ; ; FORTRAN STANDARD (1 COMPLEX ARG) ; ; RETURNS COMPLEX RESULT IN R0 - R3. ; R0=%0 R1=%1 R2=%2 R BR NEG ;JUMP IF FIRST - AND SECOND + FPOS: MOV (SP)+,R2 BLT PLS ;JUMP IF FIRST + AND SECOND - SAME: CMP R1,R2 ;COMPARE MAGNITUDES BNE OUT ;JUMP IF DIFFERENT CMP 4(SP),@SP ;COMPARE LOW ORDER BNE OUT ;JUMP IF DIFFERENT CLR R0 ;FLAG = OUT: ROR R0 ;SAVE C BIT AND TEST SECOND ARG - BCS PLS ;JUMP IF SECOND ARG + NEG: NEG R0 ;REVERSE C BIT PLS: ADD #6,SP ;POP ARGS TST R0 ;SET Z AND N BITS CORRECTLY JMP @(R4)+ ;RETURN TO CALLER .ENDC .END ,R0 ;GET HIGH ORDER R1 MOV @R3,R1 ;GET LOW ORDER MOV 4(R5),R3 ;GET R2 ADDRESS MOV (R3)+,R2 ;GET HIGH ORDER R2 MOV @R3,R3 ;GET LOW ORDER .F4RTN ;RETURN TO USER .END 3=%3 R4=%4 R5=%5 SP=%6 PC=%7 CSIN: CLR -(SP) ;FLAG CSIN BR SINCOS CCOS: MOV @PC,-(SP) ;FLAG CCOS SINCOS: MOV R5,-(SP) ;SAVE RETURN MOV 2(R5),R5 ;GET ARG POINTER MOV R5,-(SP) ;SAVE IT MOV #SIN,R4 ;POINT TO SIN JSR PC,$FCALL ;GET SIN (X) MOV (SP)+,R5 ;GET X ADDRESS AGAIN MOV R1,-(SP) ;SAVE SINE MOV R0,-(SP) MOV #COS,R4 ;POINT TO COS JSR PC,$FCALL MOV R1,-(SP) ;PUSH COS (X) MOV R0,-(SP) CMP -(SP),-(SP) ;GET SPACE FOR IM(RESULT) MOV 12.(SP),R5 ;GET ARG POINTER MOV 2(R5 .TITLE $CSQ $VERSN 04 ; ; ; COPYRIGHT 1971,1972, 1973 DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .CSECT .GLOBL CSQRT,CABS,$FCALL,$ADR,SQRT,$DVR .GLOBL $ERRA,$POLSH ; CSQRT --- COMPLEX SQUARE ROOT ROUTINE ; CALLING SEQUENCE: ; ; FORTRAN STANDARD (1 COMPLEX ARG) ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 CSQRT: MOV R5,-(SP) ;SAVE RETURN M),R5 CMP (R5)+,(R5)+ ;POINT TO Y MOV #EXP,R4 ;POINT TO EXP JSR PC,$FCALL MOV R1,-(SP) ;PUSH EXP (Y) MOV R0,-(SP) CLR -(SP) ;PUSH A 1. MOV #40200,-(SP) MOV R1,-(SP) MOV R0,-(SP) JSR R4,$POLSH .WORD $DVR,DUP ;GET EXP (-Y) .WORD $ADR,UP ;GET SUM .WORD $SBR,HALV ;GET DIFFERENCE DUP: MOV 6(SP),-(SP) ;GET 2 COPIES MOV 6(SP),-(SP) MOV 6(SP),-(SP) MOV 6(SP),-(SP) JMP @(R4)+ ; UP: MOV (SP)+,10.(SP) ;SAVE SUM OF EXPONENTIALS MOV (SP)+,10.(SP) JMP @(R4)+ ; HALV: SUB #200,@S .TITLE $CX $VERSN 01 ; ; ; COPYRIGHT 1972, DIGITAL EQUIPMENT CORP., MAYNARD, MASS. ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .CSECT .GLOBL $CI,$CR,$CD,$DC; .GLOBL $DI; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 ; $CI: CLR 4(SP); IMAGINARY PART =0.0 CLR 6(SP); JMP $DIOV 2(R5),R5 ;GET ARG POINTER MOV 2(R5),-(SP) ;GET X MOV @R5,-(SP) BIC #100000,@SP ;GET ABS VALUE OF X MOV #CABS,R4 ;POINT TO CABS JSR PC,$FCALL ;GET ABS VALUE OF ARG MOV R1,-(SP) ;PUSH ABS VALUE MOV R0,-(SP) JSR R4,$POLSH .WORD $ADR,HALF ;GET (ABS(X)+MAG(X+IY))/2 HALF: SUB #200,@SP ;DO THE 1/2 BCS UNDER ;JUMP IF UNDERFLOW MOV SP,R5 ;POINT TO (ABS(X)+MAG(X+IY))/2 MOV #SQRT,R4 ;POINT TO SQRT JSR PC,$FCALL ;GET SQUARE ROOT OF ABOVE CMP (SP)+,(SP)+ ;FLUSH CALL MOV (SP)+,R5 ;GET .TITLE $DAB $VERSN 02 ; ; ; COPYRIGHT 1971, 1972, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .CSECT .GLOBL DABS ; THE FORTRAN ABS FUNCTION ; CALLING SEQUENCE: ; ; FORTRAN STANDARD (1 ARG) ; ; RETURNS THE ABSOLUTE VALUE OF THE ; ARGUMENT IN R0 - R3. ; R0=%0 R1=%1 R2=%2 R3=%3 R5=%5 DABS: MOV 2(R5),R3 ;GET ARG ADDRESS MOV (R3)+,R0 ;GET HIGH ORDER RP ;GET HALF THE DIFFERENCE BCS UNDER ;JUMP IF UNDERFLOW BVS UNDER SUB: SUB #200,4(SP) ;HALF THE SUM TST 18.(SP) ;CHECK FLAG BNE COS0 ;JUMP IF CCOS MOV 10.(SP),-(SP) ;GET COS (X) MOV 10.(SP),-(SP) JSR R4,$POLSH .WORD $MLR,SIN1 ;GET COS (X) SINH (Y) .WORD $MLR,SOUT ;GET SIN (X) COSH (Y) SIN1: MOV (SP)+,6(SP) ;SAVE PRODUCT MOV (SP)+,6(SP) MOV 10.(SP),-(SP) ;GET SIN (X) MOV 10.(SP),-(SP) JMP @(R4)+ ; COS0: MOV 14.(SP),-(SP) ;GET SIN (X) MOV 14.(SP),-(SP) ADD #100000,@SP ;NEGA; CONVERT ; $CR: MOV (SP)+,2(SP); ELIMINATE IMAGINARY PART MOV (SP)+,2(SP); JMP @(R4)+; ; $DC: ROL 4(SP); ROUND THE REAL PART ADC 2(SP); AND LET $CD ZERO HIGH ORDER ADC @SP; $CD: CLR 4(SP); IMAGINARY PART = 0.0 CLR 6(SP); JMP @(R4)+; NOW ITS DOUBLE PRECISION ; .END RETURN POINTER MOV 2(R5),R4 ;GET ARG POINTER MOV R1,-(SP) ;PUSH ROOT MOV R0,-(SP) MOV 6(R4),-(SP) ;PUSH Y MOV 4(R4),-(SP) MOV R1,-(SP) ;PUSH ROOT MOV R0,-(SP) ADD #200,@SP ;GET 2*ROOT JSR R4,$POLSH .WORD $DVR,RTN ;GET Y/(2*ROOT) RTN: MOV 2(R5),R4 ;ARG POINTER AGAIN TST @R4 BLT XNEG ;JUMP IF X - MOV (SP)+,R2 ;GET IM(RESULT) MOV (SP)+,R3 MOV (SP)+,R0 ;GET RE MOV (SP)+,R1 .F4RTN ;DONE XNEG: MOV (SP)+,R0 ;GET RE(RESULT) MOV (SP)+,R1 MOV (SP)+,R2 MOV (SP)+,R3 TST 4(OL R0 ;DUMP SIGN CLC ;MAKE IT PLUS ROR R0 MOV (R3)+,R1 ;GET LOW ORDER PARTS MOV (R3)+,R2 MOV @R3,R3 .F4RTN ;RETURN TO CALLER .END ~ $IH TE IT JSR R4,$POLSH .WORD $MLR,COS1 ;GET SIN (X) -SINH (Y) .WORD $MLR,COUT ;GET COS (X) COSH (Y) COS1: MOV (SP)+,10.(SP) ;SAVE PRODUCT MOV (SP)+,10.(SP) JMP @(R4)+ ; COUT: CLR R4 ;FLAG COS SOUT: MOV (SP)+,R0 ;REAL PART TO REGS MOV (SP)+,R1 MOV (SP)+,R2 ;IMAGINARY PART TO REGS MOV (SP)+,R3 TST R4 ;CHECK MODE BEQ OUT ;JUMP IF CCOS CMP (SP)+,(SP)+ ;FLUSH SIN (X) OUT: MOV (SP)+,R5 TST (SP)+ ;FLUSH FLAG .F4RTN ;RETURN TO USER UNDER: CLR @SP ;ZERO UNDERFLOW CLR 2(SP) BR SUB R4) BGE DONE ;JUMP IF Y + ADD #100000,R2 ;NEGATE IMAGINARY PART ADD #100000,R0 ;NEGATE REAL PART DONE: .F4RTN UNDER: MOV #5,R0 ;ERROR 5,0 JSR PC,$ERRA EROUT: CMP (SP)+,(SP)+ MOV (SP)+,R5 BR DONE .END .END .TITLE $DBB $VERSN 01 ; ; ; COPYRIGHT 1972, DIGITAL EQUIPMENT CORP., MAYNARD, MASS. ; .CSECT .GLOBL $DVB,$DVI; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 ; $DVB: MOVB (SP)+,R0; EXTEND SIGN MOVB (SP)+,R1; MOV R1,-(SP); MOV R0,-(SP); JMP $DVI; AND DIVIDE AS INTEGER .END .TITLE $DBL $VERSN 02 ; ; ; COPYRIGHT 1971, 1972, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .CSECT .GLOBL DBLE ; THE FORTRAN DBLE FUNCTION ; CALLING SEQUENCE: ; ; FORTRAN STANDARD (1 ARG) ; ; RETURNS THE DOUBLE PRESICION EQUIVALENT ; OF THE REAL ARGUMENT IN R0 - R3. ; R0=%0 R1=%1 R2=%2 R3=%3 R5=%5 DBLE: MOV 2(R5),R2 ;GET ARG ADDRESS MOV (R2)+,R0 ; .TITLE $DCI $VERSN 01 ; ; ; COPYRIGHT 1971, 1972, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .CSECT .GLOBL $DCI,$RCI ; $DCI --- ASCII TO DOUBLE CONVERSION. ; $RCI --- ASCII TO REAL CONVERSION. ; CALLING SEQUENCE: ; PUSH ADDRESS OF START OF FIELD ; PUSH LENGTH OF FIELD ; PUSH FORMAT SCALE D FROM W.D ; PUSH P FORMAT SCALE ; JSR PC,$DCI (OR $RCI) R0=%0 R1=%1GET HIGH ORDER MOV @R2,R1 ;GET LOW ORDER CLR R2 ;CLEAR LOWEST ORDER CLR R3 .F4RTN ;RETURN TO CALLER .END .TITLE $DCO $VERSN 04 ; ; ; COPYRIGHT 1971,1972 DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL $ECO,$FCO,$GCO,$DCO ; $ECO THE E CONVERSION OUTPUT ROUTINE FOR REALS ; $FCO THE F CONVERSION OUTPUT ROUTINE FOR REALS ; $GCO THE G CONVERSION OUTPUT ROUTINE FOR REALS ; $DCO THE D CONVERSION ROUTINE FOR DOUBLES ; CALLING SEQUENCE: ; PUSH FIELD START ; PUSH FIELD LENGTH ; PUSH D PART OF W.D SPECIFICATION ; PUSH P SCALE ; PUSH VALUE TO BE OUTPUT ; JSR PC,$ECO (OR $FCO) (OR $G .TITLE $DDCI ; ; $DDCI V004A ; ; COPYRIGHT 1971,1972 DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .GLOBL $DCI,$RCI,$ERRA,$EXIT R0=%0 R5=%5 .CSECT $DCI: $RCI: MOV #8.,R0; ERROR 8,0 JSR PC,$ERRA JSR R5,$EXIT .END R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 NUMEND=0 POINTL=2 DIGITS=4 BEXP=6 ESIGN=8. SIGN=10. EXP=12. P=30. D=32. ERF=26. LENGTH=34. TEMP=LENGTH RESULT=P START=36. END=START $RCI: CLR -(SP) ;CLEAR ERROR FLAG INC @SP ;SET REAL CONVERSION FLAG BR CONV $DCI: CLR -(SP) ;CLEAR ERROR FLAG AND SET FOR DOUBLE CONV: MOV R0,-(SP) MOV R1,-(SP) MOV R2,-(SP) MOV R3,-(SP) MOV R4,-(SP) MOV R5,-(SP) CLR -(SP) ;CLEAR EXP CLR -(SP) ;CLEAR SIGN CLR -(SP) ;CLEAR ESIGN MOV #65.,-CO) (OR $DCO) ; R0, R1, R2, R3 ARE DESTROYED R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 POINT=2 BEXP=4 EXP=6 TYPE=12. P=16. D=18. L=20. S=22. $GCO: MOV #42403,R0 ;FLAG G FORMAT BR XCO $FCO: CLR R0 ;FLAG F FORMAT BR XCO $DCO: MOV (SP)+,R0 ;POP RETURN MOV (SP)+,R1 ;GET HIGHEST ORDER ARG MOV (SP)+,R2 ;GET NEXT MOV @SP,R3 ;THIRD ARG WORD MOV #42002,@SP ;FLAG D FORMAT MOV R4,-(SP) ;SAVE R4 MOV 4(SP),R4 ;GET LOWEST ORDER ARG MOV R0,4(SP) ;SAVE RETURN BR XCO1 (SP) ;INITIALIZE BEXP MOV #18.,-(SP) ;INITIALIZE MAX DIGITS CLR -(SP) ;CLEAR POINTL CLR -(SP) ;CLEAR NUMEND MOV START(SP),R5 ;GET FIELD START ADDRESS ADD LENGTH(SP),END(SP) ;POINT TO END +1 CLR R0 ;CLEAR NUMERIC WORK SPACE CLR R1 CLR R2 CLR R3 SCAN: MOVB (R5)+,R4 ;GET NEXT INPUT CHARACTER BIC #177600,R4 CMPB R4,#' ;TEST FOR BLANK BNE SIGNS ;IF NOT BLANK LOOK FOR + OR - CMP R5,START(SP) ;CHECK END OF FIELD BLT SCAN ;IF NOT DONE GO GET NEXT JMP ZERO ;ENTIRE FIELD IS BLANK SI .TITLE $DDCO ; ; $DDCO V004A ; ; COPYRIGHT 1971,1972 DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .GLOBL $DCO,$ECO,$FCO,$GCO,$ERRA,$EXIT R0=%0 R5=%5 .CSECT $DCO: $ECO: $FCO: $GCO: MOV #8.,R0; ERROR 8,0 JSR PC,$ERRA JSR R5,$EXIT .END $ECO: MOV #42402,R0 ;FLAG E FORMAT XCO: MOV (SP)+,R3 ;SAVE RETURN MOV (SP)+,R1 ;GET HIGH ORDER ARG MOV (SP)+,R2 ;GET LOW ORDER ARG MOV R3,-(SP) ;PUSH RETURN MOV R0,-(SP) ;PUSH TYPE CLR R3 ;CLEAR LOW ORDER REGISTERS MOV R4,-(SP) ;SAVE R4 CLR R4 XCO1: MOV R5,-(SP) ;SAVE R5 AND CONTINUE ALL TYPES CLR -(SP) ;CLEAR EXP CLR -(SP) ;CLEAR BEXP CMP -(SP),-(SP) ;ROOM FOR POINT AND SIGN ADD S(SP),L(SP) ;POINT 1 BEYOND END OF FIELD MOV S(SP),R0 CLEAR: MOVB #' ,(R0)+ ;BLANK OUT FIELD CMP .TITLE $DFL $VERSN 02 ; ; ;COPYRIGHT 1971, 1972 DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .GLOBL $DEFIL,$FNDEV,$ERRA,$EXIT .CSECT ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 ; ; THIS ROUTINE PROCESS THE OBJECT TIME DEFINE FILE ; ; $DEFIL,ADDR FILENUM,ADDR MAX NUM RECS, ADDR OF REC LEN, ; ADDR OF ASSOC VAR ; $DEFIL: MOV @(R4)+,R0 ;GET DEVICE NUGNS: CMPB R4,#'+ ;CHECK FOR + SIGN BEQ FIELD ;IF FOUND IGNORE IT CMPB R4,#'- ;CHECK FOR - SIGN BNE NUMCK ;IF NOT FOUND CHECK NUMERICS INC SIGN(SP) ;SET - SIGN FLAG BR FIELD NEXT: MOVB (R5)+,R4 ;GET NEXT INPUT CHARACTER BIC #177600,R4 CMPB R4,#' ;CHECK FOR BLANKS BNE NUMCK MOV #'0,R4 ;TREAT BLANK AS 0 NUMCK: CMPB R4,#'0 ;CHECK FOR LEGAL CHARACTER BLT PNTCK ;CHECK FOR DECIMAL POINT BNE NONZ ;JUMP IF NOT 0 TST R0 ;CHECK TO SEE IF ANY NON-ZERO DIGITS FOUND BNE NONZ TST R1 BNE R0,L(SP) BLO CLEAR ROL R1 ;GET ARG SIGN ROL @SP ;SAVE IT SWAB R1 MOVB R1,BEXP(SP) ;GET BINARY EXPONENT BNE NONZ ;JUMP IF ARG NOT 0 CLR R0; CLEAR OVERFLOW ACCUMULATOR BR NORMD; GO PRINT THE 0 IN FORMAT ; NONZ: SEC ;INSERT NORMAL BIT ROR R1 CLRB R1 ;LEFT JUSTIFY FRACTION SWAB R2 BISB R2,R1 CLRB R2 SWAB R3 BISB R3,R2 CLRB R3 SWAB R4 BISB R4,R3 CLRB R4 SUB #200,BEXP(SP) ;REMOVE EXCESS 128 FROM BINARY EXP BLT DIV ;JUMP IF BINARY EXPONENT NEG BEQ NORM ;JUMP IF NO M JSR PC,$FNDEV ;GET ADDR OF DEVTB ENTRY TST R1 BEQ BADEV ;BRANCH IF BAD DEVICE NUM ; BITB #4,DVSW(R1) ;CHECK IF DEFINE FILE DONE BEQ DEFIL1 ;BRANCH IF NOT DEFILX: ADD #6,R4 ;SKIP REST OF ARGS JMP @(R4)+ ;RETURN WITHOUT DOING DEFINE FILE ; DEFIL1: BITB #3,DVSW(R1) ;CHECK IF DEVICE OPEN BNE OPNER ;ERROR IF SO ; ; NOW SET DEFINE FILE VALUES ; MOV @(R4)+,DVRMAX(R1) ;SAVE NUM RECS IN FILE MOV @(R4)+,DVRLEN(R1) ;SAVE RECORD LEN ASL DVRLEN(R1) ;CONVERT TO BYTES MOV (R4)+,DVAVANONZ TST R2 BNE NONZ TST R3 BEQ FIELD NONZ: CMPB R4,#'9 BGT EXPCK ;CHECK FOR EXPONENT DEC DIGITS(SP) ;COUNT AS A SIGNIFICANT DIGIT BGE A2I ;JUMP IF WE CAN USE THIS DIGIT INC EXP(SP) ;COMPENSATE FOR SKIPPED DIGIT BR FIELD A2I: SUB #60,R4 ;CONVERT ASCII TO INTEGER JSR PC,MUL5 ;MULTIPLY BY 5 JSR PC,LEFT ;DOUBLE RESULT FOR 10 ADD R4,R3 ;ADD IN CURRENT DIGIT ADC R2 ADC R1 ADC R0 ;END OF CONVERT FOR THIS DIGIT FIELD: CMP R5,END(SP) ;CHECK FOR END OF FIELD BLT NEXT MOV R5,@SP .TITLE $DICI ; ; $DICI V004A ; ; COPYRIGHT 1971,1972 DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .GLOBL $ICI,$OCI,$ERRA,$EXIT R0=%0 R5=%5 .CSECT $ICI: $OCI: MOV #8.,R0; ERROR 8,0 JSR PC,$ERRA JSR PC,$EXIT .END SCALING TO DO MUL: TST R1 ;BINARY EXPONENT IS POSITIVE BLT MUL1 ;JUMP IF FRACTION OVERFLOW IMPENDING ASL R4 ;DOUBLE FRACTION ROL R3 ROL R2 ROL R1 DEC BEXP(SP) ;COMPENSATE EXPONENT BGT MUL ;JUMP IF MORE BINARY SCALING TO DO BR NORM MUL1: JSR PC,MUL45 ;GET 4/5 FRACTION INC EXP(SP) ;MULTIPLY BY 10 SUB #3,BEXP(SP) ;AND DIVIDE BY 8 BGT MUL ;JUMP IF BINARY EXPONENT STILL POS. BEQ NORM ;JUMP IF EXPONENT GONE NOW DIV: CMP R1,#146314 ;BINARY EXPONENT IS NEGATIVE BHIS DIV1 ;JUMP IF NO RD(R1) ;SAVE ASSOC VAR ADDR ; BISB #4,DVSW(R1) ;SET FLAG TO INDICATE DEFIL DONE ; JMP @(R4)+ ;RETURN ; ; BADEV: MOV #6001,R0 ;BAD DEVICE NUM ERROR 1,12. JSR PC,$ERRA BR DEFILX OPNER: MOV #5401,R0 ;FILE OPENED NOT FOR RANDOM JSR PC,$ERRA ;ERROR 1,11. DEFIL3: JSR PC,$EXIT ; .END  ;POINTER TO LAST NUMERIC TO NUMEND SCALE: TST R0 BNE SCALE1 ;JUMP IF NUMBER NOT 0 TST R1 BNE SCALE1 TST R2 BNE SCALE1 TST R3 BEQ ZERO ;INPUT NUMBER IS 0 SCALE1: CMP @SP,R5 ;CHECK NUMEND BNE NOP ;JUMP IF THERE WAS AN EXPONENT FIELD SUB P(SP),EXP(SP) ;USE THE FORMAT P SCALE NOP: TST POINTL(SP) BNE POINT ;JUMP IF THERE WAS A DECIMAL POINT MOV D(SP),@SP ;USE THE D SCALE POINT: SUB POINTL(SP),@SP SUB @SP,EXP(SP) ;FORM COMPLETE DECIMAL EXPONENT BGT MUL ;MULTIPLY BY 10**EXP BLT DOOM FOR 5/4 FRACTION CMP BEXP(SP),#-3 BGT DIV1 ;JUMP IF NOT ENOUGH BINARY EXP LEFT JSR PC,MUL54 ;MULTIPLY FRACTION BY 5/4 DEC EXP(SP) ;DIVIDE BY 10 ADD #2,BEXP(SP) ;MULTIPLY BY 4 BR DIV2 DIV1: JSR PC,RIGHT ;DIVIDE BY 2 DIV2: INC BEXP(SP) ;MULTIPLY BY 2 BNE DIV ;HIT IT AGAIN IF BIN.EXP. NOT GONE ; AT THIS POINT THE BINARY EXPONENT IS 0 ; AND THE FRACTION IS IN R1, R2, R3 AND R4. NORM: CLR R0 ;CLEAR OVERFLOW ACCUMULATOR NORM1: JSR PC,MUL54 ;MULTIPLY FRACTION BY 5/4 JSR PC,MUL8 ;AND NOWIV ;JUMP IF DECIMAL EXPONENT IS NEG JMP FLOAT ;JUMP IF EXP IS 0 MUL: CMP R0,#31462 BHI MDIV ;JUMP IF FRACT TOO BIG TO MULT BY 5 JSR PC,MUL5 ;FRACT=5*FRACT INC BEXP(SP) ;TIMES 2 DEC10: DEC EXP(SP) ;OVER 10 BGT MUL ;JUMP IF MORE DECIMAL EXPONENT JMP FLOAT ;DECIMAL EXPONENT GONE MDIV: JSR PC,MUL54 ;MULTIPLY BY 5/4 ADD #3,BEXP(SP) ;TIMES 8 BR DEC10 ;GO DIVIDE BY 10 PNTCK: CMPB R4,#'. BNE ERROR ;JUMP IF NOT A DECIMAL POINT POINTF: TST POINTL(SP) BNE ERROR ;JUMP IF A . ALREADY ENCOUNTER .TITLE $DICO ; ; $DICO V004A ; ; COPYRIGHT 1971,1972 DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .GLOBL $ICO,$OCO,$ERRA,$EXIT R0=%0 R5=%5 .CSECT $ICO: $OCO: MOV #8.,R0; ERROR 8,0 JSR PC,$ERRA JSR PC,$EXIT .END  BY 8 TST R0 BNE NORMD ;JUMP IF AN INTEGER PART RESULTS DEC EXP(SP) ;DECREMENT EXPONENT BR NORM1 ;GO AGAIN TO GET AN INTEGER PART ; AT THIS POINT THE MOST SIGNIFICANT NON ZERO DIGIT IS IN R0 NORMD: TSTB TYPE(SP) ;TEST CONVERSON TYPE BEQ FFMT ;JUMP IF F FORMAT RORB TYPE(SP) BCC EFMT ;JUMP IF E FORMAT OR D FORMAT TST EXP(SP) ;G FORMAT BLT EFMT ;JUMP IF RESULT <.1 CMP EXP(SP),D(SP) BGT EFMT ;JUMP IF RESULT >10**D CLRB TYPE(SP) ;MAKE TYPE F INSTEAD OF G SUB #4,L(SP) ;LEAVE ROOM FOR  .TITLE $DIM $VERSN 02 ; ; ; COPYRIGHT 1971, 1972 DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE ; OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT ; WHICH IS NOT SUPPLIED BY DEC. ; .CSECT .GLOBL DIM,$SBR,$POLSH ; THE FORTRAN DIM FUNCTION ; CALLING SEQUENCE: ; ; FORTRAN STANDARD (2 ARGS) ; ; RETURNS ARG1-ARG2 IN R0 AND R1 IF ARG1>ARG2 ; RETURNS 0 OTHERWISE. ; R0=%0 R1=%1 R4=%4 R5=%5 SP=%6 DIM: MOV 2(R5),R0 ;GET FIRST ARG ADDRESS MOV 2( ED MOV R5,POINTL(SP) ;SAVE A POINTER TO THE . +1 BR FIELD ;GO FOR NEXT CHARACTER ERROR: COMB ERF+1(SP) ;FLAG ERROR ZERO: CLR R0 ;RESULT IS 0 CLR R1 CLR R2 CLR R3 JMP STORE ;GO PUSH RESULT AND RETURN EXPCK: CMPB R4,#'E BEQ EXPT ;JUMP IF E CMPB R4,#'D BNE ERROR ;IF NOT E OR D THEN ERROR EXPT: MOV R5,@SP ;SAVE POINTER TO END OF NUM +1 DEC @SP ;DECREMENT NUMEND MOV R3,TEMP(SP) CLR R3 CMP R5,END(SP) BGE ERROR ;JUMP IF NO ROOM FOR EXP MOVB (R5)+,R4 BIC #177600,R4 CMPB R4,#'  BLANKS ON RIGHT SUB EXP(SP),D(SP) ;DECREASE D BY # OF DIGITS LEFT OF . CLR P(SP) ;SUSPEND P SCALE FFMT: MOV EXP(SP),R5 ;F FORMAT FFMTE: ADD D(SP),R5 ADD P(SP),R5 JSR PC,ROUND ;ROUND BY ADDING 5*10**-P-D-E MOV L(SP),R5 SUB D(SP),R5 TSTB TYPE(SP) BNE FF5 ;JUMP IF NOT F CONVERSION ADD EXP(SP),P(SP) ;COMBINE P AND EXP BLE FF5 ;JUMP IF THERE IS NO INTEGER PART IN RESULT SUB P(SP),R5 SUB #2,R5 ;SIGN SLOT IS S+L-D-E-P-2 JSR PC,ISIGN ;INSERT SIGN AND CHECK WIDTH BR FF3 ;JUMP TO INSER0),-(SP) ;PUSH FIRST ARG MOV @R0,-(SP) MOV 4(R5),R0 ;GET SECOND ARG ADDRESS MOV 2(R0),-(SP) ;PUSH SECOND ARG ON STACK MOV @R0,-(SP) JSR R4,$POLSH ;ENTER POLISH MODE .WORD $SBR,UNPOL UNPOL: MOV (SP)+,R0 ;POP DIFFERENCE BLT NEG ;JUMP IF ARG1 051153 TRCBLD.BAT 2 27-SEP-73 <233> 045704 DGNBLD.BAT 2 27-SEP-73 <233> 067767 ABS .MAC 3 27-SEP-73 <233> 102411 ADB .MAC 2 27-SEP-73 <233> 061563 ADC .MAC 5 27-SEP-73 <233> 050460 ADD .MAC 16 27-SEP-73 <233> 046542 ADI .MAC 2 27-SEP-73 <233> 060573 ADJ .MAC 4 27-SEP-73 <233> 167524 ADR .MAC 11 23-OCT-73 <233> 052236 A DOUBLE ROL R2 ;ROUND TO REAL PRECISION ADC R1 ADC R0 BVS OVER BCS OVER ;JUMP IF OVERFLOW ON ROUND MOV R0,R2 ;MOVE HIGH ORDER RESULT UP MOV R1,R3 DPREC: MOV R0,RESULT(SP) ;STORE RESULT ON STACK MOV R1,RESULT+2(SP) MOV R2,RESULT+4(SP) MOV R3,RESULT+6(SP) ADD #14.,SP ;CLEAR STACK OF JUNK MOV (SP)+,R5 MOV (SP)+,R4 MOV (SP)+,R3 MOV (SP)+,R2 MOV (SP)+,R1 MOV (SP)+,R0 TSTB @SP ;TEST REAL/DOUBLE FLAG BEQ RETRN ;JUMP IF DOUBLE MOV (SP)+,2(SP) ;PUSH FLAG UP MOV (SP)+,2(SP OT POSITIVE ASL @SP MOVB 1(SP),26.(SP) ;GET EXPONENT MOVB #200,1(SP) ;TRANSFORM ARG TO (1/2,1) ROR @SP MOV #157145,-(SP) MOV #031771,-(SP) MOV #002363,-(SP) ;PUSH 1/2*ROOT2 MOV #040065,-(SP) MOV 14.(SP),-(SP) ;PUSH X MOV 14.(SP),-(SP) MOV 14.(SP),-(SP) MOV 14.(SP),-(SP) MOV #157145,-(SP) MOV #031771,-(SP) MOV #002363,-(SP) ;PUSH 1/2*ROOT2 MOV #040065,-(SP) JSR R4,$POLSH ;ENTER POLISH MODE .WORD $SBD,UP,$ADD,$DVD ;GET (X-ROOT2)/ ;(X+ROOT2) .WORD DUP,DUP ;GET THRE!C R0 ADD (SP)+,R2 ADC R1 ADC R0 ADD (SP)+,R1 ADC R0 RTS PC ;RETURN TO CALLER ; ; MUL45: MOV #16.,R5 ;MULTIPLY R1...R4 BY 4/5 JSR PC,RIGHT MOV R4,-(SP) MOV R3,-(SP) MOV R2,-(SP) MOV R1,-(SP) M451: JSR PC,RIGHT JSR PC,RIGHT MOV #2,R0 M452: JSR PC,RIGHT ADD 6(SP),R4 ADC R3 ADC R2 ADC R1 ADD 4(SP),R3 ADC R2 ADC R1 ADD 2(SP),R2 ADC R1 ADD @SP,R1 DEC R0 BGT M452 DEC R5 BGT M451 ADD #8.,SP ;FLUSH MULTIPLIER RTS PC ; ; MULTIPLY THE CONTENTS OF R0 .."LG .MAC 9 27-SEP-73 <233> 062450 AMD .MAC 3 27-SEP-73 <233> 140651 AMG .MAC 3 23-OCT-73 <233> 104727 AMN .MAC 4 27-SEP-73 <233> 010367 ANB .MAC 2 27-SEP-73 <233> 071122 ANI .MAC 2 27-SEP-73 <233> 063665 ANT .MAC 6 23-OCT-73 <233> 014541 ARG .MAC 10 23-OCT-73 <233> 167444 ASP .MAC 4 27-SEP-73 <233> 173443 ASSGN .MAC 8 27-SEP-73 <233> 135707 ATN .MAC 15 27-SEP-73 <233> 116653 BI #) ;PUSH RETURN UP RETRN: ROL (SP)+ ;FLUSH FLAG AND SET C BIT IF ERROR RTS PC ; OVER: UNDER: JMP ERROR ; MUL54: CMP R0,#146314 BLO MUL54A ;JUMP IF ROOM FOR 5/4 * FRACT CLC JSR PC,RIGHT ;DIVIDE BY 2 INC BEXP+0+2(SP) ;MULTIPLY BY 2 MUL54A: MOV R0,-(SP) MOV R1,-(SP) MOV R2,-(SP) MOV R3,-(SP) CLC JSR PC,RIGHT ;HALF CLC JSR PC,RIGHT ;QUARTER BR MUL5A ;GO GET F+F/4 MUL5: MOV R0,-(SP) ;MULT BY 5 MOV R1,-(SP) MOV R2,-(SP) MOV R3,-(SP) JSR PC,LEFT ;DOUBLE JSR PC,LEFT ;QUA$E COPIES .WORD $MLD ;SET UP POLYNOMIAL .WORD $POPR4 ;POP Y .WORD REG XPAND: .WORD $MLD,$ADD,$MLD,$ADD,$MLD,$ADD,$MLD,$ADD .WORD $MLD,$ADD,$MLD,$ADD,$MLD,$ADD ;EXPAND POLYNOMIAL .WORD SCALE,$ID,PLN2,$MLD ;GET LN(EXP) .WORD $ADD,EXIT ;COMBINE WITH FRACTION ;AND CHECK IF DONE .WORD $MLD,EXIT ;MULTIPLY BY LOG10(E) AND RETURN ERROR: ADD #24.,SP ;FLUSH JUNK MOV #1404,R0 ;ERROR 4,3 JSR PC,$ERRA BR EROUT ; REG: MOV #CONSTS+8.,R4 ;POINT TO COEFFICIENTS MOV #7,R5 ;SEVEN CONSTANT%. R4 BY 8. ; NO OVERFLOW IS ANTICIPATED MUL8: MOV R5,-(SP) MOV #3,R5 MUL81: ASL R4 ROL R3 ROL R2 ROL R1 ROL R0 DEC R5 BGT MUL81 MOV (SP)+,R5 RTS PC ERROR: TST (SP)+ ;POP RETURN MOV S(SP),R3 ;POINT TO FIELD BEGIN MOV L(SP),R4 ;GET FIELD END +1 TSTB TYPE(SP) ;CHECK IF END MODIFIED BEQ STARS ;NO, THIS IS F FORMAT ADD #4,R4 ;PUT BACK EXPONENT SPACE STARS: MOVB #'*,(R3)+ ;FILL FIELD WITH * CMP R3,R4 BLO STARS ;JUMP IF MORE TO GO COM TYPE(SP) ;FLAG ERROR BR DONE ; ; RO& .MAC 3 27-SEP-73 <233> 073346 BSP .MAC 6 27-SEP-73 <233> 157364 BX .MAC 2 27-SEP-73 <233> 066573 BYT .MAC 3 27-SEP-73 <233> 161153 CAB .MAC 5 27-SEP-73 <233> 100245 CEP .MAC 4 27-SEP-73 <233> 000126 CJG .MAC 3 27-SEP-73 <233> 113100 CLG .MAC 4 27-SEP-73 <233> 166175 CLP .MAC 4 27-SEP-73 <233> 013342 CLS .MAC 4 27-SEP-73 <233> 013554 CMB .MAC 2 27-SEP-73 <233> 051346 CMC .MA'DRUPLE MUL5A: ADD (SP)+,R3 ADC R2 ADC R1 ADC R0 ADD (SP)+,R2 ADC R1 ADC R0 ADD (SP)+,R1 ADC R0 ADD (SP)+,R0 RTS PC ;CODES MAY BE TESTED ON RETURN LEFT: ASL R3 ROL R2 ROL R1 ROL R0 RTS PC RIGHT: ROR R0 ROR R1 ROR R2 ROR R3 RTS PC .END (S BR STACKC STACK: MOV R3,-(SP) MOV R2,-(SP) MOV R1,-(SP) ;PUSH Y MOV R0,-(SP) STACKC: MOV -(R4),-(SP) ;PUSH COEFFICIENT MOV -(R4),-(SP) MOV -(R4),-(SP) MOV -(R4),-(SP) DEC R5 ;COUNT CONSTANTS BGT STACK MOV #XPAND,R4 ;SET UP RETURN TO LIST JMP @(R4)+ ; UP: MOV (SP)+,22.(SP) ;MOVE ITEM TO WORK SPACE MOV (SP)+,22.(SP) MOV (SP)+,22.(SP) MOV (SP)+,22.(SP) JMP @(R4)+ ; SCALE: CLR -(SP) BISB 12.(SP),@SP ;GET EXPONENT SUB #200,@SP ;REMOVE EXCESS 128 JMP @(R4)+ ; DUP: M)UND THE CONTENTS OF R0 ... R4 TO THE PRECISION ; SPECIFIED BY R5. ; THIS ROUTINE IS SHORTER THAN THE TABLE THAT ; OTHERWISE WOULD BE NEEDED. ROUND: CMP R5,#20. BGT ROUND1 ;JUMP IF NOT WORTH ROUNDING MOV R5,BEXP+0+2(SP) ;SAVE ROUNDING PRECISION IN TEMP BEQ ROUND3 ;JUMP IF ROUND IS TO LEADING DIGIT BLT ROUND1 ;JUMP IF NO ROUNDING TO DO MOV R0,-(SP) MOV R1,-(SP) MOV R2,-(SP) MOV R3,-(SP) MOV R4,-(SP) MOV #100000,R1 ;INSERT .5 CLR R2 CLR R3 CLR R4 RNDF: DEC BEXP+0+2+10.(SP) ;COU*C 3 27-SEP-73 <233> 113461 CMD .MAC 4 27-SEP-73 <233> 051717 CMI .MAC 2 27-SEP-73 <233> 032660 CMR .MAC 4 27-SEP-73 <233> 050244 CPX .MAC 3 27-SEP-73 <233> 115455 CSN .MAC 7 27-SEP-73 <233> 030732 CSQ .MAC 5 27-SEP-73 <233> 100760 CX .MAC 3 27-SEP-73 <233> 131271 DAB .MAC 3 27-SEP-73 <233> 112206 DBB .MAC 2 27-SEP-73 <233> 037500 DBL .MAC 3 27-SEP-73 <233> 107354 DCI .MAC ,OV 6(SP),-(SP) MOV 6(SP),-(SP) ;DUPLICATE STACK ITEM MOV 6(SP),-(SP) MOV 6(SP),-(SP) JMP @(R4)+ ; PLN2: MOV #147572,-(SP) MOV #173721,-(SP) MOV #071027,-(SP) ;PUSH LN(2) MOV #040061,-(SP) JMP @(R4)+ ; EXIT: DECB 11.(SP) ;CHECK FOR ALOG10 BLT LOGOUT ;NO, DONE MOV #024162,-(SP) MOV #124467,-(SP) MOV #055730,-(SP) ;PUSH LOG10(E) MOV #037736,-(SP) JMP @(R4)+ LOGOUT: MOV (SP)+,R0 ;POP RESULT MOV (SP)+,R1 MOV (SP)+,R2 MOV (SP)+,R3 EROUT: MOV (SP)+,R5 ;RESTORE RETURN TST-NT PRECISION BEQ RNDD ;JUMP IF DONE JSR PC,MUL45 ;MULTIPLY BY 4/5 JSR PC,RIGHT JSR PC,RIGHT JSR PC,RIGHT ;DIVIDE BY 8 BR RNDF ;GO CHECK IF DONE WITH FACTOR RNDD: CLR R0 ADD (SP)+,R4 ;ADD FRACTION TO RND FACTOR ADC R3 ADC R2 ADC R1 ADD (SP)+,R3 ADC R2 ADC R1 ADD (SP)+,R2 ADC R1 ADD (SP)+,R1 ADC R0 ADD (SP)+,R0 ROUND2: CMP #10.,R0 BGT ROUND1 ;JUMP IF NO OVERFLOW INC EXP+2(SP) ;BUMP DECIMAL EXPONENT ROUND1: RTS PC ;RETURN TO CALLER ROUND3: ADD #5,R0 ;ROUND MOST SIG. 16 27-SEP-73 <233> 075145 DCO .MAC 20 27-SEP-73 <233> 051410 DDCI .MAC 2 27-SEP-73 <233> 050706 DDCO .MAC 2 27-SEP-73 <233> 053274 DFL .MAC 4 27-SEP-73 <233> 025303 DICI .MAC 2 27-SEP-73 <233> 050740 DICO .MAC 2 27-SEP-73 <233> 051004 DIM .MAC 3 27-SEP-73 <233> 144656 DLCI .MAC 2 27-SEP-73 <233> 050414 DLCO .MAC 2 27-SEP-73 <233> 050504 DLG .MAC 12 27-SEP-73 <233> 043464 FREE BLKS: 27/ BNE PSHRL1 ;JUMP IF LABEL ASSIGNED MOV FLABL,RLAB ;ASSIGN INC FLABL ; NEW LABEL MOV #-120.,RPC ;AND BR PSHRL ;TRY AGAIN PSHRL1: MOV #PSH008,R2 ;POINT TO "REAL" TAIL BR PSHCOM GENDON: MOV FNCHED,R5 ;GET CURRENT CHARACTER POINTER BEQ 99$ ;SKIP IF NO SUMMARY SUB #DOLST,R5 ;FORM CHAR COUNT MOV #DOLST,R4 ;TEXT POINTER .GLOBL OUTLST,LINCT INC LINCT ;ACCOUNT FOR TWO LISTING LINES JSR PC,OUTLST ;TO LISTING DEVICE CLR FNCHED ;TERMINATE BUFFE0 (SP)+ ;FLUSH FLAG .F4RTN .ENDC ; .IFDF FPU DLOG10: MOV @PC,R4; GET 0004XX AS DLOG10 FLAG BR LOG; DLOG: CLR R4; GET 0 AS DLOG FLAG LOG: SETD ; DOUBLE PRECISION FP SETI ; SHORT INTEGERS MOV #FCONST,R0; POINTER TO CONSTANTS LDD @2(R5),F2; GET ARG CFCC BLE ERROR; JUMP IF NOT POSITIVE STEXP F2,R1; GET EXPONENT OF ARGUMENT LDCID R1,F3; CONVERT TO FP FORM MULD (R0)+,F3; SCALE FACTOR=EXPONENT*LN(2) LDEXP #0,F2; TRANSFORM ARG TO(1/2,1) ; LDD F2,F1; SUBD (R0),F2; X-1/2*1NIFICANT DIGIT BR ROUND2 ; ; INSERT A - IF NECESSARY AND CHECK THAT THE FIELD ; IS WIDE ENOUGH TO CONTAIN THE RESULT. ISIGN: CMP R5,S-0+2(SP) ;COMPARE SIGN SLOT WITH FIELD BEGIN BLO SPCK ;JUMP IF IT MAY NOT FIT ROR 0+2(SP) ;TEST SIGN BCC ISR ;JUMP IF + MOVB #'-,@R5 ;INSERT - ISR: INC R5 ;POINT TO LEADING DIGIT SLOT RTS PC ;RETURN SPCK: ROR 0+2(SP) ;TEST SIGN BCS ERROR ;JUMP IF IT'S - 'CAUSE THERE ISN'T ROOM INC R5 ;POINT TO LEADING DIGIT SLOT CMP R5,S+2(SP) BLO ERROR ;JUMP IF NO 2 FREE FILES: 2 3R GOODIES 99$: MOV #200.,R4 JSR PC,TSTPSH ;FORCE OUT THE LAST BIT OF CODE ; ; OUTPUT THE GLOBALS NECESSARY TO HOOK UP TO THE OTS. ; .GLOBL BITM,MISC GEND4: MOV #MISC+4,R5 ;GET ADDRESS OF ITEM BITB #143,(R5) ;ANYTHING AT ALL TO DO? BEQ GEND3 ;NO BITB #140,(R5) ;ANY ENCODE/DECODE STUFF? BNE 1$ ;YES JSR R5,OUTLN2 GL ;OUTPUT THE GLOBAL BITB BITM+0,(R5) ;DO WE NEED A READ? BEQ GEND2 ;NO BICB BITM+0,(R5) JSR R5,OUTLN2 ;OUTPUT THE RD 4SQRT(2) ADDD (R0)+,F1; X+1/2*SQRT(2) DIVD F1,F2; W=(X-ROOT2)/(X+ROOT2) LDD F2,F1; MULD F1,F1; Y= W**2 ; MOV #6,R1; COUNT CONSTANTS FOR POLYNOMIAL LDD (R0)+,F0; INITIALIZE ACCUMULATOR XPAND: MULD F1,F0; DEC R1; COUNT ADDD (R0)+,F0; F0:= Y*F0 + C(I) BGT XPAND; LOOP MULD F2,F0; ADDD (R0)+,F0; F0:= W*F0 - 1/2*LN(2) ADDD F3,F0; ADD SCALE FACTOR FOR EXPONENT TST R4; TEST DLOG10 FLAG BEQ LOGOUT; MULD (R0),F0; DLOG10 = DLOG*LOG10(E) ; LOGOUT: STD F0,-(SP); MOVE RESULT TO 5ROOM FOR IT EITHER RTS PC ; ; EXTRACT LEADING DIGITS FROM R0 ... R4 AND FILL IN ; THE AREA STARTING AT THE ADDRESS IN R5 AND ; BOUNDED BY THE MODIFIED FIELD END. DIGITS: CMP #10.,R0 ;CHECK IF OVERFLOW IN R0 BGT DIG1 ;JUMP IF ONLY ONE DIGITS WORTH MOVB #'1,(R5)+ ;OUTPUT OVERFLOW SUB #10.,R0 ;CORRECT R0 FOR NEXT DIGIT DIG1: CMP POINT+2(SP),R5 ;CHECK FOR . SLOT BNE DIG2 MOVB #'.,(R5)+ ;INSERT THE . DIG2: CMP L+2(SP),R5 ;CHECK END OF FIELD BLOS DIGR ;JUMP IF DONE DIG3: ADD #60,R0 ;CONVE7;$READ 3$: MOV #ILIN,R0 ;GO SET UP JSR PC,SETIO ;INPUT GLOBALS BR GEND4 1$: BITB #100,(R5) ;DECODE? BEQ 2$ ;NO BICB #100,(R5) BR 3$ 2$: BICB #40,(R5) ;CLEAR ENCODE FLAG BR GEND2A GEND2: BITB BITM+1,(R5) ;DO WE NEED A WRITE? BEQ GEND3 ;NO BICB BITM+1,(R5) ;CLEAR THE WRITE FLAG JSR R5,OUTLN2 ;GENERATE A WRITE WT GEND2A: MOV #OLIN,R0 ;GO SET UP JSR PC,SETIO ;THE OUTPUT GLOBALS BR GEND4 GEND3: TST BLKDAT ;BLOCK DATA ? BNE GEND5 ;YES JSR R5,OUTLN2 ;OUTPUT .GLOBL $OTSV EN8STACK MOV (SP)+,R0; AND TENCE TO R0...R3 MOV (SP)+,R1; MOV (SP)+,R2; MOV (SP)+,R3; EROUT: .F4RTN ;EXIT ; ERROR: MOV #1404,R0; ERROR 4,3 JSR PC,$ERRA BR EROUT; EXIT - NO STACK CLEANUP REQUIRED ; ; ORDER-DEPENDENT CONSTANTS FOR ROUTINE ; R0 POINTS AT CURRENT CONSTANT IN FPU VERSION ; FCONST: .WORD 040061,071027; LN(2) .WORD 173721,147572; ; .WORD 040065,002363; 1/2*SQRT(2) .WORD 031771,157145; .ENDC ; .WORD 037455,106270 ;.16948212488 .WORD 157166,174770 ; .WORD 03749RT TO ASCII MOVB R0,(R5)+ ;PUT IT IN FIELD CLR R0 JSR PC,MUL54 ;MULTIPLY FRACTION BY 5/4 JSR PC,MUL8 ;AND BY 8 BR DIG1 ;GO CONVERT TO ASCII DIGR: RTS PC ;RETURN TO CALLER ; ; SHIFT THE CONTENTS OF R1 .. R4 RIGHT 1. RIGHT: CLC ROR R1 ROR R2 ROR R3 ROR R4 RTS PC .END : .TITLE EXTERN ; ;COPYRIGHT 1971, DIGITAL EQUIPMENT CORP. ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS ; SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC. ; ; WRITTEN BY D. KNIGHT ; .CSECT R0 = %0 R1 = %1 R2 = %2 R3 = %3 R4 = %4 R5 = %5 SP = %6 PC = %7 SPACE=40 .GLOBL GET,CURSYM,ENTYWD,OUTLN2,OUTST .GLOBL EXTERN,EOL,NXTCH,ENTYMM,PARMKM,PARWD .GLOBL NAMMKM,NAMWD EXTERN: JSR PC,GET ;GET THE SYMBOL NAME BVS EXTERR ;BAD NAME TST R3 ;IS IT LEGAL? BMI;DPR2 GEND5: JSR R5,OUTLN2 ;OUTPUT END PROTOTYPE ENDPR1 .GLOBL ROUTIN TST ROUTIN ;IS THIS THE MAIN PROGRAM? BNE GEND1 ;NO TST BLKDAT ;NO TRA BNE GEND1 ;FOR BLOCK DATA JSR R5,OUTLN2 ;OUTPUT THE TRA ADDRESS ENDP1 GEND1: JSR PC,EOL ;AND AN END OF LINE .GLOBL OUTFIN JSR PC,OUTFIN ;EMPTY SMALL BUFFER JMP EXIT ;GO DO EXIT PROCESSING ; ; TSTPSH: TST DLAB ;ANY NEED FOR GENERATION?? BEQ GPSH2 ;NO ADD R4,DPC ;ADVANCE DOUBLE PC BMI GPS<71,072731 ;.1811136267967 .WORD 137716,117115 ; .WORD 037543,111153 ;.22223823332791 .WORD 060101,135465 ; .WORD 037622,044436 ;.2857140915904889 .WORD 007306,063062 ; .WORD 037714,146314 ;.400000001206045365 .WORD 153450,165773 ; .WORD 040052,125252 ;.6666666666633660894 .WORD 125247,004643 ; CONSTS: .WORD 040400,000000 ;2.00000000000000261 .WORD 000000,000057 .IFDF FPU ; MORE ORDER-DEPENDENT CONSTANTS ; .WORD 137661,071027; -1/2*LN(2) .WORD 173721,147572; ; .WORD 037> EXTERR ;NO CMP R3,#2 ;IS IT AN ARRAY BEQ EXTER1 ;YES, ERROR MOV CURSYM,R0 ;NOW BIT #NAMMKM,NAMWD(R0) ;IS THIS THE ROUTINE NAME? BNE EXTER2 ;YES, ERROR BIC #ENTYMM,ENTYWD(R0) ;SET BIS #100000,ENTYWD(R0) ; THE EXTERNAL BIT BIT #PARMKM,PARWD(R0) ;IS IT A PARAMETER? BNE EXT1 ;YES, DON'T GENERATE .GLOBL JSR R5,OUTLN2 ;GENERATE THE GLOBAL HDR3 JSR PC,OUTST ;OUTPUT THE SYMBOL NAME JSR PC,EOL EXT1: JSR PC,NXTCH ;GET A CHARACTER .GLOBL NXTCH CMPB R2,#', ;IS THERE MORE?? BEQ ?H2 ;DON'T DO ANYTHING YET MOV R4,-(SP) MOV R0,-(SP) ;SAVE R0 TST DBLT ;IS THIS A SPECIAL DOUBLE? BEQ GPSH4D ;NO CLR DBLT ;TURN OFF THE FLAG JSR R5,OUTLN2 ;OUTPUT THE SPECIAL GOODIES PSH015 GPSH4D: MOV DLAB,R3 ;GET THE LABEL MOV #'F,R0 ;OUTPUT JSR PC,OUTSER ;ROUTINE NAME JSR PC,OUTCOL JSR R5,OUTLN2 ;OUTPUT THE PSH009 JSR R5,OUTLN2 ; CODE PROTOTYPE PSH009 TST RLAB ;CAN WE IMBED A "REAL" IN IT?? BEQ GPSH4B ;NO TST RLT ;IS IT SAFE? BNE GPSH4B ;NO, DON'T ALLOW SPECI@736,055730; LOG10(E) .WORD 124467,024162; .ENDC .END AOD.1 =9. ;CONSTANT 1 REFERNCE COD.B =10. ;ARRAY+OFFSET REFERENCE COD.D =11. ;USE DESTINATION TYP.L =1 ;LOGICAL TYP.I =2 ;INTEGER TYP.R =3 ;REAL MODE TYP.D =4 ;DOUBLE REAL MOD TYP.0 =6 ; OP.NOT =3 ;.NOT. OP.A =4 ;ADD OP.S =5 ;SUBTRACT OP.M =6 ;MULTIPLY OP.D =7 ;DIVIDE OP.PWR =10 OP.LT. =12 OP.GT. =13 OP.EQ. =14 OP.NE. =15 OP.LE. =16 OP.GE. =17 OP.X =10 ;SUBSCRIPT OPERATOR OP.V =12 ;MOVE OPERATOR OP.NEG =11 ;UNARY MINUS PSH. =1 ;NORMAL PUSH PAR. =2 ;PARAMETER ARY. =3 ;ARRAY BEGIN CBEXTERN ;YES TST R2 ;IS THIS END OF LINE?? BEQ EXTDON ;YES TRAP+12. ;NO, END OF LINE ERROR EXTDON: RTS PC EXTERR: TRAP+58. BR EXT1 EXTER1: TRAP+87. ;ARRAY IS BAD NEWS BR EXT1 EXTER2: TRAP+116. ;PROGRAM NAME IS BAD NEWS BR EXT1 ; HDR3: .ASCII / .GLOBL / .BYTE 0 .EVEN ; .END CAL CASES HERE MOV RLAB,R3 ;GENERATE MOV #'F,R0 ; A "REAL" JSR PC,OUTSER ; LABEL JSR PC,OUTCOL ;OUTPUT A COLON CLR RLAB ;RESET MOV #-120.,RPC ;REAL POINTER GPSH4B: CLR DLAB MOV #-120.,DPC GPSH4C: MOV (SP)+,R0 ;RESTORE R0 JSR R5,OUTLN2 ;GENERATE PSH009 ; THE JSR R5,OUTLN2 ; REMAINDER PSH009 ; OF JSR R5,OUTLN2 ; THE PSH005 ; PROTOTYPE MOV #7,R4 ADD (SP)+,R4 TST RLT ;SHALL WE CHECK REAL? BNE GPSH2 ;YES GPSH4A: REOM. =4 ;COMMA FNC. =5 ;FUNCTION BEGIN UOP. =6 ;UNARY OPERATOR BOP. =7 ;BINARY (NO-OPT) OOP. =8. ;OPTIMIZABLE OPE TOP. =9. ;" " END. =10. ;END OF POLISH CVT. =11. ;CONVERSION SVS. =12. ;SVSP CAL. =13. ;FUNCTION CALL ; ; SOME CHARACTERS FOR THE ABOVE CODES ; CODLET: .ASCII /?CSRFGPAK1CD/ ;YES C NOT B ON END OPRLET: .ASCII /????ASMDX?V/ TYPLET: .ASCII /BIIRDC012?4???8/ .EVEN ; STRARY =177401 ;START OF ARRAY STRFNC =177402 ;START OF FUNCTION COMMAC =177403 ;COMMA CODE NULARG =1600GTS PC ; ; GPSH2: TST RLAB ;ANYTHING TO DO?? BEQ GPSH4A ;NO ADD R4,RPC ;ADVANCE REAL PC BMI GPSH4A ;NOTHING TO DO YET CLR -(SP) ;PUT NULL FUDGE ON STACK MOV R0,-(SP) ;SAVE R0 TST RLT ;CHECK FOR SPECIAL REAL BEQ GPSH2A ;NOT SPECIAL CLR RLT JSR R5,OUTLN2 PSH016 GPSH2A: MOV RLAB,R3 MOV #'F,R0 ;GENERATE JSR PC,OUTSER ; THE LABEL JSR PC,OUTCOL ;FOLLOWED BY A COLON CLR RLAB MOV #-120.,RPC ;RESET POINTER BR GPSH4C ;GO TO FINISH UP ; DBLT: 0 RLT: 0 H .TITLE FORMAT .IDENT /0504/ ;RFB ; ;COPYRIGHT 1971, 1972, 1973, DIGITAL EQUIPMENT CORP. ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS ; SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC. ; ; MODIFIED JAN 1973 TO: ; ELIMINATE DOS DEPENDENCY IN NUMERIC CONVERSION ; ADD FLAGGING OF A FORMAT FOR CONDITIONAL LOADING ; ADD FORMAT VARIABLE EXPRESSIONS ; .GLOBL OUTCH2,OUTLN2,GOFLG .GLOBL FORMAT,GENLAB,PUTNAM,BITM,MISC .GLOBL OUTGL,EOL,OUTNAM,OUTCOM,FLABL,OUTSER .GLI00 ;NULL ARGUMENT CODE SVSPCD =104000 ;SVSP CODE .SBTTL TRACE AND INTERNAL ERROR ROUTINES ; ;TRAC ROUTINE ; TRACE: SAVREG TST DMPFLG ;TO TRACE OR NOT? BEQ 5$ ;NO CALL EOL MOV R0,EXTFLG MOV #TRACET,R2 2$: MOV R2,R4 CALL OUTLN1 1$: TSTB (R2)+ BNE 1$ BIT #1,R2 BEQ 4$ INC R2 4$: MOV (R2)+,R3 BIT #1,R3 BEQ 3$ BIC #1,R3 MOV @R3,R3 3$: MOV @R3,R3 CALL OUTOCT CALL EOL TST @R2 BNE 2$ CALL EOL MOV EXTFLG,R0 CLR EXTFLG 5J .TITLE FUNNAM ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORP. ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS ; SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC. ; ; WRITTEN BY D. KNIGHT ; ; ; CHECK MODE OF SPECIAL CLASS OF FUNCTIONS, AND RESET ; TYPE IF NECESSARY. IF THE FUNCTION NAME MATCHES AND ; THE EXPLICITLY TYPED BIT IS NOT SET THE TYPE ; MAY BE SAFELY CHANGED. ; .GLOBL TFUN,SYM1WD,SYM2WD,DATYMM,DATYWD .GLOBL CURSYM,EXPMKM,EXPWD ; R0 = %0 R1 = %1 R2 = %2 K; PSHP: JSR R5,OUTCH2 ;OUTPUT AN INDIRECT '@ PSHP1: MOVB PARXWD(R0),R3 ;GET THE INDEX BIC #177400,R3 ;OUTPUT JSR PC,OUTOCT ; THE INDEX JSR R5,OUTLN2 ;NOW PUT OUT TNE REST OF THE PSH010 ;JUNK RTS PC SETIO: MOV #BITM+2,R1 ;SET UP MOV #MISC+4,R2 ;FOR WHIRLWIND CHECK OF GLOBALS BITB (R1)+,@R2 ;DO WE NEED A DOUBLE CONVERSION? BEQ SETIO2 ;NO JSR R5,OUTLN2 GL JSR R5,OUTLN2 ;GENERATE THE DOUBLE CONV. DC MOV R0,R4 ;SET THE JSR PC,OUTLN1 ;I/O TYPE NEEDED LOBL OUTCHR,LINENO,OUTLN,OUTCOL,NXTCH .GLOBL CNXC,SUBEXP,EXPGEN .CSECT R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 ; ; ;FORMAT HANDLER ; FORMAT: INCB GOFLG ;UNLABELED FORMATS ARE BAD JSR PC,GENLAB ;GENERATE A LABEL MOV #FMT001,R4 ;OUTPUT JSR PC,PUTNAM ;SAVE THE $TR BITB BITM+4,MISC ;SEE IF GLOBAL ALREADY EXISTS BNE FORM09 ;IT DOES BISB BITM+4,MISC ;SET IT EXISTING JSR PC,OUTGL ;OUTPUT THE GLOBAL JSR PC,EOL ;AND END OF LINE FOM$: RETURN ; .MACRO MS A,B .ASCIZ /A/<11> .EVEN +B .ENDM TRACET: MS <;POLPTR:>,POLPTR MS <;@POLPTR:>,POLPTR+1 MS <;STK DEPTH:>,STKDTH MS <;POL CLASS:>,EXTFLG MS <;T.O.S.:>,STKPTR+1 MS <;CURTYP:>,CURTYP MS <;CVT:SER:OPR:>,WORKI MS <;CONVRT:>,CONVRT 0 ; ; INTERNAL ERROR REPORTING ; FAILT: .ASCIZ <15><12>/;INTERNAL ERROR / .EVEN ; ERR206: INC EXTFLG ;FROM 'CSTK' ERR205: INC EXTFLG ;FROM 'DSPTCH' ERR204: INC EXTFLG ;FROM 'QGLOB' NR3 = %3 R4 = %4 R5 = %5 SP = %6 PC = %7 .CSECT ; TFUN: MOV R0,-(SP) ;SAVE MOV R1,-(SP) ;R0 AND R1 MOV CURSYM,R0 ;GET SYMBOL ADDRESS BIT #EXPMKM,EXPWD(R0) ;IS IT EXPLICITLY TYPED?? BNE TF004 ;YES, SO EXIT NOW MOV #FUNLST,R1 ;ADDRESS OF LIST TO SEARCH TF001: CMP SYM1WD(R0),(R1)+ ;DOES FIRST WORD MATCH BNE TF002 ;NO CMP SYM2WD(R0),(R1)+ ;DOES SECOND MATCH BEQ TF005 ;YES TF003: CMP R1,#FUNEND ;IS THE SEARCH DONE?? BLO TF001 ;NO TF004: MOV (SP)+,R1 ;RESTORE R1 MOV (SP)+,R0 ;AO BITB (R1)+,@R2 ;DO WE NEED INTEGER? BEQ SETIO5 ;NO SETIO3: JSR R5,OUTLN2 GL JSR R5,OUTLN2 ;OUTPUT INTEGER CONVERSION IC MOV R0,R4 ;SET THE JSR PC,OUTLN1 ;I/O TYPE BITB (R1)+,@R2 ;DO WE NEED LOGICAL? BEQ SETIO1 ;NO SETIO4: JSR R5,OUTLN2 GL JSR R5,OUTLN2 ;OUTPUT LOGICAL LC MOV R0,R4 ;AND ITS JSR PC,OUTLN1 ; TERMINATOR SETIO1: RTS PC SETIO2: BITB (R1)+,@R2 ;CHECK INTEGER BNE SETIO3 SETIO5: BITB (R1)+,@R2 ;CHECK LOGICAL BNE SETIO4 RTS PC PRM09: JSR PC,OUTNAM ;NOW OUTPUT THE NAME JSR PC,OUTCOM MOV FLABL,R3 ;GET NEEDED LABEL MOV R3,-(SP) ;REMEMBER FOR FINISH UP INC FLABL MOV #'F,R0 ;AND JSR PC,OUTSER ;OUTPUT IT JSR PC,EOL ;GENERATE END OF LINE JSR R5,OUTCH2 ;NOW PUT OUT '$ JSR R5,OUTLN2 ;THE FORMAT LINENO JSR PC,OUTCOL ; LABEL HERE MOV #40.,R5 ;GET CHARACTER COUNT CLR R3 ;SET PAREN COUNT TO ZERO JSR R5,OUTLN2 ;OUTPUT THE FMT004 ; .ASCII FMT000: MOV #CLIST,R4 ;Q ERR203: INC EXTFLG ;FROM 'SVSP' ERR202: INC EXTFLG ;FROM 'GETTYP/SERATR' ERR201: INC EXTFLG ;FROM 'PSHITM' ERR200: CALL OUTLN2, ;FROM 'POP' MOV EXTFLG,R3 ADD #200,R3 CALL OUTOCT CALL EOL ; FAIL: CLR R1 TRAP+147. ;INTERNAL ERROR INC DMPFLG CALL DUMP CALL TRACE DEC DMPFLG MOV FAILSP,SP JMP EXIT ; DUMP: SAVREG CMP #4,OPTLVL BHI 1$ SUB #4,OPTLVL INC DMPFLG 1$: TST DMPFLG BEQ 2$ CALL EOL MOV POLPTR,R2 TST (R2)+ 3$: MOV #';,R4 CALL OUTCHR MOV -(R2),RRND R0 AND RTS PC ;RETURN TF002: TST (R1)+ ;SKIP EXTRA WORD BR TF003 ;AND CONTINUE TF005: SUB #FUNLST+4,R1 ;GET THE TYPE INDEX ASR R1 ASR R1 ;HERE MOVB CHMOD(R1),R2 ;RESET THE TYPE BIC #DATYMM,DATYWD(R0) ;CLEAR OLD TYPE SWAB R2 BIS R2,DATYWD(R0) ;SET THE NEW TYPE SWAB R2 ASR R2 ASR R2 ASR R2 ;MODE IS NOW CORRECT IN R2 BR TF004 ;NOW EXIT ; ; FUNCTION NAMES FOLLOW HERE IN RADIX 50 ; FUNLST: .RAD50 /DAB/ ;DOUBLE .RAD50 /S/ .RAD50 /DMA/ ;DOUBLE .RAD50 /X1/ .RAD50 /DSS .IF NDF COM8K ; ;THIS ROUTINE IS USED TO OUTPUT A SUMMARY OF ALL FUNCTIONS AND ; SUBROUTINES WHICH ARE CALLED BY THE SUBJECT PROGRAM. ; .GLOBL ENTYWD,ENTYMK,UNPK00,SYM1WD FNC01: MOV R0,-(SP) ;SAVE THE SERIAL NUMBER MOV CURSYM,R0 ;IS THIS MOV ENTYWD(R0),R0 ;AN BIC #ENTYMK,R0 BIT #040000,R0 ;ASF??? BNE 99$ ;YES, SKIP IT!! TST FNCHED ;HAS THE HEADING BEEN PUT OUT? BNE 1$ ;YES MOV #HED,R4 MOV #HEDLGT,R5 JSR PC,OUTLST MOV #DOLST,FNCHED CLR FNCNAM ;CLEAR COUNT OTGET CHARACTER LIST FMT012: MOVB (R1)+,R2 ;GET A CHARACTER CMPB R2,#40 ;IGNORE ALL BEQ FMT012 ; BLANKS CMPB R2,(R4)+ ;IS IT AN OPEN PAREN? BEQ FMT014 ;YES CMPB R2,(R4)+ ;IS IT A CLOSED PAREN? BEQ FMT006 ;YES CMPB R2,(R4)+ ;IS IT A ' ? BEQ FRM10 ;YES CMPB R2,(R4)+ ; IS IT A . ? BEQ FMT002 ;YES CMPB R2,(R4)+ ;IS IT A , ? BEQ FMT002 ;YES CMPB R2,(R4)+ ;IS IT A /? BEQ FMT002 ;YES CMPB R2,(R4)+ ;IS IT A - ?? BEQ FMT002 ;YES, IS ALLOWED CMPB R2,(R4)+ ;IS IT A < BNE 13 BEQ 4$ CALL OUTOCT CALL EOL BR 3$ 4$: CALL EOL 2$: RETURN .END VI/ .RAD50 /GN/ .RAD50 /DBL/ ;DOUBLE .RAD50 /E/ .RAD50 /CMP/ ;COMPLEX .RAD50 /LX/ .RAD50 /CON/ ;COMPLEX .RAD50 /JG/ .RAD50 /DEX/ ;DOUBLE .RAD50 /P/ .RAD50 /CEX/ ;COMPLEX .RAD50 /P/ .RAD50 /DLO/ ;DOUBLE .RAD50 /G/ .RAD50 /CLO/ ;COMPLEX .RAD50 /G/ .RAD50 /DLO/ ;DOUBLE .RAD50 /G10/ .RAD50 /DSI/ ;DOUBLE .RAD50 /N/ .RAD50 /CSI/ ;COMPLEX .RAD50 /N/ .RAD50 /DCO/ ;DOUBLE .RAD50 /S/ .RAD50 /CCO/ ;COMPLEX .RAD50 /S/ .RAD50 /DSQ/ ;DOUBLE .RAD50 /RT/ .RAD50 /CSQ/WF NAMES 1$: MOV CURSYM,R0 ;FIND OUT ADD #SYM1WD,R0 ;WHERE THE NAME IS MOV FNCHED,R1 ;GET CURRENT STRING POINTER CMP R1,#DOLST ;IS THIS THE START OF THE LINE? BEQ 2$ ;YES MOVB #',,(R1)+ ;STORE A COMMA 2$: MOVB #TAB,(R1)+ ;FOLLOWED BY A TAB JSR PC,UNPK00 ;GET THE ASCII NAME INC FNCNAM ;ADVANCE COUNT OF NAMES CMP FNCNAM,#7. ;HAVE WE PUT OUT SEVEN? BLT 3$ ;NO SUB #DOLST,R1 ;GET CHARACTER COUNT MOV #DOLST,FNCHED ;RESET THE POINTER MOV R1,R5 X$ JMP FMTEXP ;DO FORMAT EXPRESSION 1$: CMPB R2,(R4)+ ;IS IT A A BEQ FMTA CLR R0 ;SET COUNT TO ZERO CMPB R2,(R4)+ ;IS IT A DIGIT? BLT FMT008 ;NO CMPB R2,(R4)+ ;CHECK AGAIN BLE FMT007 ;IT IS A DIGIT CMPB R2,(R4)+ ;IS IT A D?? BEQ FORM04 ;YES CMPB R2,(R4)+ ;IS IT AN E? BEQ FORM04 ; GO-O-O TEAM CMPB R2,(R4)+ ;HOW ABOUT AN F? BEQ FORM04 ;YEAH MAN, REALLY COOL CMPB R2,(R4)+ ;GIMME A G! BEQ FORM04 ; YEA TEAM INC R0 ;TRY NEXT POSSIBILITY CMPB R2,(R4)+ ;WE NEED AN I BEY .TITLE GCMPLX .GLOBL GCMPLX .GLOBL SYMNXT .CSECT ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORP., MAYNARD, MASS. ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS ; SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC. ; ; WRITTEN BY R. BRENDER, D. KNIGHT ; R0 = %0 R1 = %1 R2 = %2 R3 = %3 R4 = %4 R5 = %5 SP = %6 PC = %7 ; ; ; GCMPLX ; ;ATTEMPT TO COLLECT A COMPLEX CONSTANT OF THE ;FORM: ; (REAL,REAL) ; ^ ;ENTER WITH R1 POINTING AFTER THE LEFT ;PAREN (REPEAT AZ ;COMPLEX .RAD50 /RT/ .RAD50 /DAT/ ;DOUBLE .RAD50 /AN/ .RAD50 /DAT/ ;DOUBLE .RAD50 /AN2/ .RAD50 /DMO/ ;DOUBLE .RAD50 /D/ FUNEND = . CHMOD: .BYTE 40,40,40,40,50,50 .BYTE 40,50,40,50,40,40,50,40 .BYTE 50,40,50,40,40,40 .EVEN .END [ MOV #DOLST,R4 ;TEXT POINTER JSR PC,OUTLST ;LIST IT CLR FNCNAM ;RESET THE NAME COUNT BR 99$ 3$: MOV R1,FNCHED ;REMEMBER CURRENT LINE POSITION 99$: MOV (SP)+,R0 ;RESTORE THE SERIAL NUMBER JMP PSHGEN ;AND GO BACK TO THE LOOP ; ; .IFTF .NLIST BEX .IFT HED: .ASCII <15><12>/ROUTINES CALLED:/ HEDLGT = .-HED .EVEN .IFTF FNCHED: 0+.-. FNCNAM: .BLKW .ENDC ; GL: .ASCII / .GLOBL / .BYTE 0 RD: .ASCII /$READ/ .BYTE 15,12,0 WT: .ASCII \Q FORM04 ; GOT IT!! CMPB R2,(R4)+ ;OR AN O TO CALL IT INTEGER BEQ FORM04 ;YEP, TWAS AN O INC R0 ;NOW WE TRY FOR LOGICAL CMPB R2,(R4)+ ;IT MUST BE AN L OR ELSE IGNORE IT BNE FMT002 ;TAIN'T LOGICAL, SO IGNORE IT FORM04: BISB BITM+2(R0),MISC+4 ;SET FLAG FOR PROPER MODE FMT002: TST R3 ;IS THE PAREN COUNT OK? BNE FMT013 ;YES TRAP+10. ;TELL HIM HE IS WRONG FMT013: JSR PC,TSTIT ;ADVANCE COUNT MOV R2,R4 ;OUTPUT THE JSR PC,OUTCHR ; CHARACTER BR FMT000 ;RE-LOOP FRM10: BR FORM10 ]FTER!) ;RETURN: IF AN ERROR - RESTORE R1 AND V=1 ; IF OKAY THEN R1 POINTS AFTER THE ) ; AND V=0. A COMPLEX CONSTANT ; IS IN THE SYMBOL TABLE POINTER ; AT BY CURSYM. ; ;NO ERROR MESSAGES ARE GIVEN SO THAT THE ;ROUTINE MAY BE CALLED TO "LOOK AHEAD" ;TO SEE IF A COMPLEX IS PRESENT. IF NOT, ;NOTHING IS CHANGED. ; ;IF C-BIT AND V-BIT BOTH SET ON RETURN THEN ;IT PROBABLY WAS AN ILL-FORMED COMPLEX - ;IE, A ; REAL, ;WAS CORRECTLY FOUND. .GLOBL NOCNSV,GET,CNXC,CURSYM,SYMBYT,LENWD,DATYMM .GL_/$WRITE/ .BYTE 15,12,0 DC: .ASCII /$DC/ .BYTE 0 IC: .ASCII /$IC/ .BYTE 0 LC: .ASCII /$LC/ .BYTE 0 ILIN: .ASCII /I/ .BYTE 15,12,0 OLIN: .ASCII /O/ .BYTE 15,12,0 ; ENDPR1: .ASCII / .END/ .BYTE 0 ENDPR2: .ASCIZ /.GLOBL $OTSV/<15><12> ENDP1: .ASCII / MAIN./ .BYTE 0 ENDP2: .ASCII / .GLOBL $EXIT/ .BYTE 15,12 .ASCII / $EXIT/ .BYTE 15,12,0 PSH001: .BYTE ': PSH002: .ASCII / MOV / .BYTE 0 PSH003: .ASCII / MOV -(%0)/ PSH004: .ASCII /,-(%6)/ .BYTE 15,12,0 PSH005: .ASCII /`FMT014: INC R3 ;INCREMENT PAREN COUNT BR FMT002 FMT006: DEC R3 ;DECREMENT PAREN COUNT BR FMT013 ;DON'T CHECK NESTING ON ) FMT008: TST R2 ;IS THIS END OF LINE? BEQ FMT009 TRAP+18. ;BAD CHARACTER IN FORMAT BR FMT000 ;RE-LOOP FMT009: TST R3 ;CHECK PAREN COUNT BEQ FMT010 ; OK BLT FMT011 ;TOO MANY RIGHT PARENS TRAP+59. ;TOO MANY LEFT PARENS FMT010: JSR R5,OUTLN2 ;OUTPUT THE FMT005 ;FINISH JSR R5,OUTLN2 ;UP FMT003 ;GOODIES MOV (SP)+aOBL DATYWD ; ;ATTEMPT TO COLLECT COMPLEX CONSTANT ; GCMPLX: MOV R1,-(SP) MOVB NOCNSV,-(SP) ;SAVE STATE THIS SWITCH INCB NOCNSV ;DON'T SAVE NEXT CONSTANT CLR -(SP) ;SET POSITIVE SIGN JUST IN CASE JSR PC,CNXC ;SKIP POSSIBLE BLANKS CMPB (R1),#'- ;MINUS SIGN?? BNE GC02 ;NO INC @SP ;SET MINUS INC R1 ;ADVANCE CHARACTER POINTER GC02: JSR PC,GET ;LOOK FOR REAL CONSTANT BVS GCMP90 ;PUNT TST R3 BGE GCMP90 ;BR=> NOT A CONSTANT CMP #3,R2 BNE GCMP90 ;BR=> NOT A REAL ; ;HAVE Tb .TITLE GENOVL .IDENT /0613/ ;CP ; ;COPYRIGHT 1971, 1972, 1973, DIGITAL EQUIPMENT CORP. ; ; WRITTEN BY D. KNIGHT ; MODIFIED 28-NOV 1972 TO INCLUDE SUPPORT ; OF RP03 AS SYSTEM DEVICE. ; MODIFIED 26-JUL-73 TO VERIFY ACTUAL SIZE OF EACH OVERLAY ; DOES NOT EXCEED EXPECTED SIZE. ; ; ; THIS ROUTINE IS USED TO OUTPUT A COMPILER OVERLAY ; TO THE DISK IN IMAGE FORM ; .MCALL .INIT,.STAT,.ALLOC,.LOOK,.TRAN,.WAIT,.EXIT,.PARAM ; .PARAM ;REGISTER DEFS, ETC. ; .CSECT ; ; MAX ALLOCATABLE SIZE Fc JMP @(%4)+/ .BYTE 15,12,0 PSH006: .ASCII / .EVEN/ .BYTE 15,12,0 PSH007: .ASCII /+10,%0/ .BYTE 15,12 .ASCII / BR / .BYTE 0 PSH008: .ASCII /+4,%0/ PSH017: .BYTE 15,12 .ASCII / BR / .BYTE 0 PSH009: .ASCII / MOV -(%0),-(%6)/ .BYTE 15,12,0 PSH010: .ASCII /(%5)/ .BYTE 0 PSH011: .ASCII /-4/ .BYTE 0 PSH012: .ASCII /,%0/ .BYTE 0 PSH015: .ASCII / ADD #10,%0/ .BYTE 15,12,0 PSH016: .ASCII / ADD #4,%0/ .BYTE 15,12,0 GENP4: .ASCII /. = .+/ .BYTE 0 GENP1: .ASCII /: 0/ .BYTE 15,d,R3 ;GET $F VALUE MOV #'F,R0 ;OUTPUT JSR PC,OUTSER ;IT JSR PC,OUTCOL ;FOLLOWED BY JSR PC,EOL ;A COLON AND END OF LINE RTS PC ;AND RETURN ; ; A FORMAT ; FMTA: BISB BITM+0,MISC+6 ;FLAG A CONVERSION BR FMT002 ;AND KEEP SCANNING FMT011: TRAP+11. ;TOO MANY RIGHT PARENS. BR FMT010 FMT007: DEC R1 ;BACK UP CHARACTER POINTER MOV R1,-(SP) ;REMEMBER OLD TEXT POINTER JSR PC,D2B ;CONVERT DECIMAL TO BINARY BVS 1$ ;NUMBER IS TOO BIG JSR PC,OUTeHE BEGINNINGS ; JSR PC,CNXC CMPB #',,(R1)+ BNE GCMP90 ;NO JOINING COMMA MOV CURSYM,R0 ;SAVE CURRENT REAL VALUE TST (SP)+ ;IS THE SIGN NEGATIVE?? BEQ GC03 ;NO ADD #100000,SYMBYT(R0) ;YES, SET THE NEGATIVE SIGN GC03: MOV SYMBYT(R0),-(SP) MOV SYMBYT+2(R0),-(SP) CLR -(SP) ;SET POSITIVE SIGN JUST IN CASE JSR PC,CNXC ;SKIP BLANKS CMPB (R1),#'- ;IS IT NEGATIVE?? BNE GC04 ;NO INC @SP ;SET NEGATIVE SIGN INC R1 ;AND ADVANCE CHARACTER COUNT GC04: JSR PC,GET ;TRY FOR SECOND REfOR OVERLAYS ; .IF NDF COM8K SIZLST: 23000 ;OVERLAY 0 MAX SIZE 27000 ;OVERLAY 1 MAX SIZE 36000 ;OVERLAY 2 MAX SIZE 34000 ;OVERLAY 3 MAX SIZE 15000 ;OVERLAY 4 MAX SIZE OVCNT: 4 ;MAX OVERLAY NUMBER IS 4 .IFF ;8K SIZES SIZLST: 12000 ;OVERLAY 0 13000 ;OVERLAY 1 13000 ;OVERLAY 2 13000 ;OVERLAY 3 12000 ;OVERLAY 4 OVCNT: 4 ;MAX OVERLAY NUMBER IS 4 .ENDC ; .GLOBL BEG,TLB,FB0,OVLIST,LOWCOR .GLOBL OVTAB,LENGTH,OVLAY,RDCNTX,INIT ; INIT: .INIT #TLB ;INIT THE SYSTEM DEVICg12,0 GENP2: .ASCII /: 0,0/ .BYTE 15,12,0 GENP3: .ASCII /: 0,0,0,0/ .BYTE 15,12,0 PSHA01: .ASCIZ /: MOV/ .EVEN .END hNUM ;OUTPUT THE VALUE JSR PC,NXTCH ;GET NEXT CHARACTER CMPB R2,#'H ;IS IT HOLLERITH? BEQ FORM11 ;NO DEC R1 ;BACK UP POINTER JMP FMT000 1$: JSR PC,OUTNUM ;OUTPUT THE VALUE BR BADST FORM11: MOV R2,R4 ;OUTPUT THE H JSR PC,OUTCHR JSR PC,TSTIT TST R0 BEQ BADSTR CMP R0,#255. ;IS IT TOO LONG? BGT BADSTR ;YES FORM12: MOVB (R1)+,R4 ;GET A CHARACTER BEQ BADLGT ;BAD LENGTH JSR PC,OUTCHR ;OUTPUT IT JSR PC,TSTIT DEC R0 ;DONE? BGT FORMiAL BVS GCMP91 ;BR=> PUNT TST R3 BGE GCMP91 ;BR=>NOT CONSTANT CMP #3,R2 BNE GCMP91 ;NOT A REAL ;CLOSING DELIMITER? CMPB #'),(R1)+ BNE GCMP91 ;N.G. MOV (SP)+,R0 ;GET THE SIGN MOV (SP)+,R2 ;GET FIRST MOV (SP)+,R3 ;PART OF VALUE MOVB (SP)+,NOCNSV ;USE PREV. VALUE OF THIS SWITCH ;HAVE COMPLEX - MAKE A VALID ENTRY MOV R4,-(SP) ;EVALU EXPECTS R4 MOV R5,-(SP) ;AND R5 TO BE SAFE MOV CURSYM,R4 MOV SYMBYT+2(R4),-(SP) MOV SYMBYT(R4),-(SP) TST R0 ;IS THE SIGN NEGATIVE?? BEQ GjE .STAT #TLB ;AND FIND ITS CHARACTERISTICS CMP (SP)+,(SP)+ MOV (SP)+,BLKSIZ ;AND SAVE IT MOV #BEG,TBLK+2 ;CORE ADDRESS MOV #OVLAY,R2 ;THE MOV R2,LOWCOR ;PRESET LOW CORE ADDRESS .GLOBL OVLAY SUB #BEG,R2 ASR R2 ;WORD COUNT MOV R2,TBLK+4 ;IS SAVED TOO MOV #OVLIST,R0 ;GET ADDRESS OF OVERLAY DATA AREA MOVB (R0)+,R1 ;GET THE OVERLAY NUMBER ASL R1 ;WORD INDEX MOV #OVLAY,R2 SUB #BEG,R2 CMP R2,SIZLST(R1) BHIS ERR ASR R1 BNE INIT01 ;SKIP IF NOT FIRST OVERLAY MOVB (R0)+,Rl12 ;NO JMP FMT000 ;YES FORM10: MOV R2,R4 FORM13: JSR PC,TSTIT JSR PC,OUTCHR ;OUTPUT A CHARACTER MOVB (R1)+,R4 ;GET NEXT CHARACTER BEQ BADLGT ;ERROR IF NO CLOSING ' CMPB #'',R4 ;IS IT A STRING END? BNE FORM13 ;NO MOV R4,R2 JMP FMT013 BADSTR: TRAP+75. ;BAD COUNT BADST: JMP FMT000 BADLGT: DEC R1 ;BACK UP POINTER TRAP+76. ;WEIRD COUN( BR BADST TSTIT: DEC R5 ;DECREMENT CHARACTER COUNT TSTIT1: BGT TST01 ;EXIT IF STILL ROOM MOV R4,-(mC05 ;NO ADD #100000,@SP ;SET NEGATIVE SIGN GC05: MOV R2,-(SP) ;SAVE FIRST MOV R3,-(SP) ;VALUE TOO MOV SP,R0 ;GET ADDRESS OF VARIABLE MOV #10,R4 ;GET LENGTH OF CONSTANT MOV #24000,R5 ;MODE IS COMPLEX .GLOBL SYMCON JSR PC,SYMCON ;DOES CONSTANT ALREADY EXIST? BVC GCMP01 ;YES, DON'T ENTER IT MOV SP,R2 ;REMEMBER ADDRESS OF CONSTANT MOV #8.,R0 ;CLEAR EIGHT GC01: CLR -(SP) ;ENTRIES DEC R0 BNE GC01 MOV SP,R2 ;GET ADDRESS OF SCRATCH .GLOBL DDDD MOV DDDD,R3 ;GET A SERIAL TO Un2 ;GET MAX OVERLAY NUMBER MOV #8.,-(SP) ;MAKE ROOM FOR FIRST SEGMENT MOV #OVTAB,R5 ;GET WORKING ROOM MOV #SIZLST,R0 ;GET ADDRESS OF MAX SIZE TABLE INIT02: MOV (R0)+,R3 ;GET MAX LENGTH OF EACH OVERLAY MOV (SP),(R5)+ ;SAVE SEGMENT ADDRESS ADD #4,R5 ;SKIP OVER UNNEEDED ENTRIES MOV #128.,R4 ;GET SEGMENT SIZE JSR PC,DIVX ;DIVIDE BY SEGMENT SIZE ADD #7,R3 ;ROUND UP TO 8 SEGMENT BIC #7,R3 ;BOUNDARY ADD R3,@SP ;ACCUMULATE TOTAL DEC R2 ;LOOP BPL INIT02 ;UNTIL COMPLETE MOV (SP)+,R4o .TITLE GOTO .IDENT /0711/ ;RFB,PJK,RG ; ;COPYRIGHT 1971,1972,1973 DIGITAL EQUIPMENT CORP. ; MAYNARD, MASS. ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS ; SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC. ; ; THIS MODULE CONTAINS - GOTO, ASSIGN ; ; THE GOTO STATEMENTS ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 .NLIST BEX .GLOBL PUTNAM,BITM,MISC,OUTGL,OUTNAM,OUTCOM .GLOBL OUTCH2,OUTLN2,OUTTAB .GLOBL OUTSL .GLOBL DIMWD,DIMMKM,ASGWD,ASpSP) ;R4 IS SAFE JSR R5,OUTLN2 ;OUTPUT THE TERMINATOR FMT005 JSR R5,OUTLN2 ;OUTPUT THE .ASCII FMT004 ADD #40.,R5 ;RESTORE COUNT MOV (SP)+,R4 ;RESTORE R4 TST01: RTS PC ;AND RETURN OUTNUM: MOV (SP)+,R2 ;SAVE RETURN ADDRESS MOV (SP)+,R4 ;GET OLD CHARACTER POINTER MOV R2,-(SP) ;RESTORE RETURN ADDRESS MOV R1,R2 ;SAVE INPUT POINTER SUB R4,R1 ;CHARACTER COUNT SUB R1,R5 ;CHECK FOR JSR PC,TSTIT1 ;OUTPUT STRING OVERFLOW MOV R5,-(SP) ;SAVE R5 MOV R1,R5 ;PUT CHARACTER COUNT IN RqSE INC DDDD .GLOBL OTOA JSR PC,OTOA ;CONVERT TO ASCII MOV #"$C,@SP ;MAKE A NAME FOR IT MOV SP,R0 ;ADDRESS OF DESTINATION MOV R1,-(SP) ;SAVE R1 MOV R0,R1 ;ADDRESS OF SCRATCH TO R1 ADD #6,R0 ;TO R0 .GLOBL PACK00 JSR PC,PACK00 ;CONVERT TO RADIX 50 MOV (SP)+,R1 ;RESTORE R1 ADD #6,SP ;GET RID OF SCRATCH CLR -(SP) ;PUT IN NULL ENTRY .GLOBL SERIAL MOV SERIAL,-(SP) ;GET A SERIAL NUMBER FOR IT INC SERIAL ;ADVANCE SERIAL NUMBER .GLOBL CONMKM MOV #024000+CONMKM+10,-(SP) ;TEr ;GET NUMBER OF SEGMENTS TO ADDRESS MOV R4,LENGTH ;REMEMBER THE NEEDED FILE LENGTH .ALLOC #TLB,#FB0,R4 ;ALLOCATE THE PROPER FILE LENGTH TST (SP)+ ;TEST RETURN CODE BMI INIT01 ;-1 IS SUCCESS RETURN CLR -(SP) ;ANYTHING ELSE IS AN ERROR MOV #1400+240,-(SP) ;F240 IOT ; DOES NOT RETURN ; INIT01: .LOOK #TLB,#FB0,1 ;LOOK UP THE FILE LOCATION MOV (SP)+,TBLK ;GET FILE START ADDRESS ;VERIFY THAT FILE EXITS AND IS CONTIGUOUS TST (SP)+ ;DISCARD BIT #200,@SP ;FILE EXITS? BEQ ERR ;BR => NO: sGMKM .GLOBL CHTEST,CURSYM,OUTST,PARXMK,SERMK .GLOBL GENLAB,ZLEQLS .GLOBL PARMKM,PARXMK,OUTOCT,PARWD,SERWD .GLOBL PARXWD .GLOBL CNXC,OUTCHR,EOL,OUTSER .GLOBL GOTO,ASSIGN,GET,CNXC1,PSHWD,PSHMKM ;ENTER HERE FOR ALL GOTO STATEMENTS GOTO: .GLOBL GOFLG JSR PC,CNXC ;FIND NEXT NON-BLANK BEQ GOTOER ;ERROR:END-OF-LINE JSR PC,ZLEQLS ;LOOK FOR ZERO LEVEL = BCC GOTO03 ;BR => NOT THERE SEV ;TRY AS ASSIGNMENT INSTEAD RTS PC ; GOTO03: JSR PC,GENLAB ;HANDLE THE LABEL NOW CMPB #'(,@R1t5 MOV R2,R1 ;SET UP NEW STRING POINTER JSR PC,OUTLN ;OUTPUT THE STRING MOV (SP)+,R5 ;RESTORE R5 RTS PC ;AND RETURN TO CALLER ; D2B - DECIMAL ASCII TO BINARY ; ; CONVERT DECIMAL ASCII STRING TO POSITIVE 15-BIT BINARY ; NUMBER. ; ; V-BIT SET IFF OVERFLOW OCCURS. ; SCAN CONTINUES UNTIL FIRST NON-DIGIT OCCURS. ; ; REGISTER USAGE ; INPUT - R1 IS INPUT STRING POINTER ; OUTPUT - R0 IS BINARY VALUE ; R1 IS UPDATED STRING POINTER ; MODIFY - R0,R1,R2,R4 ; D2B: CLR R2uLL WHAT KIND IT IS MOV SP,R0 ;GET ADDRESS OF ENTRY MOV SP,R2 ;AND ADDRESS ADD #20,R2 ; OF THE CONSTANT VALUE .GLOBL PUTSYM JSR PC,PUTSYM ;PUT IN SYMBOL TABLE ADD #20,SP ;GET RID OF ENTRY GCMP01: MOV CURSYM,R2 ;SET UP JSR PC,GETRTR ;RETURN ARGUMENTS .GLOBL GETRTR ;CORRECTLY ADD #10,SP ;GET RID OF THE CONSTANT MOV (SP)+,R5 ;RESTORE THE MOV (SP)+,R4 ;REGISTERS TST (SP)+ ;DISCARD OLD R1 CLC CLV RTS PC ; ;ERROR RETURNES ; GCMP91: ADD #6,SP ;POP JUNK MOVB (SP)+,NOCvERROR BIT #100,(SP)+ ;CONTIGUOUS? BNE OK ;BR=> YES: OKAY ;FATAL ERROR REPORT ERR: CLR -(SP) MOV #1400+300,-(SP) ;F300 IOT ;DOES NOT RETURN ; OK: TST R1 ;IS THIS THE FIRST TIME THROUGH?? BEQ INIT05 ;YES MOV #4,TBLK+6 ;SET READ FUNCTION MOV #RDCNTX,TBLK+4 ;SET NUMBER OF WORDS MOV #LENGTH,TBLK+2 ;SET ADDRESS .TRAN #TLB,#TBLK ;READ IN THE CONTROL BLOCK .WAIT #TLB MOV #2,TBLK+6 ;RESET TO WRITE FUNCTION INIT05: ASL R1 ;MULTIPLY MOV R1,R0 ;OVERLAY NUMBER ASL R0 ;BY ADD R1,w BEQ GOTOX ;HAVE COMPUTED GOTO INCB GOFLG JSR PC,CHTEST ;CHECK CHAR TYPE BMI GOTOU ;DIGIT => UNCONDITIONAL BVC GOTOER ;ERROR - NOT VALID GOTO JMP GOTOA ;ASSIGNED GOTO ; ; UNCONDITIONAL GOTO ; GOTOU: MOV R1,-(SP) ;REMEMBER BEGINNING OF LABEL JSR PC,SKPSL ;SKIP PAST LABEL BNE GOTOES ;SHOULD BE EOL MOV (SP)+,R1 ;LINE OKAY - RECOVER LABEL POINTER ; GENERATE THE TRANSFER CODE MOV #GOTOT0,R4 ;"$TR,." JSR PC,PUTNAM BITB BITM+4,MISC ;WAS A GLOBL PREV. GENERATED? BNE Gx CLR R0 1$: MOVB (R1)+,R4 BIC #177600,R4 SUB #60,R4 CMP R4,#11 BHI 4$ CMP R0,#6314 BHI 3$ BLO 2$ CMPB R4,#7 BHI 3$ 2$: ASL R0 ADD R0,R4 ASL R0 ASL R0 ADD R4,R0 BR 1$ 3$: INC R2 BR 1$ 4$: DEC R1 TST R2 BEQ 5$ CLR R0 SEV 5$: RTS PC ; ; FORMAT EXPRESSION ; FMTEXP: JSR PC,CNXC ;SKIP BLANKS CMPB #'>,@R1 ;LOOK FOR NULL EXPRESSION BNE 3$ ;BR IF NOT NULL TRAP+144. ;NULL FORMAT EXPRESSION INC R1 ;IGNORE THE <> yNSV MOV (SP)+,R1 ;RESTORE TEXT POINTER 263 ;SET CARRY AND OVERFLOW RTS PC ;AND RETURN GCMP90: TST (SP)+ ;DISCARD SIGN POINTER MOVB (SP)+,NOCNSV GCMP92: MOV (SP)+,R1 SEV ;ERROR RETURN CLC ;TELL HIM IT WASN'T COMPLEX ANYWAY RTS PC .END zR0 ;SIX ADD #OVTAB,R0 ;GET WORKING ADDRESS MOV (R0)+,R2 ;GET START SEGMENT CMP BLKSIZ,#256. ;IS THIS A BIG BLOCK? BEQ INIT08 ;BR => 256. BMI INIT06 ;BR => 64. ASR R2 ;THIS IS 512. INIT08: ASR R2 ;YES, CONVERT ASR R2 ;TO BLOCK ADDRESS INIT06: ADD R2,TBLK ;GET ACTUAL DISK ADDRESS MOV #BEG,(R0) ;SAVE THE CORE START ADDRESS CMP (R0),LOWCOR ;IS THIS THE LOWEST ADDRESS YET? BHIS INIT07 ;NO MOV (R0),LOWCOR ;YES INIT07: MOV (R0),TBLK+2 ;PUT IT IN THE TRAN BLOCK ALSO MOV #OVLAY,R1 ;{OTOU1 ;YES BISB BITM+4,MISC ;NO, SET GENERATED FLAG JSR PC,OUTGL ;GENERATE THE GLOBAL JSR PC,EOL GOTOU1: JSR PC,OUTNAM ;GENERATE THE CALL JSR R5,OUTLN2 ;OUTPUT LINE TERMINATOR GOTOTX ;NOW PUT OUT THE NUMBER, CHECK AS WE GO JSR PC,OUTSL ;OUTPUT STATEMENT LABEL FROM SOURCE BVS GOTOER ;SOME ERROR BR GOTONE ;NORMAL EXIT - ALL OKAY! ; ; ERROR EXITS FOR GOTO ; GOTOET: TST (SP)+ ;POP TWO WORDS GOTOES: TST (SP)+ ;POP ONE WORD GOTOER: TRAP+52. |PAIR JMP FMT000 ;BACK TO MAIN SCAN ; ; HANDLE EXPRESSION ; 3$: MOV R3,-(SP) ;SAVE PAREN COUNT MOV R2,R4 ;OUTPUT THE < JSR PC,OUTCHR JSR R5,OUTLN2 +FMT005 ;CLOSE OUT CURRENT TEXT JSR R5,OUTLN2 +FMT003 ;.EVEN JSR PC,SUBEXP ;PARSE EXPRESSION BIC #70000,2(SP) ;FORCE MODE TO INTEGER BIS #20000,2(SP) MOV R0,-(SP) ;NOTE FOR CLEANUP JSR PC,EXPGEN ;GENERATE CODE MOV @SP,SP ;CLEAR POLISH STACK TST (SP)+ ;PART OF CLEAR STEP JSR R5,OUTLN2 +FMT020 ;RETURN TO FORMAT AT RUN T~GET HIGH ADDRESS SUB (R0)+,R1 ;GET LENGTH IN BYTES ASR R1 ;CONVERT IT TO WORDS MOV R1,(R0)+ ;SAVE IT MOV R1,TBLK+4 ;SAVE IT ALSO IN THE TRAN BLOCK .TRAN #TLB,#TBLK ;WRITE OUT THE DATA .WAIT #TLB SUB R2,TBLK ;POINT TO BLOCK ZERO FO THE FILE MOV #LENGTH,TBLK+2 ;GET ADDRESS OF CONTROL BLOCK MOV #RDCNTX,TBLK+4 ;AND ITS LENGTH .TRAN #TLB,#TBLK ;WRITE OUT THE CONTROL BLOCK .WAIT #TLB .EXIT ; ; DIVIDE R3 BY R4 ; .GLOBL DIVX DIVX: MOV R5,-(SP) ;SAVE R5 CLR R5 ;PRE-CLEAR RESULT  ;"ILLEGAL SYNTAX" ; ; NORMAL EXIT FROM THIS MODULE ; GOTONE: JSR PC,EOL ;START HERE FOR NORMAL EXIT CLV ;DON'T TRY ASSIGNMENT RTS PC ; ; SOME TEXT FOR THESE GOTOES ; ; SYMBOLIC NAMES OF ASCII CONTROL CHARACTERS TAB=11 ;HORIZONTAL TAB LF=12 ;LINE FEED CR=15 ;CARRIAGE RETURN GOTOT0: .BYTE TAB .ASCII "$TR" .BYTE 0 GOTOTX: .BYTE 15,12,TAB,'. .BYTE 0 ; GOTOT3: .BYTE TAB .ASCII "$TRX" .BYTE 0 GOTOT4: .BYTE TAB .ASCII "." IME JSR R5,OUTLN2 +FMT004 ;.ASCII ... JSR PC,CNXC CMPB #'>,@R1 ;GOOD TERMINATOR? BEQ 1$ ;BR IF YES TRAP+143. ;MISSING > OR EXPRESSION ERROR BR 2$ 1$: INC R1 ;SKIP > 2$: MOV #40.,R5 ;RETURN TO MAIN SCAN MOV (SP)+,R3 JSR PC,CNXC ;DON'T ALLOW WITH HOLLERITH CMPB #'H,@R1 BNE 4$ ;BR IF OKAY TRAP+145. INC R1 4$: JMP FMT000 .NLIST BEX FMT020: .ASCII / .GLOBL $FMTRT/<15><12> .ASCII / $FMTRT/<15><12><0> FMT001: .ASCII / $TR/ .BYT .TITLE HDRGEN ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORP. ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS ; SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC. ; ; WRITTEN BY D. KNIGHT ; .GLOBL OTOA,CKOP,SCAN2A,GENLAB,OUTLN2,SEQSUP R0 = %0 R1 = %1 R2 = %2 R3 = %3 R4 = %4 R5 = %5 SP = %6 PC = %7 SPACE=40 ; HDR1: .ASCII / .TITLE / .BYTE 0 HDR2: .ASCII / .CSECT/ .BYTE 15,12 HDR2L = .-HDR2 HDR3: .ASCII / .GLOBL / .BYTE 0 HDR5: .ASCII /: JSR %4,$POLSH/ .BY TST R3 ;IS VALUE ZERO? BEQ D2 ;YES D1: INC R5 ;INCREMENT RESULT SUB R4,R3 ;SUBTRACT BGT D1 ;UNTIL .LE. ZERO MOV R5,R3 ;PLACE RESULT IN R3 D2: MOV (SP)+,R5 RTS PC ;AND RETURN ; BLKSIZ: 0 ; TBLK: 0 ;START BLOCK 0 ;START CORE ADDRESS 0 ;WORD COUNT 2+.-. ;WRITE 0 ;RESERVED ; .END INIT .BYTE 0 GOTOT5: .BYTE TAB .ASCII "$TRA" .BYTE 0 GOTOT6: .BYTE TAB,'0,CR,LF,0 GOTOT7: .BYTE TAB .ASCII '$TRAL' .BYTE 0 .EVEN ; ; COMPUTED GOTO ; GOTOX: INC R1 ;ADVANCE R1 PAST ( CLR R0 ;WILL COUNT THE NUMBER OF LABELS IN R0 MOV R1,-(SP) ;SAVE CURRENT R1 GOTOX1: JSR PC,SKPSL ;SKIP LABEL INC R0 ;COUNT MOVB (R1)+,R2 CMPB R2,#', BEQ GOTOX1 ;MORE LABELS TO COME CMPB R2,#') BNE GOTOES ;") MISSING" ;R0 NOW HAS NUMBER OF LABELSE 0 FMT004: .ASCII / .ASCII ^/ .BYTE 0 FMT005: .ASCII /^/ .BYTE 15,12,0 FMT003: .ASCII / .EVEN/ .BYTE 15,12,0 CLIST: .BYTE '(,'),'','.,',,'/,'-,'<,'A .BYTE '0,'9,'D,'E,'F,'G,'I,'O,'L .EVEN .END TE 15,12 .ASCII / .GLOBL $POLSH,$NAM/ .BYTE 15,12 .ASCII / $NAM,0,0,/ .BYTE 0 HDR4: .ASCII / .GLOBL $SEQ/ .BYTE 15,12,0 .EVEN ; .GLOBL HDRGEN,HDR,OUTLN2,SYM1WD,OUTST,EOL .GLOBL HEAD,HLGT,OUTLN,HDR2,HDR2L,BLKDAT .GLOBL OUTOCT,OUTCH2 ; ; HDRGEN - HEADER GENERATOR AND PROTOTYPES. UPON ENTRY ; R0 POINTS TO HEADER NAME. ; REGISTERS CHANGED - R1,R4,R5. ; HDRGEN: INC HDR ;SET HEADER GENERATED FLAG JSR R5,OUTLN2 ;OUTPUT THE NAME HDR1 SUB # GOTOX2: MOV R0,-(SP) ;SAVE FOR NOW JSR PC,CNXC ;SKIP OPTIONAL, CMPB #',,@R1 BNE GOTOX3 INC R1 ;NOW GET VARIABLE NAME GOTOX3: JSR PC,GETLBV ;GET INDEX VARIABLE BVS GOTOET ;GET ERROR => PUNT TSTB @R1 ;THAT SHOULD BE ALL:EOL EXPECTED BNE GOTOET ;NOT SO => ERROR JSR PC,GOVAL ;GENCODE VALUE TO STACK MOV #GOTOT3,R4 ;GENCODE INVOKE SERVICER JSR PC,PUTNAM ;$TRX BITB BITM+5,MISC ;WAS A $TRX GLOBAL PREV. GEN.?? BNE GOTOX4 ;YES BISB BITM+5,MISC ;NO JSR PC,OUTGL ;GENERATSYM1WD,R0 JSR PC,OUTST JSR PC,EOL MOV #HEAD,R4 MOV #HLGT,R5 JSR PC,OUTLN MOV #HDR2,R4 ;OUTPUT THE MOV #HDR2L,R5 ;REMAINDER JSR PC,OUTLN ;OF HEADER TST BLKDAT ;BLOCK DATA? BNE HDRE1 ;YES, SKIP REST OF FORMALITIES!! JSR R5,OUTLN2 HDR3 JSR PC,OUTST ;NAME JSR PC,EOL JSR PC,OUTST ;NAME AGAIN JSR R5,OUTLN2 HDR5 ADD #SYM1WD,R0 MOV (R0)+,R3 ;GET FIRST WORD OF NAME JSR PC,OUTOCT ;OUTPUT IT JSR R5,OUTCH2 ', MOV (R0)+,R3 ;OUTPUT JSR PC,OUTOCT ;SECOND WORD JSR PC,EO .TITLE HEAD00 .IDENT /0506/ ; ;COPYRIGHT 1971, 1972, 1973 DIGITAL EQUIPMENT CORP. ; ; WRITTEN BY D. KNIGHT ; ; ;THIS ROUTINE CONTAINS ALL THE INFORMATION REQUIRED ; TO LINK TOGETHER AND INTERCONNECT THE VARIOUS ; OVERLAYS. THE FIRST WORD CONTAINS THE OVERLAY ; NUMBER OF THIS ROUTINE. ; .GLOBL OVLIST BEG: OVLIST: .BYTE 0,4 ;OVERLAY 0, MAX OVERLAY 4 DESCR ;ADDRESS OF DESCRIPTION LIST TRNVEC ;ADDRESS OF TRANSFER VECTOR ;OVERLAY 0 TRANSFER VECTORS ; .GLOBL END,ENDPRO,SYN3ER,TFUN E THE GLOBAL JSR PC,EOL GOTOX4: JSR PC,OUTNAM ;GENERATE THE NAME JSR PC,OUTCOM ;OUTPUT A COMMA MOV (SP)+,R3 ;THE LABEL COUNT NEXT OUT JSR PC,OUTOCT JSR PC,EOL ;CLOSE THE LINE MOV (SP)+,R1 ;BEGINNING OF LABEL LIST JSR PC,GOLABS ;OUTPUT THE LABEL LIST JMP GOTONE ;GETTING HERE MEANS SUCCESS! ; GOVAL ; ; GENCODE TO GET VALUE TO STACK FOR USE ; BY GOTO SERVICERS. CHECKS ARE MADE TO ; VERIFY VARIABLE IS NOT DIMENSIONED AND ; IS AN INTEGE .TITLE HEAD01 .IDENT /0506/ ; ;COPYRIGHT 1971, 1972, 1973 DIGITAL EQUIPMENT CORP. ; ; WRITTEN BY D. KNIGHT ; ;THIS ROUTINE CONTAINS ALL THE INFORMATION REQUIRED ; TO LINK TOGETHER AND INTERCONNECT THE VARIOUS ; OVERLAYS. THE FIRST WORD CONTAINS THE OVERLAY ; NUMBER OF THIS ROUTINE. ; .GLOBL OVLIST BEG: OVLIST: .BYTE 1,4 ;OVERLAY 1, MAX OVERLAY 4 DESCR ;ADDRESS OF DESCRIPTION LIST TRNVEC ;ADDRESS OF TRANSFER VECTOR ; ;DUMMY ENTRY TO REMOVE LINKER ERROR ; .GLOBL RSET RSET: ; L TSTB SEQSUP ;SUPPRESS SEQUENCING? BNE HDRE1 ;YES JSR R5,OUTLN2 ;OUTPUT HDR4 ; EXTRA GLOBL HDRE1: RTS PC .END ; ; GENERATE STATEMENT LABEL FOR EXECUTABLE STATEMENT ; GENLAB: TST INHLAB ;IS THE LABEL NEEDED OR DESIRED? BNE LABEZ ;NOT AT ALL MOV R3,-(SP) MOV R4,-(SP) MOV #LINENO,R4 ;GET ADDRESS OF LINE NUMBER TSTB @R4 ;IS THERE A LINE NUMBER BEQ LABEX ;NO JSR R5,OUTCH2 ;OUTPUT A . '. JSR R5,OUTLN2 ;AND A LINE NUMBER LINENO  .GLOBL BACKSP,REWIND,ENDFIL TRNVEC: END ENDPRO SYN3ER TFUN BACKSP REWIND ENDFIL ; .GLOBL DESCR,DISP,JLIST ; DESCR: ; ;SCANNR .BYTE 6,0,0 ;OVERLAY 1, ENTRY 0, NO RETURN ;RETURN .BYTE 14,4,1 ;OVERLAY 2, ENTRY 2, RETURN ;PALFTN .BYTE 30,0,1 ;OVERLAY 4, ENTRY 0, RETURN ;ALOCAT .BYTE 6,2,1 ; .EVEN .GLOBL SCANNR,RETURN,PALFTN,ALOCAT ALOCAT: INC DISP PALFTN: INC DISP RETURN: INC DISP SCANNR: JMP JLIST ;GOTO OVERLAY HANDLER ; . = BEG+240 ; .END R TYPE. ; ; INPUT: CURSYM POINTS TO STE (SET UP BY GETLBV) ; OUTPUT: TO OBJECT DEVICE - CODE TO MOVE VALUE TO STACK ; REGISTERS CHANGED: R0,R2,R3,R4,R5 ; ;TWO CASES: A PARAMETER OR NOT GOVAL: MOV CURSYM,R0 GONOP: JSR PC,OUTTAB MOV CURSYM,R0 BIS #PSHMKM,PSHWD(R0) ;SET PUSH FLAG MOV SERWD(R0),R3 BIC #SERMK,R3 MOV #'P,R0 JSR PC,OUTSER JSR PC,EOL RTS PC ; ; OUTPUT THE LABELS ; GOLABS: JSR R5,OUTLN2 GOTOT4 JSR PC,OUTSL ;OUTPUT LABEL GOTERR: BVS GOTOER ;A LABEL ERROR ;OVERLAY 1 TRANSFER VECTORS ; .GLOBL SCANNR,ALOCAT TRNVEC: SCANNR ALOCAT ; ;OVERLAY 1 JUMP LIST ; ;NULL FOR NOW ; ;OVERLAY 1 INTERNAL DISPATCH TABLE ; .GLOBL NEXJMP,BJMP,SUBROU,FUNCTI,BLOCKD .GLOBL EXTERN,DEFINE,DIMENS,COMMON .GLOBL EQUIVA,DATA,SCAN18,END ; NEXJMP: SUBROU FUNCTI BLOCKD EXTERN DEFINE BJMP: DIMENS COMMON EQUIVA DATA SCAN18 ;SPECIAL HANDLING FOR "IMPLICIT" END ; .GLOBL DESCR,DISP,JLIST ; DESCR: ; ;SYN3ER .BYTE 0,4,1 ;OVERLAY 0, ENTRY 2, RETURN MOV #TERM,R4 ;GET TERMINATOR LABEY: JSR PC,OUTLN1 ;OUTPUT IT MOV SEQNO,R3 JSR PC,OUTOCT JSR PC,EOL MOV (SP)+,R4 MOV (SP)+,R3 LABEZ: RTS PC TERM: .ASCII /: $SEQ,/ .BYTE 0 .EVEN LABEX: MOV #TERM+1,R4 BR LABEY ; ; HDRGEN - HEADER GENERATOR AND PROTOTYPES. UPON ENTRY ; R0 POINTS TO HEADER NAME. ; REGISTERS CHANGED - R1,R4,R5. ; HDRGEN: INC HDR ;SET HEADER GENERATED FLAG JSR R5,OUTLN2 ;OUTPUT THE NAME HDR1 SUB #SYM1WD,R0 JSR PC,OUTST JSR PC,EOL MOV #HEAD,R4 MOV #HLGT JSR PC,EOL CMPB #',,(R1)+ BEQ GOLABS ;BACK TO NEXT ONE DEC R1 ;R1 POINTS TO TERMINAL CHAR RTS PC ; ; ASSIGNED GOTO ; GOTOA: JSR PC,GETLBV BVS GOTERR ;REPORT ERROR JSR PC,GOVAL ;GENCODE FOR VALUE MOV CURSYM,R0 BIS #ASGMKM,ASGWD(R0) ;MARK USED IN ASSIGN/GOTO ; ; MUST BE END-OF-LINE OR , TO BE LEGAL ; TSTB @R1 BEQ GOTOA1 ;HAVE EOL CMPB #',,@R1 ;SKIP COMMA BEFORE LIST BNE GOTOEX ;NO COMMA TO SKIP:ERROR JSR PC,CNXC1 ;SKIP TH ;END .BYTE 0,0,1 ;OVERLAY 0, ENTRY 0, RETURN ;ENDPRO .BYTE 0,2,0 ;OVERLAY 0, ENTRY 1, NO RETURN ;EXECUT .BYTE 14,0,0 ;OVERLAY 2, ENTRY 0, NO RETURN ;EXPGEN .BYTE 14,10,1 ;OVERLAY 2, ENTRY 4, RETURN ;SUBEXP .BYTE 14,6,1 ;OVERLAY 2, ENTRY 3, RETURN ; .EVEN .GLOBL SYN3ER,END,ENDPRO,EXECUT,SUBEXP,EXPGEN SUBEXP: INC DISP EXPGEN: INC DISP EXECUT: INC DISP ENDPRO: INC DISP END: INC DISP SYN3ER: JMP JLIST ;GOTO OVERLAY HANDLER . = BEG+240 .END ,R5 JSR PC,OUTLN MOV #HDR2,R4 ;OUTPUT THE MOV #HDR2L,R5 ;REMAINDER JSR PC,OUTLN ;OF HEADER TST BLKDAT ;BLOCK DATA? BNE HDRE1 ;YES, SKIP REST OF FORMALITIES!! JSR R5,OUTLN2 HDR3 JSR PC,OUTST ;NAME JSR PC,EOL JSR PC,OUTST ;NAME AGAIN JSR R5,OUTLN2 HDR5 ADD #SYM1WD,R0 MOV (R0)+,R3 ;GET FIRST WORD OF NAME JSR PC,OUTOCT ;OUTPUT IT JSR R5,OUTCH2 ', MOV (R0)+,R3 ;OUTPUT JSR PC,OUTOCT ;SECOND WORD JSR PC,EOL HDRE1: RTS PC ; ; GENERATE STATEMENT LABEL FOR EXECUTABLE S .TITLE HEAD02 .IDENT /0506/ ; ;COPYRIGHT 1971, 1972, 1973 DIGITAL EQUIPMENT CORP. ; ; WRITTEN BY D. KNIGHT ; ; ;THIS ROUTINE CONTAINS ALL THE INFORMATION REQUIRED ; TO LINK TOGETHER AND INTERCONNECT THE VARIOUS ; OVERLAYS. THE FIRST WORD CONTAINS THE OVERLAY ; NUMBER OF THIS ROUTINE. ; .MCALL .PARAM .PARAM .GLOBL OVLIST BEG: OVLIST: .BYTE 2,4 ;OVERLAY 2, MAX OVERLAY 4 DESCR ;ADDRESS OF DESCRIPTION LIST TRNVEC ;ADDRESS OF TRANSFER VECTOR ; ;DISPATCH ROUTINES FOR EXECUTABLESE COMMA GOTOA3: CMPB #'(,@R1 ;LOOK FOR LABEL LIST BEQ GOTOA2 ;BR => LOOKS GOOD SOFAR BR GOTOEX ;ERR0R - NO ( FOR LABEL LIST ; ; ASSIGNED GOTO WITH CHECK LIST ; GOTOA2: INC R1 ;SKIP OVER THE ( MOV #GOTOT7,R4 JSR PC,PUTNAM BITB BITM+6,MISC BNE GOTOA4 BISB BITM+6,MISC ;SET GLOBAL FLAG JSR PC,OUTGL ;GENERATE THE GLOBAL JSR PC,EOL GOTOA4: JSR PC,OUTNAM ;OUTPUT THE NAME JSR PC,EOL JSR PC,GOLABS ;OUTPUT THE LABEL LIST CMPB #'),@R1 ;MUST CLOSE WITH ) BNE GOTOEX ;ERROR - NO TATEMENT ; GENLAB: TST INHLAB ;IS THE LABEL NEEDED OR DESIRED? BNE LABEZ ;NOT AT ALL MOV R3,-(SP) MOV R4,-(SP) MOV #LINENO,R4 ;GET ADDRESS OF LINE NUMBER TSTB @R4 ;IS THERE A LINE NUMBER BEQ LABEX ;NO JSR R5,OUTCH2 ;OUTPUT A . '. JSR R5,OUTLN2 ;AND A LINE NUMBER LINENO MOV #TERM,R4 ;GET TERMINATOR LABEY: JSR PC,OUTLN1 ;OUTPUT IT MOV SEQNO,R3 JSR PC,OUTOCT JSR PC,EOL MOV (SP)+,R4 MOV (SP)+,R3 LABEZ: RTS PC TERM: .ASCII /: $SEQ,/ .BYTE 0 .EVEN LABEX: MOV #TERM+1 AND LOGICAL 'IF' ; .GLOBL EXDSP,EXRET,IFDSP,IFRET EXDSP: JSR PC,@EXJMP(R0) ;DISPATCH TO EXECUTABLE JMP EXRET ;RETURN TO MODULE 'EXECUT' IFDSP: JSR PC,@IFJMP(R0) ;DISPATCH TO LOGICAL 'IF' SUBSTATEMENT JMP IFRET ;RETURN TO MODULE 'IF' ; ;DUMMY ENTRY TO REMOVE LINKER ERROR ; .GLOBL RSET RSET: ; ;OVERLAY 2 TRANSFER VECTORS ; .GLOBL EXECUT,RETURN,SUBEXP,EXPGEN,OVJMP,ASGN TRNVEC: EXECUT ENDFIL RETURN SUBEXP EXPGEN OVJMP ASGN ; ;OVERLAY 2 JUMP LIST ; ;NULL FOR NOW ;) JSR R5,OUTLN2 GOTOT6 JMP GOTONE ;ALL EXIT HAPPY ; ; ASSIGNED GOTO WITHOUT CHECK LIST ; GOTOA1: MOV #GOTOT5,R4 JSR PC,PUTNAM BITB BITM+7,MISC ;CHECK FOR GLOBAL NEEDED BNE GOTOA5 ;NOT NEEDED BISB BITM+7,MISC ;SET FOUND FLAG JSR PC,OUTGL ;GELERATE THE GLOBAL JSR PC,EOL GOTOA5: JSR PC,OUTNAM ;GENERATE THE NAME JSR PC,EOL JMP GOTONE ;NORMAL EXIT ; ; A LONG LINK TO THE ERROR REPORTERS ; GOTOEX: JMP GOTOER ; ; SKIP OVER A STATEME .TITLE HEAD03 .IDENT /0506/ ; ;COPYRIGHT 1971, 1972, 1973 DIGITAL EQUIPMENT CORP. ; ; WRITTEN BY D. KNIGHT ; ; ;THIS ROUTINE CONTAINS ALL THE INFORMATION REQUIRED ; TO LINK TOGETHER AND INTERCONNECT THE VARIOUS ; OVERLAYS. THE FIRST WORD CONTAINS THE OVERLAY ; NUMBER OF THIS ROUTINE. ; .MCALL .PARAM .PARAM .GLOBL OVLIST BEG: OVLIST: .BYTE 3,4 ;OVERLAY 3, MAX OVERLAY 4 DESCR ;ADDRESS OF DESCRIPTION LIST TRNVEC ;ADDRESS OF TRANSFER VECTOR ; ;DISPATCH ROUTINES FOR EXECUTABLES,R4 BR LABEY ; ; HDRGEN - HEADER GENERATOR AND PROTOTYPES. UPON ENTRY ; R0 POINTS TO HEADER NAME. ; REGISTERS CHANGED - R1,R4,R5. ; HDRGEN: INC HDR ;SET HEADER GENERATED FLAG JSR R5,OUTLN2 ;OUTPUT THE NAME HDR1 SUB #SYM1WD,R0 JSR PC,OUTST JSR PC,EOL MOV #HEAD,R4 MOV #HLGT,R5 JSR PC,OUTLN MOV #HDR2,R4 ;OUTPUT THE MOV #HDR2L,R5 ;REMAINDER JSR PC,OUTLN ;OF HEADER TST BLKDAT ;BLOCK DATA? BNE HDRE1 ;YES, SKIP REST OF FORMALITIES!! JSR R5,OUTLN2 HDR3 JSR PC,OUTST ;NAM ;OVERLAY 2 INTERNAL DISPATCH LIST ; .GLOBL END,DO .GLOBL CALL,CONTIN,RETURN,IF,READ,PRINT,WRITE .GLOBL FIND,ENCODE,DECODE ; EXJMP: END OV3JMP DO OV3JMP IFJMP: OV3JMP CALL CONTIN RETURN OV3JMP IF OV3JMP OV3JMP READ PRINT WRITE ENCODE DECODE REWIND BACKSP FIND ; .GLOBL DESCR,DISP,JLIST ; DESCR: ; ;SCANNR .BYTE 6,0,0 ;OVERLAY 1, ENTRY 0, NO RETURN ;SYN3ER .BYTE 0,4,1 ;OVERLAY 0,ENTRY 2, RETURN ;END .BYTE 0,0,1 ;OVERLAY 0, ENTRY 0, RETURN ;ALOCATNT LABEL ; SKPSL1: INC R1 ;LOOP LOCATION SKPSL: JSR PC,CNXC ;ENTRY POINT LOCATION JSR PC,CHTEST BMI SKPSL1 ;DIGIT => KEEP SCANNING TSTB @R1 ;ELSE RETURN-SET STATUS RTS PC ;FOR ZERO TEST AFTER RETURN ; ; GETLBV ; ;GET LABEL VARIABLE GETLBV: JSR PC,GET BVS GETLV9 CMP #2,R2 ;MUST BE AN INTEGER BNE GETLV9 ;NO => ERROR TST R3 ;MUST BE A VARIABLE BNE GETLV9 ;NO => ERROR MOV CURSYM,R3 BIT DIMWD(R3),#DIMMKM ;NOT DIMENSIONED? BNE GETLV9 ;BR => ERROR JSR PC,CNXC ;SET U AND LOGICAL 'IF' ; .GLOBL EXDSP,IFDSP,EXRET,IFRET EXDSP: JSR PC,@EXJMP(R0) ;DISPATCH TO EXECUTABLE JMP EXRET ;RETURN TO MODULE 'EXECUT' IFDSP: JSR PC,@IFJMP(R0) ;DISPATCH TO LOGICAL 'IF' SUBSTATEMENT JMP IFRET ;RETURN TO MODULE 'IF' ; ;DUMMY ENTRIES TO REMOVE LINKER ERROR ; .GLOBL RSET,ASGN8,ASGN9,CALL03,CALL05 .GLOBL LIST99 ASGN8:ASGN9:CALL03:CALL05: LIST99:RSET: ; ;OVERLAY 2 TRANSFER VECTORS ; .GLOBL OVJMP TRNVEC: OVJMP ; ;OVERLAY 2 JUMP LIST ; ;NULL FOR NOW ; ;OVEE JSR PC,EOL JSR PC,OUTST ;NAME AGAIN JSR R5,OUTLN2 HDR5 ADD #SYM1WD,R0 MOV (R0)+,R3 ;GET FIRST WORD OF NAME JSR PC,OUTOCT ;OUTPUT IT JSR R5,OUTCH2 ', MOV (R0)+,R3 ;OUTPUT JSR PC,OUTOCT ;SECOND WORD JSR PC,EOL HDRE1: RTS PC  .BYTE 6,2,1 ;OVERLAY 1, ENTRY 1, RETURN ;ENDPRO .BYTE 0,2,0 ;OVERLAY 0, ENTRY 1, NO RETURN ;TFUN .BYTE 0,6,1 ;OVERLAY 0, ENTRY 3, RETURN ;ENDFIL .BYTE 0,14,1 ;OVERLAY 0, ENTRY 6, RETURN ;OV3JMP .BYTE 22,0,0 ;OVERLAY 3, ENTRY 0, NO RETURN ;REWIND .BYTE 0,12,1 ;OVERLAY 0, ENTRY 5, RETURN ;BACKSP .BYTE 0,10,1 ;OVERLAY 0, ENTRY 4, RETURN ; .EVEN .GLOBL SCANNR,SYN3ER,END,ALOCAT,ENDPRO,TFUN .GLOBL ENDFIL BACKSP: INC DISP REWIND: INC DISP OV3JMP: INC DISP ENDFIL: INC DISP TFUN: IP R1 FOR NEXT CHAR CLV ;CLEAR ERROR FLAG RTS PC GETLV9: SEV ;SET ERROR FLAG - NOT INTEGER VAR RTS PC ; ;ASSIGN STATEMENT ; ASSIGN: JSR PC,ZLEQLS ;LOOK FOR ZERO LEVEL = BCC ASSI02 ;C CLEAR => NOT FOUND SEV ;FOUND => TRY AS ASSIGNMENT RTS PC ASSI02: JSR PC,GENLAB MOV R1,-(SP) ;SAVE CURRENT R1 JSR PC,SKPSL ;SKIP OVER LABEL JSR PC,CNXC ;LOOK FOR "T0" CMPB #'T,(R1)+ ; BNE ASSIER JSR PC,CNXC CMPB #'O,(R1)+ BEQ ASSI01 ; ; RLAY 2 INTERNAL DISPATCH LIST ; .GLOBL FORMAT,GOTO,PAUSE,STOP .GLOBL DEFINE,IF,ASSIGN ; EXJMP: END FORMAT OV2JMP DEFINE IFJMP: ASSIGN OV2JMP OV2JMP OV2JMP GOTO IF PAUSE STOP OV2JMP OV2JMP OV2JMP OV2JMP OV2JMP REWIND BACKSP OV2JMP ; .GLOBL DESCR,DISP,JLIST ; DESCR: ; ;SCANNR .BYTE 6,0,0 ;OVERLAY 1, ENTRY 0, NO RETURN ;SYN3ER .BYTE 0,4,1 ;OVERLAY 0,ENTRY 2, RETURN ;ALOCAT .BYTE 6,2,1 ;OVERLAY 1, ENTRY 1, RETURN ;OV2JMP .BYTE 14,12,0 ;OVERLAY 2, ENC DISP ENDPRO: INC DISP ALOCAT: INC DISP END: INC DISP SYN3ER: INC DISP SCANNR: JMP JLIST ;GO TO OVERLAY HANDLER . = BEG+240 .END  ERROR IN ASSIGN ; ASSIER: TST (SP)+ ;CLEAR STACK ASSI90: TRAP+52. ASSINE: JSR PC,EOL ;COME HERE FOR NORMAL EXIT CLV RTS PC ;FOUND "T0" OKAY ASSI01: JSR PC,GETLBV ;COLLECT A LABEL VARIABLE BVS ASSIER ;GET ERROR => PUNT TSTB @R1 ;MUST BE ALL BNE ASSIER ; ;THERE REMAIN 2 CASES ; VARIABLE IS A PARAMETER OR NOT ; MOV CURSYM,R0 ;POINTER TO SYMBOL TABLE BIS #ASGMKM,ASGWD(R0) ;MARK USED IN ASSIGN/GOTO BIT PARWD(R0),#PARMKM ;LOOK AT PAR BIT BEQ ASSINP ;BR => NOT PARAMETER NTRY 5, NO RETURN ;TFUN .BYTE 0,6,1 ;OVERLAY 0, ENTRY 3, RETURN ;ASGN .BYTE 14,14,1 ;OVERLAY 2, ENTRY 6, RETURN ;REWIND .BYTE 0,12,1 ;OVERLAY 0, ENTRY 5, RETURN ;BACKSP .BYTE 0,10,1 ;OVERLAY 0, ENTRY 4, RETURN ;ENDPRO .BYTE 0,2,0 ;OVERLAY 0, ENTRY 1, NO RETURN ;END .BYTE 0,0,1 ;OVERLAY 0, ENTRY 0, RETURN ; .EVEN .GLOBL SCANNR,SYN3ER,ALOCAT,TFUN,ASGN,ENDPRO END: INC DISP ENDPRO: INC DISP BACKSP: INC DISP REWIND: INC DISP ASGN: INC DISP TFUN: INC DISP OV2JMP: INC DISP ALOCAT:  .TITLE HEAD04 .IDENT /0610/ ; ;COPYRIGHT 1971, 1972, 1973 DIGITAL EQUIPMENT CORP. ; ; WRITTEN BY D. KNIGHT ; ; ;THIS ROUTINE CONTAINS ALL THE INFORMATION REQUIRED ; TO LINK TOGETHER AND INTERCONNECT THE VARIOUS ; OVERLAYS. THE FIRST WORD CONTAINS THE OVERLAY ; NUMBER OF THIS ROUTINE. ; .GLOBL OVLIST .PSECT ZZZAAA BEG: OVLIST: .BYTE 4,4 ;OVERLAY 4, MAX OVERLAY 4 DESCR ;ADDRESS OF DESCRIPTION LIST TRNVEC ;ADDRESS OF TRANSFER VECTOR ; ;DUMMY ENTRY TO REMOVE LINKER ERROR ; .GLOB; ; PARAMETER CASE ; MOV #ASSIT0,R4 ;SERVICER MOVB BITM+0,R3 ;GET MASK MOV #ASSIG1,R2 ;COMPLETION OF THIS STATEMENT BR ASSIG3 ; ; NON-PARAMETER CASE ; ASSINP: MOV #ASSIT2,R4 ;SERVICER MOVB BITM+1,R3 ;GET MASK MOV #ASSIG2,R2 ;COMPLETION ; ;COMMON SECTION ; ASSIG3: JSR PC,PUTNAM ;GET THE NAME BITB R3,MISC+1 ;DO VE HAF TO GENERATE GLUBL BNE ASSIG4 ;NINE? BISB R3,MISC+1 ;SET GENERATED FLAG JSR PC,OUTGL ;OUTPUT THE GLOBAL JSR PC,EOL INC DISP SYN3ER: INC DISP SCANNR: JMP JLIST ;GO TO OVERLAY HANDLER . = BEG+240 .END L RSET RSET: ; ;OVERLAY 3 TRANSFER VECTORS ; .GLOBL PALFTN TRNVEC: PALFTN ; .GLOBL DESCR,DISP,JLIST ; DESCR: ; ; .EVEN ; . = BEG+240 ; .END  .TITLE IF .IDENT /0506/ ; ;COPYRIGHT 1971,1973, DIGITAL EQUIPMENT CORP. ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS ; SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC. ; ; WRITTEN BY L. COHEN, D. KNIGHT ; ; ;IF PROCESSOR ;IF IDENTIFIED BY "IF(". R1 POINTS BEYOND THE LEFT PAREN. ;UPON ENTRY. ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 .GLOBL CNXC1,SUBEXP,SCAN2A,EXPGEN,OUTLN,FLABL,IF,EOL .GLOBL CHTEST,OUTASSIG4: JSR PC,OUTNAM JSR R5,OUTLN2 ASSIT1 MOV (SP)+,R1 ;POP POINTER TO LABEL JSR PC,OUTSL ;GENCODE FOR LABEL BVS ASSI90 ;BR => ERROR JSR PC,EOL ;OUTPUT LINE TERMINATOR JSR R5,OUTCH2 ;AND A TAB ;TAB MOV CURSYM,R0 ;SYMBOL TABLE ENTRY ADDRESS JMP @R2 ;DISPATCH TO COMPLETION ; ; PARAMETER CASE ; ASSIG1: MOV PARXWD(R0),R3 ;PARAM NUMBER BIC #PARXMK,R3 ASL R3 JSR PC,OUTOCT ;PARAMETER INDEX ;ALL DONE SO EXIT BR ASSINE ; ; NON-PARAMETER CASE ; ASSIG2: JSR PC,OUTST ;OUSER,CNXC,OUTLN2 .GLOBL ASGN,IFTAB,SCAN2A,OTOA,GENLAB .GLOBL INHLAB,OUTCHR .GLOBL IFDSP,IFRET ; ; IF011A: JMP IF011 ;INTERMEDIATE HELP ; ; ; ; IF: JSR PC,SUBEXP MOV R2,-(SP) ;SAVE VITAL REGISTERS, 1ST EXP MOV R0,-(SP) JSR PC,CNXC MOV 2(SP),R2 ;RESTORE R2 CMPB (R1),#') ;IF TERM. NOT =")" THIS IS AN ILLEGAL IF BNE IF011A JSR PC,CNXC1 ;IF NEXT CH IS "=" THIS IS ;AN ASSIGNMENT STTEMENT CMPB (R1),#'= BEQ IF011A ;BR IF THIS IS AN ASSIGNMENT STTMNT ;PICK UP MODE OF EXPRESSION TPUT FROM ST BR ASSINE ; ; SOME TEXT FOR ASSIGN ; TAB =11 ASSIT0: .BYTE TAB .ASCII "$ASP" .BYTE 0 ASSIT2: .BYTE TAB .ASCII "$AS" .BYTE 0 ASSIT1: .BYTE 15,12,TAB,'.,0 ;HI THERE, LISTING READER .EVEN .END  .TITLE IMPLIC ; ;COPYRIGHT 1971, 1972, DIGITAL EQUIPMENT CORP. ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS ; SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC. ; ; WRITTEN BY D. KNIGHT ; ;IMPLICIT PROCESSOR - ENTERED WITH MODE IN LOW ORDER R0 ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 ; ; .GLOBL IMPLIC,IMPTAB,NXTCH,CHT1,SERIAL,SERATR .GLOBL DOLST ; IMPLIC: ASL R0 ;PLACE TYPE ASL R0 ;IN THE ASL R0 ;C .TITLE INIT ;COMPILER INITIALIZATION .IDENT /0611A/ ;LP ; ;COPYRIGHT 1971, 1972, 1973, DIGITAL EQUIPMENT CORP. ; ; WRITTEN BY D. KNIGHT ; ; .MCALL .CLOSE,.CSI1,.CSI2,.DELET,.EXIT,.INIT,.MONF,.PARAM .MCALL .OPEN,.READ,.RLSE,.RSTRT,.TMCVT,.TRAP,.WAIT,.WRITE .MCALL .CORE ; .GLOBL RSET,TTLCNT,OLDHGH,DOLST,DPTR .GLOBL EXIT .GLOBL ALOKAT,BUFIN,CMDBUF,COMCLR .GLOBL COMUN,ECNT,ENDCLR,EQVHED,ERRCUR,ERRS .GLOBL FLABL,GBUF,HEAD1,HLGT1,INHD,INPBLK .GLOBL ITOA,LINKI,LINKK,LINKL,LINKOL,LINKSL .GLO MOV R2,R5 SWAB R5 ;SHIFT TO LOW ORDER OF R5, ASR R5 ;MULTIPLIED BY 2 ASR R5 ASR R5 ASR R5 BIC #177770,R5 ;CLEAR ALL OTHER BITS ;R1 POINTS PAST THE ) JSR PC,CHTEST ;DOES LABEL FOLLOW? BMI IF04 ;THIS IS AN ARITHMETIC IF ; ; LOGICAL IF STATEMENT ; IF041: JSR PC,GENLAB ;GENERATE STATEMENT LABEL IF ANY ;FORCE TYPE OF RESULT TO BE LOGICAL CMP #1,R5 ;MUST BE LOGICAL BEQ 1$ TRAP+141. BIC #070000,6(SP) BIS #010000,6(SP) 1$: JSR PC,EXORRECT POSITION CLR R4 ;CLEAR ENTRIES MADE FLAG IMP01: JSR PC,NXTCH ;GET A NON-BLANK CHARACTER TST R2 ;IS IT ZERO? BEQ IMPEND ;YES , ALL IS DONE CMPB R2,#'( ;DID WE FIND A LEFT PAREN? BNE SINGLE ;NO JSR PC,NXTCH ;GET THE NEXT CHARACTER JSR PC,CHT1 ;IT MUST BE ALPHABETIC BVC ERROR ;IT WASN'T MOV R2,R3 ;SAVE IT JSR PC,NXTCH ;A "-" MUST COME NEXT CMPB R2,#'- ;WAS IT THERE? BNE SINGLF ;NO JSR PC,NXTCH ;TRY FOR ANOTHER ALPHABETIC JSR PC,CHT1 ;GOT IT? BVC ERROR ;NO CBL LSTBLK,LSTER,LSTEXT,OBJBLK,OBJER .GLOBL OBJEXT,OBJLS,OUTPUT,SCANNR,SRCIN .GLOBL SRCLS,STCLR,SYNERR,LOWCOR .GLOBL SYMBAS,SYMEND,SYMCUR .GLOBL SERIAL,SRCERR,SRCEXT,IMPTAB .GLOBL ISW,SEQSUP,TYPSIZ,ARYCHK,ERRFLG,SWVAL .IF NDF COM8K .GLOBL LSW,OSW,LSTVAL,OLDLOW,FORMCH,SWDSC .ENDC .CSECT ; .PARAM ;REGISTER DEFS, ETC. ; TAB = 11 ;A TAB HAS THE VALUE 11 SPACE = 40 ;A SPACE IS A 40 ; .MACRO RLS EMT 7 .ENDM .MACRO INIT EMT 6 .ENDM .MACRO .CSI2X CSIBLK .CSI2 CSIBLK BPGEN ;GENER LOGICAL EXPRESSION ;GENERATE CODE FOR THE CALL TO THE OTS COMPARISON ROUTINE ;GENERATE ".GLOBL $TRTST" MOV #IF800,R4 ;GET ADDR OF ASCII STRING MOV #IF802-IF800,R5 ;SIZE OF STRING FOR .GLOBL DECLA JSR PC,OUTLN JSR PC,EOL ;OUTPUT CR/LF MOV #IF802-IF801,R5 MOV #IF801,R4 JSR PC,OUTLN JSR PC,EOL ;OUTPUT CR/LF ;NEXT GENERATE "JUMP OVER" ADDRESS FOR THE "FALSE" RETURN. .GLOBL OUTTAB JSR PC,OUTTAB ;WRITE A TAB TO OBJECT FILE ; MOV FLABL,R3 ;GET A SERIAL# MOV R3,-(SP) ; .TITLE IOLIST .IDENT /0711A/ ;DK,RG ; ;COPYRIGHT 1971,1973 DIGITAL EQUIPMENT CORP. ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS ; SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC. ; ; .GLOBL GL1,PUTCHR,OUTLN2,CHT1 .GLOBL END1,GET,ZLEQLS,GENLAB,NXTCH .GLOBL PUTNAM,BITM,MISC,OUTGL,EOL .GLOBL OUTNAM,OUTCOM,CURSYM,OUTST,OUTLN1 .GLOBL PARMKM,PARWD,PARXWD,OUTSER .GLOBL PARCNT,DOTMP,DONUM,LINENO,DODON .GLOBL PSHMKM,PSHWD R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=MP R2,R3 ;ARE THEY IN ASCENDING SEQUENCE? BLT ERROR ;NO JSR PC,ENTER ;GO ENTER THE VARIOUS TYPES JSR PC,NXTCH ;LOOK FOR ANOTHER PAREN CMPB R2,#') ;FOUND IT? BNE ERROR ;NO, GIVE ERROR CKCOM: JSR PC,NXTCH ;TRY FOR TERMINATOR TST R2 ;TERMINATOR? BEQ IMPEND ;YES CMPB R2,#', ;COMMA? BEQ IMP01 ;YES, GO LOOK FOR MORE ERROR: TRAP+77. ;WEIRD FORM IN IMPLICIT INC R4 ;FAKE AN ENTRY FOUND 4$: JSR PC,NXTCH ;GET A CHARACTER TST R2 ;END OF LINEIC #177774,(SP) .ENDM ; ; ALL OF FORTRAN STARTS HERE. THE THREE REQUIRED FILES ; ARE INITIALIZED AND A JUMP TO SCANNR IS MADE. ; RSET: .GLOBL OVNUM,DISP,TMPEND,TSTK .GLOBL OPTLEV,OPTLVL CLR OVNUM ;RESET CLR DISP ;THE OVERLAY MOV #TMPEND,TSTK ;CONTROLLER CLR CURLN ;CLEAR BUFFER FLAG FOR RESTART .GLOBL CURLN CLRB SEQSUP ;TURN OFF SEQUENCE SUPPRESS CLRB ARYCHK ;TURN OFF SUBSCRIPT CHECK MOV #OPTLEV,OPTLVL ;DEFAULT SPECIFIED AT LINK TIMESAVE SER.# MOVB #'F,R0 ;OUTPUT TO OBJECT DEVICE JSR PC,OUTSER JSR PC,EOL ;OUTPUT A CR.LF INC FLABL ;NOW IDENTIFY AND TRANSLATE THE STATEMENT IMBEDDED IN THIS IF. MOV #IFTAB,R0 ;ADDR OF TABLE OF EXECUTABLE PRO JSR PC,SCAN2A ;SEARCH TABLE FOR A MATCH BVS IF05 ;IF V=1, NO MATCH.TREAT AS ASSIGNMENT INC INHLAB ;SET "INHIBIT LABEL" SWITCH JMP IFDSP ;GO TO 'IF' DISPATCHING ROUTINE IFRET: ;RETURN HERE FROM 'IF' DISPATCHING .GLOBL GOFLG CLRB GOFLG ;DON'T GIVE EXTRANEOUS PATH ERROR%5 SP=%6 PC=%7 .NLIST BEX .GLOBL IOLIST .CSECT .GLOBL IOL,ARY001,STKCNT .GLOBL OUTOCT,LSTMOD,COUNT,DONUM,IOL ; ; IOLIST - I/O LIST PROCESSING IS DONE HERE ; IOLIST: MOV #100,DONUM JSR PC,LIST00 ;CALL THE FIRST PART OF LIST HANDLER MOV #-1,R2 ;FORCE FINAL JSR PC,TSTM01 ; I/O MOV #FIN00,R4 ;OUTPUT JSR PC,PUTNAM ;SAVE THE NAME BITB BITM+7,MISC+2 ;HAVE WE ALREADY DONE ONE? BNE LSTPR2 ;YES BISB BITM+7,MISC+2 ;SET DONE BIT JSR PC,OUTGL ;OUTPUT THE GLOBAL LSTPR2: JSR PC? BEQ IMPEND ;YES CMPB R2,#', ;COMMA FOUND BNE 4$ ;LOOP UNTIL FOUND BR IMP01 ;GO BACK TO MAIN LOOP SINGLF: CMPB R2,#') ;ALLOW A ) INSTEAD OF A - BNE ERROR ;NOT FOUND MOV R3,R2 ;FUDGE IT BR SINGLG ;AND CONTINUE SINGLE: JSR PC,CHT1 ;THE CHARACTER FOUND MUST BE ALPHA. BVC ERROR ;IT WASN'T MOV R2,R3 ;SET UP ENTER POINTERS SINGLG: JSR PC,ENTER ;AND ENTER THE VALUE BR CKCOM ;GO CHECK TERMINATOR IMPEND: TST R4 ;WERE ANY ENTRIES MAD MOV #400,SWVAL ;VALUE DEPENDENT ON SWITCH ;TABLE ORDER AT SWLST MOV #5,LINCNT ;RESET DEFAULT CONTINUATIONS MOVB #4,TYPSIZ+1 ;RESET THE COMPILER TO MOVB #4,TYPSIZ+2 ;NORMAL OPTIONS .GLOBL START .TRAP #0,#SYNERR ;SET UP TRAPS .RSTRT #START ;SET UP RESTART ADDRESS RSET01: MOV LOWCOR,SP ;GET ROOM TO WORK MOV #LINKL,-(SP) ;IS IT TST @(SP) ;ALREADY INITED? BEQ RSET02 ;NO RLS ;RELEASE IT BR RSET01 RSET02: MOV #LINKK,-(SP) TST @(SP) ; CLR INHLAB ;CLEAR "INHIBIT LABEL" SWITCH IF051: MOV (SP),R3 ;NOW GENERATE ON THE STACK THELABEL MOV #005015,-(SP) ;PUT LINE TERM. ON STACK SUB #10,SP ;MAKE SPACE FOR 6 BYTES MOV SP,R2 JSR PC,OTOA ;CONVERT SERIAL # TO ASCII MOV #"$F,(SP) ;MOVE IN PREFIX TO LABEL MOV #": ,6(SP) ;MOVE IN SUFFIX MOV SP,R4 ;SET UP CALLING SEQ TO OUTPUT SY MOV #12,R5 JSR PC,OUTLN ;OUT GOES THE LINE ;LOGICAL IF DONE. CLEAN UP STACK AND RETURN SUCCESSFULLY. MOV 14(SP),SP IF052: TST (SP)+ ;POP LA,OUTNAM ;OUTPUT THE NAME TSTB -(R1) BEQ LSTPR1 TRAP+12. LSTPR1: RTS PC ; ; THE FIRST PART OF THE LIST PROCESSING CHECKS FOR SIMPLE ; LIST ITEMS AND COMPILES THE CODE FOR THEM. IF, ; DURING THE SCAN, A LEFT PARENTHESIS IS ENCOUNTERED ; WHICH IS NOT PART OF A SUBSCRIPT, PART TWO OF THE ; PROCESSING IS CALLED WHICH IS USED TO HANDLE THE ; PARENTHESIZED OR DO IMPLYING LISTS. NOTE THAT ; PART TWO IS ALLOWED TO CALL PART ONE TO GET SIMPLE ; LISTS EVALUAE? BEQ ERROR ;NO JSR PC,UPDATE ;GO UPDATE EXISTING ENTRIES RTS PC ;AND RETURN ENTER: MOVB R0,IMPTAB-101(R3) ;SET PROPER TYPE INC R3 ;ADVANCE POINTER INC R4 ;UPDATE ENTRY MADE POINTER CMP R3,R2 ;DONE? BLOS ENTER ;NO RTS PC ;YES ; ;UPDATE IMPLICIT ENTRIES IN SYMBOL TABLE ; .GLOBL CURSYM,SYM1WD,UNPK00,DATYMM,DATYWD .GLOBL NAMSER,EXPMKM,EXPWD UPDATE: CLR R0 ;START OUT AT FIRST ENTRY 1$: INC R0 HOW ABOUT THIS ONE? BEQ RSET03 ;NOT THIS ONE RLS ;RELEASE IT BR RSET02 RSET03: JSR PC,RLSALL ;RELEASE EVERYTHING INIT INIT ;TELEPRINTER .GLOBL TTLCNT TSTB TTLCNT ;ISSUE TITLE? BNE FORT09 ;NO INCB TTLCNT MOV #HLGT1,R5 ;OUTPUT MOV #HEAD1,GBUF+6 ;THE MOV #DESC,R4 ;HEADING JSR PC,OUTPUT ;WHICH IS STORED IN THE TABLES FORT09: .IF NDF COM8K MOVB #15,FORMCH ;PRESET THE FORM CONTROL CHARACTER CLR LSW ;RESET LIST SWITCHES CLR OSW ST WORD OFF STACK CLV ;INDICATE SUCCESSFUL RETURN RTS PC ;EXIT IF05: INC INHLAB ;SET "INHIBIT LABEL" SWITCH JSR PC,ASGN ;TREAT WHAT FOLLOWS AS AN ASSIGN CLR INHLAB ;CLEAR "INHIBIT LABEL" SWITCH BR IF051 ; ;ARITHMETIC IF PROCESSOR ; IF04: MOV R5,-(SP) ;SAVE MODE ON STACK JSR PC,GENLAB ;GENERATE STATEMENT LABEL ETC. INCB GOFLG ;SET POSSIBLE PATH ERROR JSR PC,EXPGEN ;GENERATE CODE FOR SUBEXPRESSION MOV (SP)+,R0 ;PUT MODE IN R0 JSR R5,OUTLTED. ; .GLOBL LSTOUT,CUROUT LIST00: MOV #-1,LSTMOD ;CLEAR LAST MODE MOVB #-1,LSTOUT MOVB #-1,CUROUT CLR COUNT ;CLEAR DATA COUNT LIST10: JSR PC,NXTCH ;GET A CHARACTER TST R2 ;IS IT THE END? BEQ LIST05 ;YES LIST01: CMPB R2,#'( ;IS IT A LEFT PAREN? BNE LIST1E MOV #-1,R2 ;FORCE CURRENT I/O JSR PC,TSTM01 ;JUST IN CASE OF DO IMPLIED I/O JMP LIST04 ;YES, DISPATCH TO PART TWO LIST1E: DEC R1 ;BACK UP THE STRING POINTER LIST1A: JSR PC,GET ;GET A LIST ITEM BVS LIST2A ;ILLEGAL LIS;ADVANCE TO NEXT ENTRY CMP R0,SERIAL ;DONE? BGT 99$ ;YES JSR PC,SERATR ;GET SYMBOL LOCATION TST R3 ;IS THIS A VARIABLE? BMI 1$ ;IGNORE CONSTANT DEC R3 MOV R3,-(SP) MOV CURSYM,R3 ;GET ADDRESS OF ENTRY MOV R0,-(SP) ;SAVE R0 MOV R3,R0 ;SET UP ADD #SYM1WD,R0 ;FOR MOV R1,-(SP) ;CALL MOV #DOLST,R1 ;TO UNPACK JSR PC,UNPK00 ;DO THE UNPACK MOV #DOLST,R1 ;FIND OUT WHAT THE FIRST CHARACTER IS MOVB (R1),R2 ;AND PICK IT UP FOR AN INDEX CLR (R1) MOV (SP)+,R1 ;RESTORE MOV (SP) ;AND BINARY SWITCHES .ENDC CLR ISW ;RESET INPUT SWITCH LIST MOV #TEND,R5 ;GET COUNT MOV #TITLE,GBUF+6 MOV #DESC,R4 ;AND I/O DESCRIPTOR JSR PC,OUTPUT ;TELL USER WE ARE HERE .READ #LINKK,#INHD ;GET THE USER RESPONSE .WAIT #LINKK ;WAIT FOR THE USER RESPONSE BIT #060000,INHD+2 ;CHECK FOR EOF OR EOM BNE QUIT CMPB BUFIN,#15 ;IS IT A NULL LINE? BEQ FORT09 ;YES .CSI1 #CMDBUF ;INTERPRET THE COMMAND LINE MOV (SP)+,R1 ;IS IT OK?? BEQ FORT01 ;YES INC R1 ;APPEND MOVB #'?,(R1)+ N2 +IF90 ADD #MODTAB,R0 MOVB @R0,R4 BIC #177400,R4 MOV R4,-(SP) TSTB @R0 BPL 1$ TRAP+141. 1$: JSR PC,OUTCHR JSR PC,EOL JSR R5,OUTLN2 +IF91 MOV (SP)+,R4 JSR PC,OUTCHR JSR PC,EOL ;NOW FIND 3 DESTINATIONS FROM THE INPUT ;STRING AND OUTPUT EACH TO THE OBJECT DEVICE MOV #3,-(SP) ;SET UP LOOP COUNT FOR 3 STATEMENT LABELS IF045: MOV #005015,-(SP) ;PUT CR/LF ON STACK MOV #" ,-(SP) MOV #" ,-(SP) MOV #" ,-(SP) MOV SP,R5 MOV #027011,-(SP) ;PUT A TAB & A DOT ON STACK T ITEM TST R3 ;IS IT A CONSTANT? BMI LIST2A ;ILLEGAL LIST ITEM BGT ARRAY ;GO PROCESS ARRAY ITEM LIST1B: MOVB (R1)+,R3 CMPB R3,#' BEQ LIST1B CMPB R3,#'= BEQ LIST05 CLRB LSTOUT ;SET VARIABLE PUSH JSR PC,TSTMOD DEC R1 JSR PC,PVAR ;GENERATE VARIABLE PUSH BR LIST03 LIST3A: JSR PC,OUTSER ; PROTOTYPE JSR PC,EOL ;FOLLOWED BY AN END OF LINE LIST03: CLR IOL LIST3B: JSR PC,NXTCH ;GET THE NEXT CHARACTER TST R2 ;EXIT IF BEQ LIST05 ; +,R0 ;R0 AND R1 MOV (SP)+,R4 ;GET ARRAY FLAG JSR PC,CHT1 ;IS IT ALPHABETIC? BVC 1$ ;NOPE, MUST BE WEIRD BIT #EXPMKM,EXPWD(R3) ;EXPLICITLY TYPED? BNE 1$ ;YES MOVB IMPTAB-101(R2),R2 ;GET THE IMPLICIT TYPE SWAB R2 ;POSITION IT CORRECTLY TST R4 ;IS THIS AN ARRAY? BNE 3$ ;NO .GLOBL DATYMK MOV DATYWD(R3),R4 ;GET THE OLD TYPE BIC #DATYMK,R4 ;CLEAR OUT JUNK CMP R2,R4 ;DO THE TYPES STILL MATCH? BNE 98$ ;NO, FLAG AS ERROR 3$: BIC #DATYMM,DATYWD(R3) ;CLEAR THE OLD TYPE BIS R2,D; "?" AND MOVB #15,(R1)+ ;BLANK MOVB #12,(R1)+ ;LINE MOVB #12,(R1)+ ;TO MESSAGE SUB #BUFIN,R1 ;GET BYTE COUNT MOV R1,INHD+4 .WRITE #LINKL,#INHD ;OUTPUT THE ERROR BR FORT09 QUIT: .EXIT ;EXIT ON EOF OR EOM FTERR1: MOV #2203,R1 ;TOO MANY SWITCHES BR FTCOM FTERR2: MOV #2204,R1 ;TOO MANY OUTPUT FILES BR FTCOM FTERR3: MOV #2205,R1 ;NO INPUT OR TOO MUCH INPUT FTCOM: CLR -(SP) MOV R1,-(SP) IOT ;OUTPUT THE WORLD'S MOST USELESS DIAGNOSTIC BR FO JSR PC,ISTAT ;GET STATEMENT LABLE TST R4 ;CHECK FOR NO STTMNT FOUND BEQ IF042 IF044: MOV SP,R4 ;ELSE WRITE IT OUT MOV #12,R5 JSR PC,OUTLN IOF421: ADD #12,SP ;BACK UP THE STACK DEC (SP) ;REDUCE LOOP COUNT BEQ IF0431 ;EXIT IF 0. ELSE... CMPB (R1),#', ;DOES A COMMA FOLLOW? BNE IF046 ;IF NOT, ERROR JSR PC,CNXC1 ;ELSE STEP OVER COMMA BR IF045 ;3 STATEMENT LABELS HAVE BEEN PROCESSED. ;CLEAN UP AND GET OUT. IF0431: MOV 2(SP),SP ;POP EVERYTHING OFF STACK BR IF052 IF042: ADD #12,SP ;END OF LINE CMPB R2,#', ;WE MUST HAVE A COMMA IF NOT BNE LIST02 ; JSR PC,NXTCH ;GET ANOTHER CHARACTER BR LIST01 ;AND RE-LOOP LIST05: RTS PC LIST02: CMPB R2,#') BNE LIST2A DEC PARCNT BGE LIST3B CLR PARCNT LIST2A: TRAP+72. ;ILLEGAL LIST ITEM INC R1 ;SKIP OVER BAD ITEM BR LIST10 ;GO BACK TO BEGINNING LIST11: MOV #RPSH,R4 JSR PC,PUTNAM BITB BITM+1,GL1+4 ;CHECK FOR REGISTER PUSH GLOBAL BNE LIST12 BISB BITM+1,GL1+4 ;SET THE OUTPUT DONE FLAG JSR PC,OUTGL ;OUTPUT THE GLOBALATYWD(R3) ;SET UP THE NEW TYPE BR 1$ ;AND LOOP 98$: TRAP+137. ;IMPLICIT OCCURS TOO LATE IN LIFE BR 1$ 99$: RTS PC ;RETURN TO THE REAL WORLD ; .END RT09 FORT01: MOV #2,CMDBUF ;SET FOR OUTPUT .CSI2X #OBJBLK ;GET THE BINARY SPECIFICATION. .IF DF COM8K TST OBJEXT ;DO WE USE THE DEFAULT EXTENSION?? BNE FORT10 ;NO MOV FORT11,OBJEXT ;YES .ENDC FORT10: MOV (SP)+,R1 ;GET COUNT BEQ FORT02 ;GO GET LIST SPECIFICATION IF ZERO CMP R1,#2 ;OR TWO BGE FTERR1 ;TOO MANY SWITCHES CLR LINKSL+6 ;OTHERWISE NO LIST BR FORT05 FORT02: MOV #2,CMDBUF .CSI2X #LSTBLK ;GET THE LIST SPECIFICATION TST LSTECLEAN UP STACK IF046: TRAP +83. ;IMPROPER DESTINATION LABEL SEQU BR IF0431 IF043:IF010: SEV ;INDICATE UNSUCCESSFUL RETURN RTS PC IF011: MOV (SP),SP ;CLEAN UP STACK TST (SP)+ BR IF010 ; ;ISTAT GETS A STATEMENT # FROM THE SOURCE STRING. . ; (R1)=CURRENT CHAR. (1ST TO LOOK AT); SITS ON TERM AT END ; (R5)=WHERE RESULT SHOULD GO R4 CLOBBERED ISTAT: MOV R3,-(SP) ;SAVE R3 MOV R5,R3 ;SET LEADING ZERO FLAG CLR R4 ;INITIALIZE CH COUNT IST2: CMP R LIST12: JSR PC,OUTNAM ;NOW OUTPUT THE NAME BR LIST03 ; ARRAY PROCESSING ARRAY: CMP R3,#2 ;IS THIS A FUNCTION NAME? BEQ LIST02 ;YES, NOT ALLOWED ARR01: MOVB (R1)+,R3 CMPB R3,#' BEQ ARR01 CMPB R3,#'( ; AN ARRAY ELEMENT? BEQ ARYELE ;YES MOVB #-1,LSTOUT DEC R1 MOV #7,R2 ; NO, IT IS THE WHOLE ARRAY JSR PC,TSTMOD ;CHECK FOR COMPATIBLE MODE JSR R5,OUTLN2 ;OUTPUT THE ARRAY PUSH INIT07 MOV R0,R3 ;NOW DO MOV CURSYM,R0 ;SET GENERATE ADBXT ;DEFAULT EXTENSION?? BNE FORT13 ;NO MOV FORT12,LSTEXT ;YES FORT13: MOV (SP)+,R1 BEQ FTERR2 ;ERROR IF MORE FILES CMP R1,#2 ;TOO MANY ITEMS?? BGE FTERR1 ;YES FORT05: CLR CMDBUF ;LOOK .CSI2X #INPBLK ;GET THE INPUT SPECIFICATION TST LINKI+6 ;INPUT SPECIFIED?? BEQ FTERR3 ;NO TST SRCEXT ;EXTENSION SPECIFIED?? BNE FORT03 ;YES MOV FORT14,SRCEXT ;SPECIFY DEFAULT /FTN/ MOV #FORT04,SRCERR ;SET ERROR RETURN FORT03: MOV (SP)+,R1 ;ERROR IF4,#5 BEQ IST1 ;ARE WE DONE BECAUSE COUNT IS EX 2$: JSR PC,CHTEST ;NO, LOOK AT NEXT CH. BPL IST1 ;IF NOT DIGIT, EXIT CMP R3,R5 ;CHECK FOR LEADING ZEROS? BNE 1$ ;NO CMPB (R1),#'0 ;LEADING ZERO? BNE 1$ ;NO JSR PC,CNXC1 ;SKIP IT BR 2$ 1$: MOVB (R1),(R5)+ ;ELSE MOVE IT OUTPUT JSR PC,CNXC1 ;GET NEXT CH. INC R4 BR IST2 IST1: MOV (SP)+,R3 RTS PC ; ;CONSTANTS FOR GENERATING CODE TO CALL THE ;OTS ARITHMETIC COMPARISON ROUTINES ; IF90: .ASCII / .GLOBL/ IF91: .ASCII / $TS/ .BYTE BIT BIS #PSHMKM,PSHWD(R0) MOV #'A,R0 ;THE ADB ADDRESS BR LIST3A ;NOW GO BACK TO MAIN PROCESSING ARYELE: MOVB #1,LSTOUT JSR PC,TSTMOD INC IOL ; MOV SP,STKCNT ;REMEMBER STACK MOV R2,-(SP) ; AND THE MODE JMP ARY001 ;GO TO SUBSCRIPT RECOGNIZER ; ; PART TWO HANDLES PARENTHESES AND IMPLIED DO STATEMENTS ; BADLST: TRAP+90. ;BAD DOSPEC LIST5A: TST (SP)+ MOV (SP)+,R1 RTS PC LIST04: MOV R1,-(SP) ;SAVE THE TEXT POINTER CLR -(SP) ;CLEAR PAREN .TITLE IOPACK .IDENT /0610/ ;RFB 9-MAY-73 ; ;COPYRIGHT 1971, 1972, DIGITAL EQUIPMENT CORP. ; ; WRITTEN BY D. KNIGHT ; .MCALL .READ,.WAIT ; ;ENTRY POINTS .GLOBL ITOA,OUTLN2,OUTCH2,JTOA .GLOBL EOL,GETLN,LSTLIN,OUTCHR,OUTLN,OUTLN1,OUTPUT ;EXTERNAL REFERENCES .GLOBL OUTHD,LINKSL,COMHD .GLOBL BUFIN,BUFOUT,CURLN,GBUF,INHD,LINENO .GLOBL LINKI,LINKOL,SEQNO,TLINE,SEQSUP,SRCLIN,SRCLEG .PSECT ZZZHGH R0 = %0 R1 = %1 R2 = %2 R3 = %3 R4 = %4 R5 = %5 SP = %6 PC = %7 ; TAB = 11 ;A TAB HAS TH BEQ FTERR3 ;ZERO CMP R1,#2 BGE FTERR1 .IF NDF COM8K BIC #7,SWVAL TST OSW ;IS THERE A BINARY SWITCH? BEQ FORT19 ;NO CMP OSW+2,#"AS ;IS THIS THE ASSEMBLER SWITCH? BNE FTERR1 ;NO BIS #2,SWVAL ;REMEMBER ASSEMBLER SWITCH FORT19: MOV #1,LSTVAL TST LSW ;IS THERE A LIST SWITCH? BEQ FORT20 ;NO CMP LSW,#2 ;IS THERE A SWITCH VALUE? BEQ FORT21 ;YES MOV #1,LSTVAL ;SET DEFAULT FORT21: CMP LSW+4,#"LI ;IS IT "LI"ST?? BNE FTERR1 ;NO BIS #4,SWVAL ;REMEMBER LI SWITCH MOVB @LSW 0 MODTAB: .BYTE 'I,'I+200,'I,'R,'D,'D+200 ; ; ;GLOBL DECLARATION AND CALL TO OTS LOGICAL COMPARE ROUTINE ; IF800: .ASCII / .GLOBL/ IF801: .ASCII / $TRTST/ .BYTE 015,012 ;CR/LF IF802=. ; ; .END ;  COUNT LIST06: JSR PC,NXTCH ;GET A CHARACTER CMPB R2,#'( ;IS IT A LEFT PAREN? BNE LIST07 ;NO INC @SP ;INCREMENT PAREN COUNT BR LIST06 LIST07: CMPB R2,#', ;IS IT A COMMA? BEQ LIST08 ;YES TST R2 ;EXIT BEQ LIST5A ;IF END OF LINE CMPB R2,#') BNE LIST06 DEC @SP BPL LIST06 TST (SP)+ MOV (SP)+,R1 INC PARCNT DEC COUNT ;BACK UP ON FALSE ALARM JMP LIST1A LIST6B: DEC R1 ;BACK UP THE POINTER LIST6A: TST (SP)+ ;POP THE JUNK BR LISTE VALUE 11 SPACE = 40 ;A SPACE IS A 40 ; INIT = EMT+6 ;INITIALIZE OPEN = EMT+16 ;OPEN FILE READ = EMT+4 ;READ FILE WRITE = EMT+2 ;WRITE FILE MWAIT = EMT+1 ;WAIT UNTIL DONE UTIL = EMT+41 ;GENERAL UTILITY CALL CSI1 = EMT+56 CSI2 = EMT+57 CLOSE = EMT+17 RLS = EMT+7 ;RELEASE DEL = EMT+21 ;DELETE EXITM = EMT+60 ;EXIT ; ; GETLN OBTAINS A LINE OF SOURCE INPUT FOR THE COMPILER. ; ANY LINE NUMBERS FOUND ARE STRIPPED AND SAVED. ANY ; CONTINUATIONS+2,LSTVAL ;GET SWITCH SUB #60,LSTVAL ;CONVERT IT TO INTEGER BMI FTERR1 ;BAD SWITCH CMP LSTVAL,#9. ;IS IT TOO BIG? BGT FTERR1 FORT20: .ENDC FORT31: MOV #ISW,R0 ;GET ADDRESS OF SWITCHES FORT16: MOV #SWLST,R1 ;GET ADDRESS OF SWITCH LIST MOV #1,R2 ;GET SWITCH BIT POINTER CLR R3 ;SET SWITCH POINTER TO ZERO DEC (R0)+ ;IS THERE ANOTHER SWITCH? BMI FZRT15 ;NO BEQ FORT29 ;NO, DON'T CHECK FOR VALUE MOV R0,R3 ;GET THE POINTER MOV -2(R3),R4 ;06 LIST08: TST @SP ;IS IT ON THE CURRENT LEVEL? BNE LIST06 ;NO MOV R1,-(SP) ;REMEMBER POSITION JSR PC,GET ;SEE IF IT IS A SIMPLE VARIABLE TST R3 ;RE-LOOP BNE LIST6A ; IF NOT A SIMPLE VARIABLE CMP R2,#2 ;IS IT INTEGER? BNE LIST6A ;NO JSR PC,NXTCH ;GET THE NEXT CHARACTER CMPB R2,#'= ;IS IT AN EQUAL? BNE LIST6B ;NO MOV (SP)+,R1 ;FOUND IT!!! INC IOL INC DONUM ;SET UP MOV #DOTMP+4,R4 ;FOR MOV R4,R3 ;FAKE MOVB DONUM,(R3)+ ;DO CLRB (R3)+ ;LOOP JSR PC,END1 ;GO DO  ARE PROPERLY APPENDED. UPON RETURN TO THE ; COMPILER, THE LINE IS POINTED TO BY R1 AND THE STRING ; IS TERMINATED BY A ZERO BYTE WITH REMOVED. ; REGISTERS CHANGED - ALL. ; GET27: SEV ;SET END-OF-FILE RTS PC ;AND RETURN GETLN: MOV SRCLIN,R1 ;SET LINE POINTER TO ZERO TST CURLN ;IS THERE A LINE ALREADY WAITING? BMI GET27 ;EXIT IF END-OF-FILE BEQ GET00 ;NO IF NOT SET MOV CURLN,R5 ;PICK UP OLD LINE LENGTH BR GET01 ;AND CONTINUE GET20:GET THE SWITCH VALUE COUNT TST (R0)+ ;SKIP OVER VALUE POINTER DEC R4 ;CLECK FOR ONLY ONE SWITCH BNE FTERRX ;MORE THAN ONE!! FORT29: TST (R1) ;DID WE RUN OUT OF LIST? BEQ FTERRX ;YES, DIE QUIETLY ASL R2 ;ADVANCE BIT POINTER CMP (R1)+,(R0) ;IS IT A MATCH BNE FORT29 ;NO BIS R2,SWVAL ;SET IT JSR PC,@SWJMP-SWLST-2(R1) ;GO SET UP THE SWITCH TST (R0)+ ;SKIP OVER SWITCH NAME BR FORT16 ;GO GET NEXT SWITCH FZRT15: JMP FORT15 SWLST: .IF NDF .TITLE IOSTMT .IDENT /0711A/ ;RG ; COPYRIGHT 1973 DIGITAL EQUIPMENT CORPORATION ; MAYNARD, MASS. 01754 ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS ; SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC. .NLIST BEX .GLOBL DECODE,ENCODE,FIND,PRINT,READ,WRITE .GLOBL IOVERB,IOLIST,ZLEQLS R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 ; THE FOLLOWING ENTRY POINTS, CALLED FROM EXECUT ; SET AN I/O STATEMENT VERB CODE ; AND THEN FALL INTO THE COMMON THE INITIALIZATION BVS BADLST CLR IOL MOV R1,@SP ;REMEMBER END OF DOSPEC MOV 2(SP),R1 MOV (SP)+,@SP JSR PC,LIST00 ;GO GET THE I/O LIST MOV R3,-(SP) MOV #-1,R2 ;FINISH UP THE JUNK JSR PC,TSTM01 CLR COUNT MOV #-1,LSTMOD MOV LINENO,-(SP) ;SAVE REAL LINE NUMBER MOVB DONUM,LINENO DEC DONUM CLRB LINENO+1 INC IOL ;TELL HIM THIS IS I/O JSR PC,DODON ;GO HANDLE DO ENDING CLR IOL ;UN-TELL HIM NOW MOV (SP)+,LINENO ;RESTORE REAL LINE NU JSR PC,LSTL00 ;LIST A COMMENT LINE AND TRY AGAIN GET00: .READ #LINKI,#INHD ;READ AN INPUT LINE .WAIT #LINKI ;WAIT FOR COMPLETION BIT #060000,INHD+2 ;CHECK FOR EOF OR EOM BNE GET26X ;EXIT IF SET MOV #BUFIN,R2 ;GET BUFFER ADDRESSES MOV #BUFOUT,R5 CLR R0 ;SET NULL FLAG INL01: CMP R2,#BUFIN+72. ;IS END OF LINE TO BE FORCED? BHIS INL04A ;YES MOVB (R2)+,R4 ;GET A CHARACTER CMPB R4,#40 ;IS IT A CONTROL CHAR? BEQ INL02A ;A SPACE! BGT INL02 ;NOT A CC CMPB R4,#15 ; IS SPECIAL  COM8K .ASCII /AS/ ;USED BY SWITCH LIST ROUTINE .ASCII /LI/ ;USED BY SWITCH LIST ROUTINE .IFTF .ASCII /ER/ ;ERROR DIAGNOSTICS - COMPREHENSIVE .ASCII /ON/ ;ONE WORD INTEGERS .ASCII /CK/ ;ARRAY BOUNDS CHECKING .ASCII /SU/ ;SEQUENCE SUPPRESSION .ASCII /CO/ ;CONTINUATION LINE SET .ASCII /OP/ ;OPTIMIZATION LEVEL .IFT .ASCII /GO/ ;COMPILE AND GO .IFTF .WORD 0 SWJMP: .IFT FTERRX FTERRX .IFTF FORT22 ;/ER FORT18 ;/ON FORT28 ;/CH FORT17 ;/SU FORT33 ;/CO FOPROCESSING SEGMENT FIND: MOV #-1,R0 BR IOCOM READ: CLR R0 BR IOCOM WRITE: MOV #1,R0 BR IOCOM PRINT: MOV #3,R0 BR IOCOM ENCODE: MOV #4,R0 BR IOCOM DECODE: MOV #5,R0 IOCOM: JSR PC,ZLEQLS ;IS IT A REAL I/O STATEMENT ? BCS 20$ ;NO - TRY FOR ASSIGNMENT JSR PC,IOVERB ;PROCESS I/O VERB PART BCS 10$ ;SOME ERROR - SKIP LIST-PROCESSING JSR PC,IOLIST ;PROCESS I/O LIST 10$: CLV ;INDICATE PROCESSING COMPLETE RTS PC 20$: SEV ;INDICATE NOT I/O STATEMENT RTS PC .END MBER CMPB (SP)+,#'= ;MAKE SURE IT IS CORRECT BEQ LIST9A ;IT IS TRAP+91. ;ILLEGAL LIST LIST9A: MOV (SP)+,R1 ;REMEMBER WHERE DOSPEC ENDS JSR PC,NXTCH ;GET A CHARACTER CMPB R2,#') ;IT MUST BE A RIGHT PAREN BNE LIST09 JMP LIST03 ;GO BACK FOR ENDING LIST09: TRAP+90. ;BAD DOSPEC JMP LIST10 ;TRY TO CONTINUE ; ; CHECK THE CURRENT MODE AGAINST THE LAST ; TSTMOD: TST LSTMOD ;HAS IT BEEN INITIALIZED? BPL TSTM01 ;YES MOV R2,LSTMOD ;NO, SET TO C BEQ INL02A CMPB R4,#12 ; IS MORE SPECIAL BEQ INL04 CMPB R4,#14 ;A IS SPECIAL TOO BEQ INL04C CMP R4,#TAB BEQ INL02A MOVB #'^,(R5)+ ;STORE ^ ADD #100,R4 ;CONVERT TO UPPER CASE INL02: INC R0 ;SET NON-NULL FLAG INL02A: MOVB R4,(R5)+ ;STORE IN BUFFER BR INL01 GET26X: BR GET26 INL04C: MOV #12,R4 ;CONVERT TO BR INL04 INL04A: MOVB #15,(R5)+ ;FORCE MOVB #12,R4 ;END OF LINE MOV #15,(R2)+ ;CLEAR END MOV R4,(R2)+ ;OF INRT40 ;/OP .IFT FORT30 ;/GO .IFTF ; ; HANDLE THE ARRAY BOUNDS CHECKING SWITCH ; FORT28: TST R3 ;WAS THERE A VALUE BNE EREX1 ;YES MOVB #1,ARYCHK ;SET ARRAY CHECKING RTS PC ; ; HANDLE THE SEQUENCE SUPPRESSION SWITCH ; FORT17: MOVB #1,SEQSUP ;SET SUPPRESS SWITCH RTS PC ; ; HANDLE THE ONE WORDS INTEGERS SWITCH ; FORT18: TST R3 ;WAS THERE A VALUE? BNE EREX1 ;YES MOVB #2,TYPSIZ+1 ;SET SINGLE WORD MOVB #2,TYPSIZ+2 ;INTEGERS IN TABLE RTS PC .IFT ; ; HANDLE THE COMPILE URRENT VALUE TSTM01: INC COUNT ;ADVANCE THE COUNT CMP R2,LSTMOD ;ARE THE CURRENT AND LAST MODES EQUAL? BNE 1$ ;THE MODES ARE DIFFERENT TSTB CUROUT ;NOW CHECK THE BMI TSTM02 ;MIXING BGT 2$ ;OF TSTB LSTOUT ;ARRAY ITEMS BGT 3$ ;AND BR TSTM02 ;SIMPLE ITEMS 2$: TSTB LSTOUT BNE TSTM02 3$: CMP COUNT,#1 ;DON'T OUTPUT BEQ TSTM02 ;ZERO ITEMS 1$: MOV LSTMOD,R4 ;GET THE PREVIOUS MODE MOV R2,LSTMOD ;SAVE THE NEW MODE MOV R4,R2 MOV #FMPSH,R4 ;OUTPUT THE JSR PC,PUTNAM ;PUSH PROTOBUF TOO!! INL04: MOVB R4,(R5)+ ;STORE SUB #BUFOUT,R5 ;GET BYTE COUNT CLR CURLN TST R0 ;IS THIS A NULL (COMMENT) LINE? BEQ GET20 ;YES GET01: CLR CURLN ;TURN OFF BUFFER FLAG MOV #BUFIN,R0 CMPB @R0,#'C ;IS IT A COMMENT??? BEQ GET31 ;YES, SO THERE CAN'T BE CONTINUATION MOV #TLINE,R4 ;GET ADDRESS OF STORAGE AREA MOV #6,R2 ;GET COUNT PLUS TWO GET11: DEC R2 ;DECREMENT CHARACTER COUNT BLE GET12 ;EXIT IF DONE MOVB (R0)+,R3 ;GET A CHARACTER CMPB R3,#SPACE ;IGNORE BLANKS BEQAND GO SWITCH ; FORT30: MOVB #1,RUNFG ;TURN ON COMPILE AND GO CLRB RUNCT ;TURN OFF /CC CLRB RUNER ;TURN OFF FATAL FLAG RTS PC .GLOBL RUNFG,RUNCT,RUNER .ENDC ; ; HANDLE THE COMPREHENSIVE ERROR DIAGNOSTIC SWITCH ; FORT22: TST R3 ;WAS THERE A VALUE? BNE EREX1 ;YES MOVB #1,ERRFLG ;SET ERROR FLAG TO ONE RTS PC EREX1: TST (SP)+ FTERRX: JMP FTERR1 ;BAD VALUE ; ; HANDLE THE CONTINUATION LINE SWITCH ; FORT33: TST R3 ;IS THERE A SWITCH VALUE .TITLE IOVERB .IDENT /0711B/ ;DK,RG ; ;COPYRIGHT 1971,1973 DIGITAL EQUIPMENT CORP. ; DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS ; SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC. ; ; .GLOBL PUTCHR,OUTCH2,OUTLN2,CHT1 .GLOBL GET,ZLEQLS,GENLAB,NXTCH,CNXC .GLOBL PUTNAM,BITM,MISC,OUTGL,EOL .GLOBL OUTNAM,OUTCOM,CURSYM,OUTST,OUTLN1,OUTOCT .GLOBL PARMKM,PARWD,PARXWD .GLOBL LSTOUT,RDDEV,WTDEV .GLOBL SCAN2A,OUTSL .GLOBL IOVERB .CSECT R0=%0 R1=%1 R2=%2 TYPE JSR PC,PVX ;AND POSSIBLY A GLOBAL OR TWO MOV COUNT,R3 ;OUTPUT THE DEC R3 JSR PC,OUTOCT ; COUNT MOV #1,COUNT JSR PC,EOL MOV #INIT08,R4 JSR PC,PUTNAM MOVB MODE(R2),R4 ;GET THE MODE JSR PC,PUTCHR ;OUTPUT IT BITB BITM(R2),MISC+3 BNE TSTM04 BISB BITM(R2),MISC+3 ;SET PRESENT BIT JSR PC,OUTGL ;OUTPUT THE GLOBAL JSR PC,EOL TSTM04: JSR PC,OUTNAM ;OUTPUT THE NAME JSR PC,EOL TSTM02: MOVB LSTOUT,CUROUT ;ADVANCE THE MODES RTS PC .GLOB GET11 CMPB R3,#'0 ;IS IT LEGAL ASCII? BEQ GET24 ;IGNORE LEADING ZEROS BLT GET13 ;NOT LEGAL CMPB R3,#'9 ;CHECK HIGH VALUE BLE GET25 ;LEGAL GET13: CMPB R3,#TAB ;IS IT A TAB? BNE GET14 ;NO, GIVE ERROR GET28: DEC R0 ;BACK UP POINTER BR GET12 ;YES, GO AWAY HAPPY GET25: MOVB R3,(R4)+ ;STORE CHARACTER BR GET11 GET14: CLR TLINE ;SET NOT FOUND FLAG CMP SRCLIN,R1 ;LINE ALREADY STARTED? BNE GET29 ;YES, DON'T ISSUE DUPLICATE ERROR TRAP+2 ? BNE 10$ ;YES 2$: TST (SP)+ ;MUST HAVE A VALUE BR FTERRX 10$: MOV @R3,R3 ;GET ADDRESS OF SWITCH VALUE 1$: MOVB (R3)+,R4 ;GET FIRST DIGIT SUB #60,R4 ;CONVERT TO INTEGER BMI 2$ ;LOUSY INTEGER CMP R4,#9. ;IS IT TOO BIG? BGT 2$ ;YES MOV R2,-(SP) MOVB (R3)+,R2 ;GET THE SECOND CHARACTER SUB #60,R2 ;CONVERT TO INTEGER BMI 6$ ;BAD INTEGER CMP R2,#9. ;IS IT TOO BIG BGT 6$ ;YES MOV R3,-(SP) .GLOBL LINCNT CLC ;MULTIPLY ASL R4 ;R4 MOV R4,R3 ;BY ASL R3 ;TEN ASLR3=%3 R4=%4 R5=%5 SP=%6 PC=%7 .NLIST BEX ; ; THE FOLLOWING CODE HANDLES READ, WRITE, PRINT, AND FIND ; STATEMENTS. ALL REGISTERS ARE USED. ; ON ENTRY, R0 CONTAINS AN INTEGER CODE FOR THE TYPE OF I/O STATEMENT ; THE CODES ARE: ; FIND -1 ; READ 0 ; WRITE 1 ; PRINT 3 ; ENCODE 4 ; DECODE 5 ; RETURNS C=1 IF NO I/O LIST-PROCESSING IS TO FOLLOW ; THUS C=1 FOR 'FIND' AND ON ERRORS ; IOVERB: MOV R0,-(SP) ;SET I/O VERB CODE WHERE EXPECTED BELOW JSR PC,GENLAB ;GENERATE THE LABEL JSRL LIST99 LIST99: MOV STKCNT,R0 ;GET STRING ADDRESS CLR -(SP) ;ADD TERMINATOR TST -(R0) ;POINT TO STRING MOV R2,-(SP) ;REMEMBER TYPE JSR PC,EXPGEN ;GENERATE SOME CODE .GLOBL EXPGEN MOV (SP)+,R2 ;RETAIN TYPE MOV STKCNT,SP JMP LIST11 ; ; GENERATE ADDRESS PUSH FOR VARIABLE ; PVAR: CLRB LSTOUT MOV CURSYM,R0 ;GET ADDRESS OF ENTRY MOV #FMPSH,R4 ;ADDRESS OF PROTOTYPE JSR PC,PUTNAM ;PUT NAME IN LIMBO BIT #PARMKM,PARWD(R0) ;IS IT A PARAMETER??? ;GIVE DIAGNOSTIC TO USER GET29: MOVB (R0)+,R3 ;SKIP OVER CMPB R3,#TAB ;LINE # FIELD BEQ GET28 CMPB R3,#SPACE BNE GET29 CMP R0,#BUFIN+6 BLOS GET5A MOV #BUFIN+6,R0 BR GET5A GET24: CMP R4,#TLINE ;IS THIS A LEADING ZERO BEQ GET11 ;YES, IGNORE IT BR GET25 ;NO, STORE IT GET12: CLRB (R4)+ ;TERMINATE LINE NUMBER GET5A: CMP SRCLIN,R1 ;LINE ALREADY THERE? BEQ GET05 ;NO TSTB TLINE ;IS LINE NUMBER NULL? BNE GET08 ;NO, SO DON'T CHECK CONTINUATION GET05: MOVB (R0)+,R3 ;GET NEXT CH R3 ;FOR DECIMAL ADD R3,R4 ;CONVERSION MOV (SP)+,R3 ;RESTORE R3 ADD R2,R4 ;FINAL VALUE OF SWITCH 5$: MOV (SP)+,R2 ;RESTORE R2 CMPB (R3),#', ;IS IT TERMINATED BEQ 3$ ;BY A COMMA OR CMPB (R3),#'/ ;BY A SLASH BEQ 3$ ;OR CMPB (R3),#15 ;A CARRIAGE RETURN? BNE 2$ ;NO, BAD ERROR 3$: MOV R4,LINCNT ;SET NEW LINE COUNT RTS PC ;RETURN TO CALLER 6$: DEC R3 ;BACK UP OVER BAD CHARACTER BR 5$ ; HANDLE THE OPTIMIZATION LEVEL SWITCH ; FORT40: PC,NXTCH ;GET A CHARACTER CMPB R2,#'( ;IS IT A LEFT PAREN? BEQ 8$ ;YES - NORMAL I/O PROCESSING ; HANDLE SPECIAL SHORT FORMS FOR READ/PRINT TST (SP) ;IS IT A READ STATEMENT ? BNE 2$ ;NO MOV #2,(SP) ;READ IS A SIMPLE FORM MOV #RDDEV,R0 ;FAKE UNIT NUMBER FOR READ BR 4$ ;PROCESS UNIT NUMBER 2$: CMP (SP),#3 ;IS IT A PRINT STATEMENT? BNE BADIO ;NOT READ OR PRINT MOV #WTDEV,R0 ;FAKE UNIT NUMBER FOR PRINT 4$: DEC R1 ;BACK UP THE SCAN POINTER MOV R1,-(SP) ;AND SAVE IT BRIEFLY M?? BEQ PVAR01 ;NO MOV #'P,R4 JSR PC,PUTCHR ;FLAG IT AS A PARAMETER BITB BITM+2,MISC+1 ;DO WE NEED A GLOBL?? BNE PVAR02 ;NO BISB BITM+2,MISC+1 ;YES, SET IT DONE JSR PC,OUTGL ;OUTPUT THE GLOBAL JSR PC,EOL ;AND AN END OF LINE PVAR02: JSR PC,OUTNAM ;OUTPUT THE NAME JSR PC,OUTCOM ;AND A COMMA MOVB PARXWD(R0),R3 ;GET THE PARAMETER INDEX BIC #177400,R3 JSR PC,OUTOCT BR PVAR03 PVAR01: JSR PC,PVX JSR PC,OUTST ;AND THE SYMBOL NAME PVAR03: JSR PC,EOL ;FINALLY AN END OF LINE RTS PARACTER CMPB R3,#TAB ;IS IT A TAB? BEQ GET04 ;YES, GO CHECK FOR SPECIAL CONTINUATION GET02: CMPB R3,#SPACE ;WAS THE CHARACTER A SPACE? BNE GET03 ;NO, CHECK REST OF LINE MOVB (R0)+,R3 ;GET ANOTHER CHARACTER BR GET02 ;AND TRY AGAIN GET31: CMP SRCLIN,R1 ;IS THERE A LINE ALREADY FOUND? BNE GET18 ;YES JMP GET20 ;NO, SO LIST THE COMMENT GET26: MOV #-1,CURLN ;SET END OF FILE CMP R1,SRCLIN ;DO WE ALREADY HAVE A LINE?? BNE GET22 ;YES JMP GET27  TST R3 ;IS THERE A SWITCH VALUE? BNE 1$ ;ERROR IF NOT 2$: TST (SP)+ ;CLEAR RETURN POINTER BR FTERRX ;REPORT ERROR 1$: MOV @R3,R3 MOVB (R3)+,R4 ;GET VALUE CHAR SUB #60,R4 ;SCALE TO NUMERIC RANGE BMI 2$ ;BAD DIGIT CMPB R4,#9. ;TOO HIGH? BGT 2$ MOV R4,OPTLVL ;SAVE AS OPT LEVEL CMPB @R3,#', ;NEXT MUST BE TERMINATOR BEQ 3$ CMPB @R3,#'/ BEQ 3$ CMPB @R3,#15 BNE 2$ ;REPORT ERROR 3$: RTS PC ;ALL IS WELL FORT15: .RLSE #LINKL ;RELEASE TELEPRIOV R0,R1 ;SET TO SCAN FAKE UNIT NUMBER JSR PC,GET ;PLACE IT IN SYMBOL TABLE MOV (SP)+,R1 ;RESTORE SCAN POINTER BR IO002 ;GO FINISH UNIT NUMBER 8$: CMP (SP),#3 ;DON'T ALLOW THE FORM "PRINT (" BEQ BADIO ;ERROR JSR PC,GET ;GET THE UNIT NUMBER BVS BADIO ;NO UNIT NUMBER CMP R2,#2 ;IS IT AN INTEGER?? BEQ IO001 ;YES CMP @SP,#4 ;ENCODE/DECODE? BLT IO01A ;NO, GIVE NORMAL DIAGNOSTIC TRAP+118. ;BAD BUFFER DESCRIPTOR BR IO001 IO01A: TRAP+65. ;NO, GIVE ERROR IO001: CMP R3,#1 C PVX: BITB BITM+1,MISC ;DO WE NEED A GLOBAL? BNE PVAR04 ;NO BISB BITM+1,MISC ;SET THE DONE BIT JSR PC,OUTGL ;OUTPUT THE GLOBAL JSR PC,EOL ;AND AN END OF LINE PVAR04: JSR PC,OUTNAM ;OUTPUT THE NAME JSR PC,OUTCOM ;AND A COMMA RTS PC ; ; MODE: .BYTE 'B,'L,'I,'R,'D,'C,'X,'A .EVEN FMPSH: .ASCII / $PSH/ .BYTE 0 RPSH: .ASCII / $PSHR1/ .BYTE 15,12,0 .EVEN INIT07: .ASCII / $PSH,/ .BYTE 0 INIT08: .ASCII / $IO/ .BYTE 0 FIN00: .ASCII / $IOF/ .BYTE 15,12,0 .EVEN .END ;  ;NO GET03: CMP R0,#BUFIN+6 ;IS THERE A CONTINUATION BHI GET16 ;NO CMP R3,#'0 ;MAYBE, CHECK FOR NULL CONTINUATION BEQ GET08 ;NO CONTINUATION CMPB R3,#40 ;DON'T ALLOW CONTROL CHARS BLE GET09 CMPB R3,#140 ;DON'T ALLOW LOWER CASE BGE GET09 ;WHY??, I DON'T KNOW GET17: CMP SRCLIN,R1 ;CHECK FOR CONTINUATION ON FIRST LINE BNE GET06 ;UNNECESSARY CONTINUATION MARK TRAP+0 ; IF START OF TEXT BUFFER GET06: CMP SRCLIN,R1 ;IS THIS A CONTINUATION? BEQ GET6A ;NO JSR PC,LSTL00 ;YES, DONNTER .RLSE #LINKK ;RELEASE KEYBOARD .INIT #LINKI ;INITIALIZE INPUT FORT27: .OPEN #LINKI,#SRCIN ;OPEN SOURCE INPUT TST LINKSL+6 ;IS THERE A SOURCE LISTING???? BEQ FORT06 ;NO .INIT #LINKSL ;INIT SOURCE LIST DEVICE MOV #LSTDEL,LSTER JSR R5,CKIN ;CHECK FOR SAME NAME +SRCLS ;AS LISTING BVS LSTD1 ;DIFFERENT CLR LSTER ;TURN OFF ERROR HANDLING LSTD1: .OPEN #LINKSL,#SRCLS ;OPEN SOURCE LIST CLR LSTER FORT06: TST LINKOL+6 ;IS THERE ANY OBJECT OUTPUT?? BEQ FORT07 .IF NDF COM8K T;IS IT A VARIABLE OR CONSTANT BLE IO002 ;YES, IT IS CMP @SP,#4 ;ENCODE/DECODE? BLT IO02B ;NO, GIVE NORMAL DIAGNOSTIC TRAP+119. ;ARRAY OR FUNCTION USED IMPROPERLY BR IO002 IO02B: TRAP+66. ;ARRAY OR FUNCTION NAME IS ILLEGAL IO002: JSR PC,PVAR ;GENERATE PUSH CMP @SP,#4 ;IS IT ENCODE/DECODE? BGE IO02A ;YES CMP @SP,#2 ;IS IT A SPECIAL READ OR WRITE?? BGE IO006 ;YES IO02A: JSR PC,NXTCH ;GET A COMMA CMPB R2,#', ; WAS IT A COMMA? BEQ IO005 ; YES,GO GET GOODIES CMP @SP,#4 ; 0 IF READ 'T LIST SEQUENCE NUMBER BR GET19 GET6A: JSR PC,LSTLIN ;LIST THE LINE BEFORE SAVING IT GET19: MOVB (R0)+,R3 ;GET CHAR IN BUFFER CMP R3,#15 ;QUIT ON BNE GET15 JMP GET00 GET15: MOVB R3,(R1)+ ;STORE IN LINE BUFFER MOV SRCLIN,R3 ;DID IT ADD SRCLEG,R3 ;OVERFLOW DEC R3 CMP R1,R3 ;HERE?? BHIS GET21 ;YES BR GET19 GET04: MOVB (R0)+,R3 ;CHECK SPECIAL CONTINUATION CMPB #'1,R3 ;IS IT OK?? BGT GET16 ;NO CMPB #'9,R3 ;CHECK AGAIN BGE GET17 ;GO AWAY IF OK GET16: DEC R0 ;BACK UST OBJEXT ;OBJECT DEFAULT EXTENSION? BNE FORT24 ;NO TST OSW ;WHICH IS IT BEQ FORT25 ;JUMP IF .OBJ MOV FORT11,OBJEXT ; .PAL BR FORT24 FORT25: MOV FORT23,OBJEXT ; .OBJ FORT24: .ENDC .INIT #LINKOL ;INITIALIZE OBJ OUTPUT MOV #OBJDEL,OBJER JSR R5,CKIN ;IS THE NAME THE +OBJLS ;SAME AS THE OBJECT? BVS OBJD1 ;NO CLR OBJER ;YES, LET MONITOR HANDLE IT OBJD1: .OPEN #LINKOL,#OBJLS CLR OBJER FORT07: .IF NDF COM8K .GLOBL LINKAS,ASMLS IS IT ENCODE/DECODE? BGE BADIO ;YES, MUST BE AN ERROR CMPB R2,#') ;IS IT A RIGHT PAREN??? BEQ IO003 ;YES, UNFORMATTED I/O CMPB #'',R2 ;IS IT A SINGLE QUOTE?? BEQ IO010 ;YES, IT IS RANDOM ACCESS BADIO: TST (SP)+ ;CLEAR ITEM FROM STACK BADIO1: TRAP+67. ;ILLEGAL I/O STATEMENT FORM SEC ;INDICATE ERROR RTS PC ;AND RETURN IO003: TST @SP ;IS IT A LEGAL UNFORMATTED I/O?? BPL IO004 ;YES TRAP+68. ;MISSING ARGUMENT IO004: CLR -(SP) ;SET UNFORMATTED MODE JMP IOGEN ;GO HANDLE AP POINTER GET08: CMP SRCLIN,R1 ;CHECK FOR LINE ALREADY FOUND BNE GET18 ;NO MORE, REMEMBER WHAT GOES ON MOV #TLINE,R3 ;GET ADDRESS OF TEMP. LINE MOV #LINENO,R4 ;GET PERMANENT LINE NUMBER MOV (R3)+,(R4)+ ;MOVE MOV (R3)+,(R4)+ ; TO MOV (R3)+,(R4)+ ; PERMANENT AREA BR GET06 ;GO TRANSFER TEXT GET18: MOV R5,CURLN ;SAVE BYTE COUNT UNTIL NEXT TIME GET22: CLRB (R1)+ ;STORE TERMINATOR IN BUFFER MOV SRCLIN,R1 ;GET ADDRESS OF BUFFER GET23: RTS PC ;RETURN TO CALLER GET09: TRAP+1 ;ILLEGAL CO TST OSW ;ASSEMBLE THE STUFF? BNE FORT26 ;NO .INIT #LINKAS ;INIT ASSEMBLER MOV #TMPDEL,ASMLS-4 ;SET ERROR RETURN TMPD1: .OPEN #LINKAS,#ASMLS ;OPEN ASSEMBLER FILE CLR LINKAS-4 ;CLEAR ERROR BR FORT26 TMPDEL: CLR ASMLS-4 ;DELETE .DELET #LINKAS,#ASMLS ;DELETE ASSEMBLER FILE BR TMPD1 FORT26: .ENDC MOV LOWCOR,SP ;SET UP THE STACK POINTER .MONF ;GET THE LOWEST AVAILABLE ADDRESS MOV (SP)+,MTOP ;REMEMBER THE ADDRESS MOV LINCNT,R5 ;COMPUTE THLL THE COMMON GOODIES IO005: MOV R1,R5 ;SAVE TEXT POINTER CMP @SP,#4 ;ENCODE/DECODE? BGE IO006 ;YES, DON'T LOOK FOR END OR ERR YET MOV #OPTLST,R0 ;GET ADDRESS OF END, ERR PROTOTYPES JSR PC,SCAN2A ;CHECK FOR ONE OF THEM BVS IO006 ;NOT PRESENT, TRY FOR FORMAT MOV R5,R1 ;UNFORMATTED BR IO004 ;GO HANDLE UNFORMATTED IO006: MOV R1,R4 ;REMEMBER CHARACTER POINTER JSR PC,NXTCH ;GET A CHARACTER JSR PC,CHT1 ;IS IT NUMERIC? BMI IO06A ;YES DEC R1 .GLOBL NOCNSV INCB NOCNSV ;SUPRESSNTINUATION MARK, IGNORED BR GET06 ;GO PROCESS LINE ANYWAY GET21: CLR CURLN ;THROW AWAY EXCESS LINE TRAP+6 ;TELL USER BR GET22 ;AND EXIT ; ; LSTLIN - LIST LINE ON SOURCE AND OBJECT DEVICES, R5 HAS COUNT ; LINE IS IN BUFOUT. REGISTERS CHANGED - R4,R5. ; LSTL00: MOV R5,-(SP) MOV NBUF+4,NBUF MOV NBUF+4,NBUF+2 BR LSTL03 LSTLIN: TSTB SEQSUP ;SUPPRESS SEQUENCING? BNE LSTL00 ;YES MOV R5,-(SP) MOV R3,-(SP) ;SAVE R3 MOV SEQNO,R4 ;GET THE E MOV #72.,R0 ;SIZE MOV R0,R1 ;OF 1$: DEC R5 ;THE WORK BUFFER BMI 2$ ;EXIT IF NO MORE CONTINUATIONS ADD R0,R1 ;ADD LENGTH OF CURRENT CONTINUATION BR 1$ ;LOOP UNTIL COMPLETE 2$: MOV R1,SRCLEG ;PUT AWAY THE TOTAL LENGTH SUB R1,SP ;MAKE ROOM FOR IT MOV MTOP,R1 ;GET MONITOR TOP MOV SP,SRCLIN ;SET UP START OF BUFFER ; SET UP FINAL COMPILER STACK SPACE ; ADD #512.+100.,R1 ;MINIMUM ROOM CMP DPTR+2,#256. ;>256. IMPLIES RP03 BGT 4$ ;IN WHICH CASE NEED EVEN MORE .CORE ;IF ME  SYMBOL ENTRY FOR FORMAT JSR PC,GET ;FIND OUT WHAT IT IS CLRB NOCNSV ;TURN OFF SUPPRESSION TST R3 ;IS IT A CONSTANT? BMI IO06A ;YES, GO HANDLE NORMALLY BEQ IO007 ;NO CMP R3,#1 ;IS IT AN ARRAY? BNE IO007 ;NO JSR PC,PVAR ;OUTPUT THE ARRAY NAME BR IO06B ;GO COMPLETE THE JOB IO06A: MOV R4,R1 MOV #FMPSH,R4 ;GET ADDRESS OF $PSH JSR PC,PUTNAM JSR PC,PVX JSR R5,OUTCH2 '$ JSR PC,OUTSL ;OUTPUT THE FORMAT NUMBER BVS IO007 ;ERROR OF NO NUMBER MOV #FMTLB1,R4 ;OUTPUT NORMAL SEQUENCE NUMBER MOV #NBUF,R3 ;AND THE BUFFER ADDRESS JSR PC,ITOA ;CONVERT TO INTEGER MOV (SP)+,R3 LSTL03: .IF NDF COM8K .GLOBL LSTVAL ;NEED A LISTING? TST LSTVAL BEQ LSTL04 ;NO JSR PC,PAG .IFTF MOV #8.,R5 ;GET SHORT COUNT MOV #LISTL0,R4 JSR PC,OUTPUT ;OUTPUT THE LINE NUMBER MOV (SP)+,R5 ;RESTORE R5 MOV #LSTL01,R4 ;DESCRIPTION OF OUTPUT RO R4 JSR PC,OUTPUT ;OUTPUT A LINE .IFT CMP LSTVAL,#1 ;IS LISTING OF OBJECT NEEDED? BGT LS MORY IS MOV (SP)+,R0 ; CMP R0,#37776 ;8K BLOS 5$ ;THEN NO MORE CMP R0,#57776 ;IF 12K THEN ALLOW 200. MORE BEQ 3$ 4$: ADD #512.,R1 ;ELSE BE GENEROUS 3$: ADD #200.,R1 5$: CMP SP,R1 ;DID WE OVERFLOW HERE? BLOS STKOVF ;YES, DIE IN AGONY MOV SP,FRHIGH ;SET FREE CORE HIGH ADDRESS MOV R1,FRLOW ;SET FREE CORE LOW ADDRESS MOV R1,OLDLOW MOV R1,SP ;RELOCATE STACK POINTER TO FINAL REST .GLOBL OLDLOW .GLOBL LOWCOR,MTOP,LINCNT,SRCLEG,SRCLIN,FRHIGHTERMINATOR IO008: JSR PC,OUTLN1 IO06B: MOV #1,-(SP) ;SET FORMATTED MODE BR IO014 IO007: MOV #FMTLAB,R4 ;OUTPUT ERROR TRAP+92. ;TELL HIM FORMAT IS BAD BR IO008 ; TERMINATOR IO010: MOV #-1,-(SP) ;RANDOM ACCESS I/O JSR PC,GET ;GET THE BVC IO011 ; RECORD NUMBER IO012: TRAP+69. ;ILLEGAL RECORD FORMAT IO013: CMP (SP)+,(SP)+ ;POP JUNK SEC RTS PC IO011: TST R3 ;IS IT A VARIABLE OR CONSTANT? BGT IO012 ;NO CMP R2,#2 ;IS IT INTEGER? BNE IO012 ;NO JSR PC,PVAR ;OUTPUT THE PUSH TL05 ;YES, PUT LINES IN AS COMMENTS TST OSW ;IS USER SPECIFYING /AS? BEQ LSTL06 ;NO, DON'T WASTE TIME ON COMMENTS .IFTF LSTL05: INC R5 ;ALLOW POINTER TO INCLUDE ";" MOV #LSTL02,R4 ;DESCRIPTION OF OBJECT OUTPUT JSR PC,OUTPUT ;OUTPUT THE LINE LSTL06: RTS PC ;AND RETURN .IFT LSTL04: MOV (SP)+,R5 RTS PC .ENDC LSTL01: OUTHD ;SOURCE LIST BUFFER LINKSL ; AND LINK BLOCK LSTL02: COMHD ;OBJECT OUTPUT BUFFER LINKOL ; AND LINK BLOCK LISTL0: NUMHD LINKSL NUMHD: 8. 2 8. NB,FRLOW MOV #STCLR,R0 ;NOW FORT08: CLR (R0)+ ;CLEAR THE CMP R0,#ENDCLR ;TABLE BLO FORT08 ;LIST MOV FRLOW,SYMBAS ;THIS IS WHERE THE TABLE STARTS MOV SYMBAS,SYMEND ;GET END OF SYMBOL TABLE ADD #160.,SYMEND ;SET IT INITIALLY TO 10 SYMBOLS MOV SYMEND,FRLOW MOV SYMBAS,SYMCUR ;SET START OF ADD #2,SYMCUR ;FREE SPACE INC SERIAL ;SET SERIAL START TO ONE INC FLABL ;PRESET INTERNAL LABEL POINTER .IF NDF COM8K CLR PAGNUM MOV #60.,LINCT .GLOBL PAGNUM,LINCT .GLOBL TIM .TMCVT #TIM IO014: CMP 2(SP),#4 ;IS THIS ENCODE/DECODE? BGE EDCOD ;YES, GO GET ARRAY ADDRESS CMP #2,2(SP) ;IS THE CLASS 2 OR 3? BGT IO016 ;NO SUB @PC,2(SP) ;YES, CONVERT IT TO NORMAL CLASS(!! ?? !!) JSR PC,NXTCH ;GET A CHARACTER CMPB R2,#', ;IS IT A COMMA?? BEQ IO017 ;YES TST R2 ;IS THIS END OF LINE? BEQ IO17A ;YES, ALLOW IT TRAP+85. ;NO, ERROR BR IO013 IO17A: DEC R1 ;BACK UP OVER TERMINATOR IO017: MOVB #'),R2 ;PRETEND IT IS NORMAL READ OR WRITE BR IOGEN ;GO HANDLE REST OF STUFF IUF: .ASCII /0000 / .EVEN ; ; ITOA - INPUT IN R4 CONVERTED TO ASCII IN R3 LIST ; JTOA: MOV #ITA03,R5 BR ITA01 ITOA: MOV #ITA03+2,R5 ;GET POINTER TO FUDGES ITA01: MOVB #57,@R3 ;SET UP DIVIDEND FUDGE ITA02: INCB @R3 ;INCREMENT COUNT SUB @R5,R4 ;SUBTRACT THE CONSTANT BPL ITA02 ;LOOP UNTIL SIGN CHANGE ADD (R5)+,R4 ;NOW MAKE IT GOOD AGAIN INC R3 ;SKIP OVER CONVERTED CHARACTER TST @R5 BNE ITA01 ;LOOP FOR FOUR CHARACTERS RTS PC ITA03: 100;GET THE TIME OF DAY .GLOBL PAG JSR PC,PAG ;EJECT THE FIRST PAGE MOVB #14,FORMCH ;RESET FORM CONTROL TO .ENDC CLR ALOKAT CLR COMCLR CLR COMUN CLR EQVHED MOV FRHIGH,OLDHGH ;REMEMBER OLD HIGH FOR LATER USE MOV #IMPTAB,R0 ;GET READY TO SET UP IMPLICIT IMPLP: MOVB #030,(R0)+ ;PRESTORE TYPE "REAL" CMP R0,#IMPTAB+26. ;ALL 26 LETTERS BLO IMPLP ;ARE DONE MOV #IMPTAB+8.,R0 ;POINT TO INTEGERS IMPLP2: MOVB #020,(R0)+ ;PRESTORE "INTEGER" CMO016: JSR PC,NXTCH ;GET A CHARACTER CMPB R2,#') ;END OF I/O DESCRIPTION?? BNE MPAR ;NOT NECESSARILY BR IOGEN MPAR: CMPB R2,#', ;CHECK FOR COMMA BEQ IOGEN ;JUMP IF OK TRAP+70. ;GIVE MISSING PAREN ERROR BR IO013 ; EDERR: TRAP+117. ;NO BUFFER ADDRESS BR IO013 ;PUNT ; EDCOD: JSR PC,NXTCH ;GET A CHARACTER CMPB R2,#', ;IS THERE A COMMA PRESENT? BNE EDERR ;NO, OOPS JSR PC,GET ;GET THE ARRAY DESCRIPTOR CMP R3,#1 ;IS IT AN ARRAY?? BNE EDERR ;NO JSR PC,PVAR ;YES, GO OUTPUT00. 1750 ;1,000 144 ;100 12 ;10 1 ;1 0 ;TERMINATOR ; ; OUTFIN - EMPTY THE TEMPORARY BUFFER ; .GLOBL OUTFIN OUTFIN: MOV R4,-(SP) MOV R5,-(SP) CMP CHRPNT,#CHRBUF ;IS BUFFER EMPTY? BEQ OUTPTX ;YES MOV CHRPNT,R5 ;GET POINTER SUB #CHRBUF,R5 ;GET COUNT MOV #CHRBUF,GBUF+6 ;STORE ADDRESS MOV #OUTL01,R4 ;GET HEADER STUFF JSR PC,OUTPTI ;OUTPUT THE BLOCK MOV #CHRBUF,CHRPNT ;SET POINTER TO EMPTY OUTPTX: MOV (SP)+,R5 MOV (SP)+,R4 RTSP R0,#IMPTAB+14. ;IN 6 OF THEM BLO IMPLP2 ;NOW WE HAVE A FRESH TABLE MOV #ERRS,ERRCUR ;INITIALIZE ERROR TABLE JMP SCANNR ;GO DO SOME FORTRAN STKOVF: MOV PC,-(SP) MOV #1401,-(SP) ;SET STACK OVERFLOW ERROR IOT ;F001 ERROR ;THE DEFAULT EXTENSION ON INPUT WAS NOT THERE FORT04: CLR SRCERR ;TURN OFF ERROR RETURN CLR SRCEXT ;SET NULL EXTENSION JMP FORT27 ;GO TRY TO FIND IT LSTDEL: CLR LSTER .DELET #LINKSL,#SRCLS ;DELETE LISTING FILE JMP LSTD1 OBJDEL: CLR OBJER ;DELETE .DELET #LINK THE MESS BR IO016 ;AND CONTINUE ; ; UPON ENTRY TO IOGEN, R2 WILL CONTAIN EITHER A COMMA OR A ; RIGHT PAREN. IF A COMMA, THE END AND ERR CONDITIONS ; MUST BE CHECKED, IF A RIGHT PAREN, END AND ERR ARE NULL. ; ; THE TOP OF THE STACK IS: ; -1 IF RANDOM ACCESS ; 0 IF UNFORMATTED ; +1 IF FORMATTED ; ; THE SECOND ITEM OF THE STACK IS: ; -1 IF FIND ; 0 IF READ ; +1 IF WRITE ; +4 IF ENCODE ; +5 IF DECODE ; IOG06: BISB BITM+5,MISC+4 ;SET ENCODE FLAG MOV #P8,R4 ;GET ADDRESS OF ENCODE S PC ; ; OUTPUT - OUTPUT A LINE, R4 POINTS TO THE I/O DESCRIPTOR, R5 CONTAINS ; THE CHARACTER COUNT. THE I/O DESCRIPTOR CONSISTS OF ; TWO WORDS, THE FIRST OF WHICH IS THE ADDRESS OF THE ; DESIRED BUFFER HEADER, THE SECOND OF WHICH IS THE ; CORRESPONDING LINK BLOCK ADDRESS. ; REGISTERS CHANGED - R4,R5. ; OUTPUT: CMP 2(R4),#LINKOL ;IS THE OUTPUT TO THE BINARY FILE? BNE OUTPTI ;NO, DON'T DUMP SMALL BUFFER JSR PC,OUTFIN ;TERMINATE LOCAL BUFFER OUTPTI: MOOL,#OBJLS ;DELETE OBJECT FILE JMP OBJD1 EXIT: MOV #DOLST,R5 ;GET A TEMPORARY BUFFER MOV R5,GBUF+6 ;REMEMBER WHERE IT IS TST SWVAL ;ANY SWITCHES? BEQ 99$ ;NO MOV #1,R0 ;PRESET THE MASK MOV #SWLST,R2 ;GET PROTOTYPE LIST MOV #/2,R1 ;NUMBER OF WORDS TO TRANSFER MOV #SWPRT,R3 1$: MOV (R3)+,(R5)+ ;STORE A WORD DEC R1 ;DONE YET? BNE 1$ ;NO 2$: ASL R0 ;SHIFT THE MASK INTO POSITION BCS 5$ ;ARE WE DONE? BIT R0,SWVAL ;IS THE SWITTRING BR IOG6B IOG6A: BISB BITM+6,MISC+4 ;SET DECODE FLAG MOV #P9,R4 ;GET ADDRESS OF DECODE STRING IOG6B: JSR PC,PUTNAM ;GET THE NAME BITB BITM-4(R5),MISC+5 ;DO WE ALREADY HAVE IT? BNE IOG03 ;YES BISB BITM-4(R5),MISC+5 ;NO, BUT SET IT FOUND BR IOG06C ;AND OUTPUT THE REST OF IT ; IOGEN: MOV 2(SP),R5 ;GET THE I/O TYPE BLT IOG04 ;SKIP IF FIND BGT IOG05 ;IT IS A WRITE BISB BITM+0,MISC+4 ;SET THE READ GLOBAL BR IOG04 IOG05: CMP R5,#4 ;IS IT ENCODE/DECODE? BEQ IOG06 ;YES, DON'T V R3,-(SP) ;SAVE R3 MOV (R4)+,R3 ;GET HEADER ADDRESS MOV R5,4(R3) ;SAVE BYTE COUNT MOV R3,-(SP) ;PUSH BUFFER HEADER POINTER MOV (R4)+,R3 ;GET LINK BLOCK .IF NDF COM8K .GLOBL OSW,LINKAS TST OSW ;IS THIS ASSEMBLER OUTPUT? BNE OUT002 ;NO CMP R3,#LINKOL ;IS THIS TO THE ASSEMBLER FILE? BNE OUT002 ;NO MOV #LINKAS,R3 ;YES, SUBSTITUTE DIFFERENT FILE OUT002: .IFTF TST 6(R3) ;IS IT BEING USED? BEQ OUTNO ;NO, DON'T OUTPUT IT MOV R3,-(SP) ;STORE LINK BLOCK CMP R3,#LINKOL ;IS THE !CH SET? BNE 3$ ;YES TST (R2)+ ;SKIP OVER ASCII SWITCH BR 2$ ;CONTINUE LOOP 3$: MOVB #'/,(R5)+ ;STORE A SLASH MOVB (R2)+,(R5)+ ;AND THE MOVB (R2)+,(R5)+ ;SWITCH NAME CMPB #'P,-1(R5) BNE 4$ CMPB #'O,-2(R5) BNE 4$ MOVB #':,(R5)+ MOVB OPTLVL,R4 ADD #'0,R4 MOVB R4,(R5)+ 4$: MOVB #',,(R5)+ ;NOW A COMMA BR 2$ ;GO DO NEXT SWITCH 5$: DEC R5 ;BACK UP OVER LAST COMMA MOVB #15,(R5)+ ;STORE MOVB #12,(R5)+ ;TERMINATOR SUB #DOLST,R5 ;GET LINE LENGTH MOV #SWDSC,R4 ;GET DESCRIPT" NEED GLOBAL HERE BGT IOG6A BISB BITM+1,MISC+4 ;SET THE WRITE GLOBAL IOG04: INC R5 ;AND MOV R5,R3 ; MULTIPLY ASL R3 ; BY ADD R3,R5 ; THREE MOV @SP,R3 ;GET THE INC R3 ; FORMATTING ADD R3,R5 ;WE NOW HAVE A TABLE INDEX SUB #2,R5 ; WHICH MAY BE USED TO OUTPUT ASCII BPL IOG01 ;FUDGE CLR R5 ; THE FIND INDICATOR IOG01: MOV R5,R3 ;PICK UP A WORD ASL R3 ; INDEX TOO MOV IOG02(R3),R4 ;GET ASCII ADDRESS JSR PC,PUTNAM ;GET THE NAME BITB BITM(R5),MISC+2 ;SEE IF WE ALREADY $OUTPUT ON THE OBJECT DEVICE? BEQ OUT004 ;YES .IFF BR OUT001 .IFT CMP R3,#LINKAS BNE OUT001 .IFTF OUT004: MOV 2(SP),R3 ;GET BUFFER HEADER CMP 4(R3),#64. ;IS THE BYTE COUNT > 64.?? BLE OUT001 ;NO, FIXING NOT NEEDED MOV #64.,4(R3) ;RESET THE BYTE COUNT MOV 6(R3),R3 ;GET THE ADDRESS OF THE BUFFER MOVB #15,62.(R3) ;AND TERMINATE MOVB #12,63.(R3) ;THE BUFFER OUT001: WRITE ;DO THE WRITE MOV -(R4),-(SP) ;GET LINK BLOCK POINTER AGAIN .IFT TST OSW ;IS THIS ASSEMBLER OUTPUT? %OR BLOCK JSR PC,OUTPUT ;PUT OUT THE LINE 99$: .IF NDF COM8K TST OSW ;ASSEMBLY NEEDED? BNE EXIT1 ;NO .CLOSE #LINKAS ;CLOSE ASSEMBLER FILE JSR PC,PALFTN ;GO ASSEMBLE IT .GLOBL PALFTN .GLOBL CURLN MOV R1,R4 ;GET THE ASSEMBLER USED CORE MOV #ASMUSE,R3 ;GET ADDRESS OF ASCII BUFFER JSR PC,JTOA ;CONVERT TO ASCII MOV R0,R4 ;GET FREE CORE MOV #ASMFRE,R3 ;AND ADDRESS JSR PC,JTOA ;CONVERT TO ASCII JSR PC,PRXSUM ;PRINT THE CORE SUMMARY ;C&HAD ONE BNE IOG03 BISB BITM(R5),MISC+2 ;SET FOUND BIT IOG06C: JSR PC,OUTGL ;GENERATE THE JSR PC,EOL ; GLOBAL IOG03: JSR PC,OUTNAM ;NOW OUTPUT THE NAME JSR PC,OUTCOM ;AND CONTINUE TST (SP)+ ;DISCARD TOP OF STACK CMP R2,#') ;IS THIS A NULL END OR ERR?? BNE IOG07 ;NO JSR R5,OUTLN2 ;YES, OUTPUT A NULL LIST INIT05 IOG14: TST (SP) ;IS THE I/O VERB 'FIND' ? BPL IOGOK ;NO - ALL OK JSR PC,CNXC ;CHECK FOR END OF LINE AFTER 'FIND' BEQ IOGERR ;OK, BUT SET C=1 FOR 'FIND' TRAP+12.( BNE OUT003 ;NO CMP @SP,#LINKOL BNE OUT003 MOV #LINKAS,@SP ;YES, SELECT DIFFERENT FILE OUT003: .ENDC MWAIT ;WAIT FOR COMPLETION MOV -(R4),R3 ;BUFFER HEADER ADDRESS BITB #100,3(R3) ;END-OF-MEDIUM? BEQ OUT1 MOV PC,-(SP) ;REQUEST ADDRESS MOV #1400+6,-(SP) ;F006 IOT ;DOES NOT RETURN OUT1: MOV (SP)+,R3 ;RESTORE R3 RTS PC OUTNO: TST (SP)+ ;DISCARD ELEMENT ON STACK BR OUT1 ; ; OUTLST - OUTPUT TO LISTING DEVICE ONLY ; INPUT: R4 = TEXT START ; R5 = CHAR COUNT ; NOTE: APPEN)HECK FOR FATAL ASSEMBLE PHASE ERROR ;I.E. SYMBOL TABLE OVERFLOW ;IF FOUND THEN END THIS COMPILATION NOW CMP #ERRS,ERRCUR BNE EXIT1B ;YES - ERROR TST CURLN ;WAS THERE AN EOF ON INPUT? BMI EXIT1B ;YES INCB RUNCT ;SET /CC SWITCH JMP FORT07 .IFTF EXIT1: JSR PC,PRTSUM .IFF MOV LOWCOR,SP ;RESET STACK FOR 8K USER .ENDC EXIT1B: CLR CURLN ;RESET END OF FILE FLAG JSR PC,RLSALL ;TURN OFF ALL CURRENT FILES .INIT #LINKK ;RE-INIT THE .INIT #* ;ILLEGAL STATEMENT FORM IOGERR: TST (SP)+ ;POP I/O VERB CODE SEC ;INDICATE SOME ERROR RTS PC IOGOK: TST (SP)+ ;POP I/O VERB CODE, SET C=0 RTS PC BADIO2: TST (SP)+ ;POP JUNK ITEM JMP BADIO1 ;AND CALL REAL ERROR IOG07: MOV #OPTLST,R0 ;CHECK JSR PC,SCAN2A ; FOR END= OR ERR= BVS BADIO2 ;NOT A LEGAL FORM TST R0 ;WAS END= SPECIFIED? BGT IOG08 ;NO JSR R5,OUTCH2 ;YES, OUTPUT '. JSR PC,OUTSL ;THE LABEL BVS IOG09 JSR PC,OUTCOM ;NOW OUTPUT A COMMA JSR PC,NXTCH ;GET THE,DS A TO END OF TEXT ; .GLOBL OUTLST,GBUF,LINKSL OUTLST: JSR PC,PAG MOV R4,GBUF+6 MOV #SWDSC,R4 JSR PC,OUTPUT MOV #EOL1,GBUF+6 MOV #2,R5 MOV #SWDSC,R4 JSR PC,OUTPUT RTS PC ; SWDSC: .WORD GBUF,LINKSL ;DOS DECSRIPTOR ; ; OUTLN - OUTPUT A LINE OF ASCII TO THE OBJECT DEVICE. R4 HAS ; ADDRESS OF THE STRING, R5 HAS THE COUNT. ; REGISTERS CHANGED - R4,R5. ; .GLOBL CHRBUF,CHREND,CHRLG,CHRPNT OUTLN: MOV R3,-(SP) ;SAVE R3 OUTX03: MOV C-LINKL ;TELETYPE ; OUTPUT THE ERROR COUNT IF ANY MOV ECNT,R4 ;GET ERROR COUNT BEQ FORT9A ;EXIT IF NONE CLR ECNT ;CLEAR COUNT MOVB #' ,R2 CMP R4,#1 ;ONLY ONE ERROR?? BEQ FORT9B ;YES MOVB #'S,R2 ;MORE THAN ONE FORT9B: MOVB R2,ERR1 MOV #ERR,R3 ;GET ADDRESS OF JSR PC,ITOA ;DESTINATION AND CONVERT TO ASCII MOV #ENDERR,R5 ;GET COUNT, MOV #ERR,GBUF+6 ;BUFFER ADDRESS, MOV #DESC,R4 ;AND I/O DESCRIPTOR JSR PC,OUTPUT ;GIVE USER THE BAD NEWS FORT9A: CMP #ERRS,ERRCUR ;ASSEMBLY FATA. NEXT CHARACTER CMPB R2,#') ;IS IT A RIGHT PAREN?? BNE IOG10 ;NO, CHECK FOR COMMA JSR R5,OUTCH2 ;OUTPUT A NULL ERR ENTRY '0 IOG11: JSR PC,EOL ;AND AN END OF LINE BR IOG14 ;NOW GO HANDLE THE LIST IOG10: CMPB R2,#', ;IS THERE A COMMA?? BNE IOG09 ;NO MOV #OPTLST,R0 ;CHECK FOR ERR= JSR PC,SCAN2A ; NOW BVS IOG09 ;IT IS NOT THERE TST R0 ;IS IT ERR= ?? BEQ IOG09 ;NO, IS NOT IOG12: JSR R5,OUTCH2 ;SO OUTPUT '. JSR PC,OUTSL ; THE LABEL BVS IOG09 ;ALL IS GOODNESS NOW JSR PC2HRPNT,R3 ;GET CURRENT POINTER CMP R3,#CHREND ;IS THE BUFFER ALREADY FULL? BHIS OUTX04 ;YES OUTX02: MOVB (R4)+,(R3)+ ;STORE A CHARACTER DEC R5 ;DECREMENT COUNT BLE OUTX01 ;UNTIL DONE CMP R3,#CHREND ;IS BUFFER FULL? BLO OUTX02 ;NO OUTX04: MOV R3,CHRPNT JSR PC,OUTFIN ;YES, EMPTY IT BR OUTX03 ;AND CONTINUE OUTX01: MOV R3,CHRPNT ;REMEMBER CURRENT POSITION MOV (SP)+,R3 ;RESTORE R3 RTS PC ;AND RETURN OUTL01: GBUF ;GENERAL BUFFER HEADER LINKOL ;OBJECT LINK BLOCK ; ; OUTLN1 - 1L ERROR? BEQ 3$ ;NO MOV #FATLGT,R5 ;YES - SAY SO MOV #FATASM,GBUF+6 MOV #DESC,R4 JSR PC,OUTPUT 3$: .IF NDF COM8K TSTB RUNFG ;/GO SWITCH SET? BEQ 1$ ;NO TSTB RUNER ;FATAL ERROR FLAG SET? BEQ 2$ ;NO MOV #EXLGT,R5 ;YES, TELL HIM MOV #EXDLT,GBUF+6 ;THAT MOV #DESC,R4 ;EXECUTION JSR PC,OUTPUT ;WAS DELETED BR 1$ 2$: .RLSE #LINKK .RLSE #LINKL .GLOBL TLB,DGBLK .IF DF NOOVL .IFF .RLSE #TLB .ENDC .RLSE #DGBLK JMP RUNLNK ;GO CALL THE LINKER .GLOBL RUNLNK .ENDC3,NXTCH ;GET A CHARACTER CMPB R2,#') ;MAKE SURE IT IS A RIGHT PAREN BEQ IOG11 ;IT IS IOG09: TRAP+71. ;ILLEGAL END= AND/OR ERR= BR IOGERR ;COMMON ERROR EXIT IOG08: JSR R5,OUTCH2 '0 JSR PC,OUTCOM BR IOG12 ; ; GENERATE ADDRESS PUSH FOR VARIABLE ; PVAR: CLRB LSTOUT MOV CURSYM,R0 ;GET ADDRESS OF ENTRY MOV #FMPSH,R4 ;ADDRESS OF PROTOTYPE JSR PC,PUTNAM ;PUT NAME IN LIMBO BIT #PARMKM,PARWD(R0) ;IS IT A PARAMETER????? BEQ PVAR01 ;NO MOV #5 1$: JMP RSET01 ;AND TRY IT ALL AGAIN WKLST: LINKI LINKSL LINKOL .IF NDF COM8K LINKAS .ENDC 0 ; ; RELEASE ANY FILES OPEN WHICH ARE SPECIFIED IN THE LIST ; "WKLST" ; RLSALL: MOV #WKLST,R0 ;GET ADDRESS OF LIST RSET04: MOV (R0)+,R1 ;GET THE LINK BLOCK ADDRESS BEQ RSET06 ;EXIT WHEN DONE TST @R1 ;IS IT INITED? BEQ RSET04 ;NO MOV #RSET05,-2(R1) ;SET THE ERROR RETURN .CLOSE R1 ;AND CLOSE THE THING RSET05: CLR -2(R1) ;CLEAR THE ERROR RET6OUTPUT A LINE WITH A ZERO TERMINATOR, R4 HAS THE STRING ; ADDRESS. ; REGISTERS CHANGED - R4. ; OUTLN1: MOV R5,-(SP) ;SAVE R5 MOV R4,R5 ;GET START OUTL02: TSTB (R5)+ ;COUNT THE CHARACTERS BNE OUTL02 SUB R4,R5 ;COMPUTE DEC R5 ;THE BYTE COUNT JSR PC,OUTLN ;GO OUTPUT THE LINE MOV (SP)+,R5 ;RESTORE R5 RTS PC ;AND RETURN TO CALLER OUTLN2: MOV (R5)+,R4 ;GET ADDRESS OF STRING JSR PC,OUTLN1 ;PRINT IT RTS R5 ; ; ; GENERATE END OF LINE ; EOL:7'P,R4 JSR PC,PUTCHR ;FLAG IT AS A PARAMETER BITB BITM+2,MISC+1 ;DO WE NEED A GLOBL?? BNE PVAR02 ;NO BISB BITM+2,MISC+1 ;YES, SET IT DONE JSR PC,OUTGL ;OUTPUT THE GLOBAL JSR PC,EOL ;AND AN END OF LINE PVAR02: JSR PC,OUTNAM ;OUTPUT THE NAME JSR PC,OUTCOM ;AND A COMMA MOVB PARXWD(R0),R3 ;GET THE PARAMETER INDEX BIC #177400,R3 JSR PC,OUTOCT BR PVAR03 PVAR01: JSR PC,PVX JSR PC,OUTST ;AND THE SYMBOL NAME PVAR03: JSR PC,EOL ;FINALLY AN END OF LINE RTS PC PVX: BITB BITM+1,MISC ; ND.E C ND.E X BET IS.L . = D ENUM S> 12><15//AB 12><15 <12>/OPTIONS = / SWEND = . : JSR R5,OUTLN2 EOL1 RTS PC EOL1: .BYTE 15,12,0 .EVEN ; ; OUTPUT SINGLE CHARACTER IN R4 ; OUTCHR: MOVB R4,CHR JSR R5,OUTLN2 CHR RTS PC CHR: 0 OUTCH2: MOV (R5)+,CHR JSR R5,OUTLN2 CHR RTS R5 .IF NDF COM8K ; ; PAGE HEADER ROUTINE ; .GLOBL PAG,PAGNUM,PNUM,TLGT,LINCT,TITL ; PAG: TST LSTVAL ;MINIMUM LISTING? BEQ PAG02 ;YES, DON'T DO ANY PAGING INC LINCT ;ADVANCE LINE COUNT CMP LINCT,#56. ;DID IT OVERFLOW? BLT PAG02 ;NO MOV R?DO WE NEED A GLOBAL? BNE PVAR04 ;NO BISB BITM+1,MISC ;SET THE DONE BIT JSR PC,OUTGL ;OUTPUT THE GLOBAL JSR PC,EOL ;AND AN END OF LINE PVAR04: JSR PC,OUTNAM ;OUTPUT THE NAME JSR PC,OUTCOM ;AND A COMMA RTS PC ; ; MODE: .BYTE 'B,'L,'I,'R,'D,'C,'X,'A .EVEN OPTLST: OPT1 OPT2 OPTEND 0 OPT1: .ASCII /END=/ OPT2: .ASCII /ERR=/ OPTEND = . .EVEN FMPSH: .ASCII / $PSH/ .BYTE 0 FMTLAB: .BYTE '0 FMTLB1: .BYTE 15,12,0 .EVEN IOG02: P1,P2,P3,P4S LEABUTECEX>/AB<15><1I CIAS . X/XXXX /IISC.A: RECFDE /XXXX/XI CIAS .E:USEC D/ S VETIRALAEC/DB>TA><12><15 /AB<15><1I CIAS . */E*OR C---- -ERILMPCO**>/AB<15><1I CIAS .M:SUOR CX BET ISNL . ;F FT.I X RT PBR T UNCOR TEACARCH ;R5M,SUOR-CNDMESU #OV M ESIN LVEFI ;G PAC, PSR J UT ONTOU;CT NCLI5, #DD AM:SURX PT IF . RNTURED AN ;C PTS R RYMAUM SHE TUTTPOU ;UTTPOUC, PSR J ORPTRISCDEF OSSREDD AET;G4 ,RSCWD#SV MO S ESDRADP UET;S6 F+BU,GUMRSCO #OV M R5+,= .EVEN DESC: GBUF LINKL TITLE: .BYTE '#,13 TEND =.-TITLE .EVEN ERR: .ASCII /0000 ERROR/ ERR1: .ASCII /S/ .BYTE 15,12 ENDERR = .-ERR .EVEN FORT11: .RAD50 /PAL/ FORT12: .RAD50 /LST/ FORT14: .RAD50 /FTN/ .IF NDF COM8K FORT23: .RAD50 /OBJ/ EXDLT: .ASCII /EXECUTION DELETED/<15><12> EXLGT = .-EXDLT .ENDC FATASM: .ASCII /FATAL ERROR IN ASSEMBLY PHASE/<15><12> FATLGT =.-FATASM .LIST BEX .EVEN ; ;CORE SUMMARY ; .GLOBL DECUSE,DECFRE,EXCUSE,>3,-(SP) MOV R4,-(SP) MOV R5,-(SP) INC PAGNUM ;ADVANCE PAGE NUMBER MOV PAGNUM,R4 ;GET PAGE NUMBER MOV #PNUM,R3 ;GET BUFFER ADDRESS JSR PC,ITOA ;CONVERT TO ASCII MOV #PNUM,R3 PAG04: CMPB (R3),#'0 ;IS THIS A LEADING ZERO? BNE PAG03 ;NO, QUIT MOVB #' ,(R3)+ ;BLANK THE CHARACTER BR PAG04 ;AND RE-LOOP PAG03: MOV #TITL,GBUF+6 ;GET ADDRESS OF STRING MOV #TLGT,R5 ;GET COUNT MOV #PAG01,R4 ;GET DESCRIPTOR JSR PC,OUTPUT ;OUTPUT THE LINE CLR LINCT ;RESET LINE COUNT MOV (SP)+,R5 MP)(SV MO OAJTC, PSR J R41, ROV M R3C IN A TO,JPCR JS 3 ,RSECUDE #OV M DSOR WINE ACSPT GE ;4 ,RR1B SU: 2$ ROZEO TFTLEE ACSPT SE, ES;Y R1R CL O ;N 2$O BL ? CEPA SOFT OUN RU ;4 ,RR1P CM S RDWON ;I R1R RO C CL E ACSPD SE UET;G1 ,ROWDLOLB SU H IG HVETIRALAEC DET;G1 ,RGHDHOLV MO N AIAGE AGORSTX MAT GE ;4 ,RR0V MO I CIASO TRTVEON;C OAJTC, PSR J CEPA SEEFRT GE ;4 ,RR1V MO A RE ACEPA SEEFRO TNTOI;P R3C IN I CIASO TRTVEON;C OAJTC, PSR J R3E,USXCEXCFRE,JTOA PRTSUM: .IF NDF COM8K .GLOBL ASMFRE,ASMUSE ADD #4,LINCT ;COUNT OUT JSR PC,PAG ;FOUR LINES .IFTF MOV #ENDASM-CORSUM,R5 ;GET CHARACTER COUNT PRTX: MOV R5,-(SP) MOV LOWCOR,R0 ;GET MAX SUB MTOP,R0 ;AREA SUB #512.,R0 ;TAKE OUT THE MONITOR FUDGE CLC ROR R0 ;HERE MOV R0,R4 MOV FRHIGH,R1 ;GET SUB FRLOW,R1 ;EXECUTABLE CLC ROR R1 ;FREE SPACE CMP R1,R4 ;RUN OUT OF SPACE? BLO 1$ ;NO CLR R1 ;SET FREE SPACE TO ZERO 1$: SUB R1,R4 ;GET USED SPACE IN R4 MOV #EOV (SP)+,R4 MOV (SP)+,R3 PAG02: RTS PC PAG01: GBUF LINKSL .ENDC .END ,P5,P6,P7 P1: .ASCII / $FIND/ .BYTE 0 P2: .ASCII / $INRI/ .BYTE 0 P3: .ASCII / $INI/ .BYTE 0 P4: .ASCII / $INFI/ .BYTE 0 P5: .ASCII / $OUTRI/ .BYTE 0 P6: .ASCII / $OUTI/ .BYTE 0 P7: .ASCII / $OUTFI/ .BYTE 0 P8: .ASCII / $ENCD/ .BYTE 0 P9: .ASCII / $DECD/ .BYTE 0 INIT05: .ASCIZ /0,0/<15><12> .EVEN .END